Update typeClasses in env to match psc

Update typeClasses in env to match psc

module Language.PureScript.Environment where

import Data.Maybe
import Data.Tuple
import Data.Tuple3

import Language.PureScript.Kinds
import Language.PureScript.Names
import Language.PureScript.TypeClassDictionaries
import Language.PureScript.Types

import qualified Language.PureScript.Constants as C
import qualified Data.Map as M

-- |
-- The @Environment@ defines all values and types which are currently in scope:
--
data Environment = Environment {
  -- |
  -- Value names currently in scope
  --
    names :: M.Map (Tuple ModuleName Ident) (Tuple Type NameKind)
  -- |
  -- Type names currently in scope
  --
  , types :: M.Map (Qualified ProperName) (Tuple Kind TypeKind)
  -- |
  -- Data constructors currently in scope, along with their associated data type constructors
  --
  , dataConstructors :: M.Map (Qualified ProperName) (Tuple ProperName Type)
  -- |
  -- Type synonyms currently in scope
  --
  , typeSynonyms :: M.Map (Qualified ProperName) (Tuple [String] Type)
  -- |
  -- Available type class dictionaries
  --
  , typeClassDictionaries :: [TypeClassDictionaryInScope]
  -- |
  -- Type classes
  --
  , typeClasses :: M.Map (Qualified ProperName) (Tuple3 [String] [Tuple Ident Type] [Tuple (Qualified ProperName) [Type]])
  }

instance showEnv :: Show Environment where
  show (Environment o) = "Environment {" ++
    "names: " ++ show o.names ++ ", " ++
    "types: " ++ show o.types ++ ", " ++
    "dataConstructors: " ++ show o.dataConstructors ++ ", " ++
    "typeSynonyms: " ++ show o.typeSynonyms ++ ", " ++
    "typeClassDictionaries: " ++ show o.typeClassDictionaries ++ ", " ++
    "typeClasses: " ++ show o.typeClasses ++ " " ++
    "}"

-- |
-- The initial environment with no values and only the default javascript types defined
--
initEnvironment :: Environment
initEnvironment = Environment { names: M.empty
                              , types: primTypes
                              , dataConstructors: M.empty
                              , typeSynonyms: M.empty
                              , typeClassDictionaries: []
                              , typeClasses: M.empty
                              }

-- |
-- The type of a foreign import
--
data ForeignImportType
  -- |
  -- A regular foreign import
  --
  = ForeignImport
  -- |
  -- A foreign import which contains inline Javascript as a string literal
  --
  | InlineJavascript

instance showForeignImport :: Show ForeignImportType where
  show ForeignImport = "ForeignImport"
  show InlineJavascript = "InlineJavascript"

instance eqForeignImport :: Eq ForeignImportType where
  (==) ForeignImport           ForeignImport           = true
  (==) InlineJavascript        InlineJavascript        = true
  (==) _ _ = false
  (/=) x y = not (x == y)

-- |
-- The kind of a name
--
data NameKind
  -- |
  -- A value introduced as a binding in a module
  --
  = Value
  -- |
  -- A foreign import
  --
  | Extern ForeignImportType
  -- |
  -- A local name introduced using a lambda abstraction, variable introduction or binder
  --
  | LocalVariable
  -- |
  -- A data constructor
  --
  | DataConstructor
  -- |
  -- A type class dictionary, generated during desugaring of type class declarations
  --
  | TypeInstanceDictionaryValue
  -- |
  -- A type instance member, generated during desugaring of type class declarations
  --
  | TypeInstanceMember
  -- |
  -- A type class dictionary member accessor import, generated during desugaring of type class declarations
  --
  | TypeClassAccessorImport

instance showNameKind :: Show NameKind where
  show Value = "Value"
  show (Extern fit) = "Extern (" ++ show fit ++ ")"
  show LocalVariable = "LocalVariable"
  show DataConstructor = "DataConstructor"
  show TypeInstanceDictionaryValue = "TypeInstanceDictionaryValue"
  show TypeInstanceMember = "TypeInstanceMember"
  show TypeClassAccessorImport = "TypeClassAccessorImport"

instance eqNameKind :: Eq NameKind where
  (==) Value                       Value                       = true
  (==) (Extern t1)                 (Extern t2)                 = t1 == t2
  (==) LocalVariable               LocalVariable               = true
  (==) DataConstructor             DataConstructor             = true
  (==) TypeInstanceDictionaryValue TypeInstanceDictionaryValue = true
  (==) TypeInstanceMember          TypeInstanceMember          = true
  (==) TypeClassAccessorImport     TypeClassAccessorImport     = true
  (==) _ _ = false
  (/=) x y = not (x == y)

-- |
-- The kinds of a type
--
data TypeKind
  -- |
  -- Data type
  --
  = DataType [String] [Tuple ProperName [Type]]
  -- |
  -- Type synonym
  --
  | TypeSynonym
  -- |
  -- Foreign data
  --
  | ExternData
  -- |
  -- A local type variable
  --
  | LocalTypeVariable

instance showTypeKind :: Show TypeKind where
  show (DataType args dctors) = "DataType (" ++ show args ++ ") (" ++ show dctors ++ ")"
  show TypeSynonym = "TypeSynonym"
  show ExternData = "ExternData"
  show LocalTypeVariable = "LocalTypeVariable"

instance eqTypeKind :: Eq TypeKind where
  (==) (DataType args1 tys1) (DataType args2 tys2) = args1 == args2 && tys1 == tys2
  (==) TypeSynonym           TypeSynonym           = true
  (==) ExternData            ExternData            = true
  (==) LocalTypeVariable     LocalTypeVariable     = true
  (==) _ _ = false
  (/=) x y = not (x == y)

-- |
-- Construct a ProperName in the Prim module
--
primName :: String -> Qualified ProperName
primName = Qualified (Just $ ModuleName [ProperName C.prim]) <<< ProperName

-- |
-- Construct a type in the Prim module
--
primTy :: String -> Type
primTy = TypeConstructor <<< primName

-- |
-- Type constructor for functions
--
tyFunction :: Type
tyFunction = primTy "Function"

-- |
-- Type constructor for strings
--
tyString :: Type
tyString = primTy "String"

-- |
-- Type constructor for numbers
--
tyNumber :: Type
tyNumber = primTy "Number"

-- |
-- Type constructor for booleans
--
tyBoolean :: Type
tyBoolean = primTy "Boolean"

-- |
-- Type constructor for arrays
--
tyArray :: Type
tyArray = primTy "Array"

-- |
-- Type constructor for objects
--
tyObject :: Type
tyObject = primTy "Object"

-- |
-- Smart constructor for function types
--
function :: Type -> Type -> Type
function t1 = TypeApp (TypeApp tyFunction t1)

-- |
-- The primitive types in the external javascript environment with their associated kinds.
--
primTypes :: M.Map (Qualified ProperName) (Tuple Kind TypeKind)
primTypes = M.fromList [ Tuple (primName "Function") (Tuple (FunKind Star (FunKind Star Star)) ExternData)
                       , Tuple (primName "Array")    (Tuple (FunKind Star Star) ExternData)
                       , Tuple (primName "Object")   (Tuple (FunKind (Row Star) Star) ExternData)
                       , Tuple (primName "String")   (Tuple Star ExternData)
                       , Tuple (primName "Number")   (Tuple Star ExternData)
                       , Tuple (primName "Boolean")  (Tuple Star ExternData) ]

module Language.PureScript.Environment where

import Data.Maybe
import Data.Tuple

import Language.PureScript.Kinds
import Language.PureScript.Names
import Language.PureScript.TypeClassDictionaries
import Language.PureScript.Types

import qualified Language.PureScript.Constants as C
import qualified Data.Map as M

-- |
-- The @Environment@ defines all values and types which are currently in scope:
--
data Environment = Environment {
  -- |
  -- Value names currently in scope
  --
    names :: M.Map (Tuple ModuleName Ident) (Tuple Type NameKind)
  -- |
  -- Type names currently in scope
  --
  , types :: M.Map (Qualified ProperName) (Tuple Kind TypeKind)
  -- |
  -- Data constructors currently in scope, along with their associated data type constructors
  --
  , dataConstructors :: M.Map (Qualified ProperName) (Tuple ProperName Type)
  -- |
  -- Type synonyms currently in scope
  --
  , typeSynonyms :: M.Map (Qualified ProperName) (Tuple [String] Type)
  -- |
  -- Available type class dictionaries
  --
  , typeClassDictionaries :: [TypeClassDictionaryInScope]
  -- |
  -- Type classes
  --
  , typeClasses :: M.Map (Qualified ProperName) (Tuple [String] [Tuple Ident Type])
  }

instance showEnv :: Show Environment where
  show (Environment o) = "Environment {" ++
    "names: " ++ show o.names ++ ", " ++
    "types: " ++ show o.types ++ ", " ++
    "dataConstructors: " ++ show o.dataConstructors ++ ", " ++
    "typeSynonyms: " ++ show o.typeSynonyms ++ ", " ++
    "typeClassDictionaries: " ++ show o.typeClassDictionaries ++ ", " ++
    "typeClasses: " ++ show o.typeClasses ++ " " ++
    "}"

-- |
-- The initial environment with no values and only the default javascript types defined
--
initEnvironment :: Environment
initEnvironment = Environment { names: M.empty
                              , types: primTypes
                              , dataConstructors: M.empty
                              , typeSynonyms: M.empty
                              , typeClassDictionaries: []
                              , typeClasses: M.empty
                              }

-- |
-- The type of a foreign import
--
data ForeignImportType
  -- |
  -- A regular foreign import
  --
  = ForeignImport
  -- |
  -- A foreign import which contains inline Javascript as a string literal
  --
  | InlineJavascript

instance showForeignImport :: Show ForeignImportType where
  show ForeignImport = "ForeignImport"
  show InlineJavascript = "InlineJavascript"

instance eqForeignImport :: Eq ForeignImportType where
  (==) ForeignImport           ForeignImport           = true
  (==) InlineJavascript        InlineJavascript        = true
  (==) _ _ = false
  (/=) x y = not (x == y)

-- |
-- The kind of a name
--
data NameKind
  -- |
  -- A value introduced as a binding in a module
  --
  = Value
  -- |
  -- A foreign import
  --
  | Extern ForeignImportType
  -- |
  -- A local name introduced using a lambda abstraction, variable introduction or binder
  --
  | LocalVariable
  -- |
  -- A data constructor
  --
  | DataConstructor
  -- |
  -- A type class dictionary, generated during desugaring of type class declarations
  --
  | TypeInstanceDictionaryValue
  -- |
  -- A type instance member, generated during desugaring of type class declarations
  --
  | TypeInstanceMember
  -- |
  -- A type class dictionary member accessor import, generated during desugaring of type class declarations
  --
  | TypeClassAccessorImport

instance showNameKind :: Show NameKind where
  show Value = "Value"
  show (Extern fit) = "Extern (" ++ show fit ++ ")"
  show LocalVariable = "LocalVariable"
  show DataConstructor = "DataConstructor"
  show TypeInstanceDictionaryValue = "TypeInstanceDictionaryValue"
  show TypeInstanceMember = "TypeInstanceMember"
  show TypeClassAccessorImport = "TypeClassAccessorImport"

instance eqNameKind :: Eq NameKind where
  (==) Value                       Value                       = true
  (==) (Extern t1)                 (Extern t2)                 = t1 == t2
  (==) LocalVariable               LocalVariable               = true
  (==) DataConstructor             DataConstructor             = true
  (==) TypeInstanceDictionaryValue TypeInstanceDictionaryValue = true
  (==) TypeInstanceMember          TypeInstanceMember          = true
  (==) TypeClassAccessorImport     TypeClassAccessorImport     = true
  (==) _ _ = false
  (/=) x y = not (x == y)

-- |
-- The kinds of a type
--
data TypeKind
  -- |
  -- Data type
  --
  = DataType [String] [Tuple ProperName [Type]]
  -- |
  -- Type synonym
  --
  | TypeSynonym
  -- |
  -- Foreign data
  --
  | ExternData
  -- |
  -- A local type variable
  --
  | LocalTypeVariable

instance showTypeKind :: Show TypeKind where
  show (DataType args dctors) = "DataType (" ++ show args ++ ") (" ++ show dctors ++ ")"
  show TypeSynonym = "TypeSynonym"
  show ExternData = "ExternData"
  show LocalTypeVariable = "LocalTypeVariable"

instance eqTypeKind :: Eq TypeKind where
  (==) (DataType args1 tys1) (DataType args2 tys2) = args1 == args2 && tys1 == tys2
  (==) TypeSynonym           TypeSynonym           = true
  (==) ExternData            ExternData            = true
  (==) LocalTypeVariable     LocalTypeVariable     = true
  (==) _ _ = false
  (/=) x y = not (x == y)

-- |
-- Construct a ProperName in the Prim module
--
primName :: String -> Qualified ProperName
primName = Qualified (Just $ ModuleName [ProperName C.prim]) <<< ProperName

-- |
-- Construct a type in the Prim module
--
primTy :: String -> Type
primTy = TypeConstructor <<< primName

-- |
-- Type constructor for functions
--
tyFunction :: Type
tyFunction = primTy "Function"

-- |
-- Type constructor for strings
--
tyString :: Type
tyString = primTy "String"

-- |
-- Type constructor for numbers
--
tyNumber :: Type
tyNumber = primTy "Number"

-- |
-- Type constructor for booleans
--
tyBoolean :: Type
tyBoolean = primTy "Boolean"

-- |
-- Type constructor for arrays
--
tyArray :: Type
tyArray = primTy "Array"

-- |
-- Type constructor for objects
--
tyObject :: Type
tyObject = primTy "Object"

-- |
-- Smart constructor for function types
--
function :: Type -> Type -> Type
function t1 = TypeApp (TypeApp tyFunction t1)

-- |
-- The primitive types in the external javascript environment with their associated kinds.
--
primTypes :: M.Map (Qualified ProperName) (Tuple Kind TypeKind)
primTypes = M.fromList [ Tuple (primName "Function") (Tuple (FunKind Star (FunKind Star Star)) ExternData)
                       , Tuple (primName "Array")    (Tuple (FunKind Star Star) ExternData)
                       , Tuple (primName "Object")   (Tuple (FunKind (Row Star) Star) ExternData)
                       , Tuple (primName "String")   (Tuple Star ExternData)
                       , Tuple (primName "Number")   (Tuple Star ExternData)
                       , Tuple (primName "Boolean")  (Tuple Star ExternData) ]


Remove reference to `fromChar` in documentation

- `fromChar` was removed in #59.

-- | Wraps the functions of Javascript's `String` object.
-- | A String represents a sequence of characters.
-- | For details of the underlying implementation, see [String Reference at MDN](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String).
module Data.String
  ( charAt
  , charCodeAt
  , fromCharArray
  , toChar
  , contains
  , indexOf
  , indexOf'
  , lastIndexOf
  , lastIndexOf'
  , null
  , uncons
  , length
  , singleton
  , localeCompare
  , replace
  , take
  , takeWhile
  , drop
  , dropWhile
  , stripPrefix
  , stripSuffix
  , split
  , toCharArray
  , toLower
  , toUpper
  , trim
  , joinWith
  ) where

import Prelude

import Data.Maybe (Maybe(..), isJust)
import Data.String.Unsafe as U

-- | Returns the character at the given index, if the index is within bounds.
charAt :: Int -> String -> Maybe Char
charAt = _charAt Just Nothing

foreign import _charAt :: (forall a. a -> Maybe a)
                       -> (forall a. Maybe a)
                       -> Int
                       -> String
                       -> Maybe Char

-- | Returns a string of length `1` containing the given character.
foreign import singleton :: Char -> String

-- | Returns the numeric Unicode value of the character at the given index,
-- | if the index is within bounds.
charCodeAt :: Int -> String -> Maybe Int
charCodeAt = _charCodeAt Just Nothing

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

toChar :: String -> Maybe Char
toChar = _toChar Just Nothing

foreign import _toChar :: (forall a. a -> Maybe a)
                       -> (forall a. Maybe a)
                       -> String
                       -> Maybe Char

-- | Returns `true` if the given string is empty.
null :: String -> Boolean
null s = length s == zero

-- | Returns the first character and the rest of the string,
-- | if the string is not empty.
uncons :: String -> Maybe { head :: Char, tail :: String }
uncons "" = Nothing
uncons s  = Just { head: U.charAt zero s, tail: drop one s }

-- | Returns the longest prefix (possibly empty) of characters that satisfy
-- | the predicate:
takeWhile :: (Char -> Boolean) -> String -> String
takeWhile p s = take (count p s) s

-- | Returns the suffix remaining after `takeWhile`.
dropWhile :: (Char -> Boolean) -> String -> String
dropWhile p s = drop (count p s) s

-- | If the string starts with the given prefix, return the portion of the
-- | string left after removing it, as a Just value. Otherwise, return Nothing.
-- | * `stripPrefix "http:" "http://purescript.org" == Just "//purescript.org"`
-- | * `stripPrefix "http:" "https://purescript.org" == Nothing`
stripPrefix :: String -> String -> Maybe String
stripPrefix prefix str =
  case indexOf prefix str of
    Just 0 -> Just $ drop (length prefix) str
    _      -> Nothing

-- | If the string ends with the given suffix, return the portion of the
-- | string left after removing it, as a Just value. Otherwise, return Nothing.
-- | * `stripSuffix ".exe" "psc.exe" == Just "psc"`
-- | * `stripSuffix ".exe" "psc" == Nothing`
stripSuffix :: String -> String -> Maybe String
stripSuffix suffix str =
  case lastIndexOf suffix str of
    Just x | x == length str - length suffix ->
      Just $ take x str
    _ ->
      Nothing

-- | Converts an array of characters into a string.
foreign import fromCharArray :: Array Char -> String

-- | Checks whether the first string exists in the second string.
contains :: String -> String -> Boolean
contains x s = isJust (indexOf x s)

-- | Returns the index of the first occurrence of the first string in the
-- | second string. Returns `Nothing` if there is no match.
indexOf :: String -> String -> Maybe Int
indexOf = _indexOf Just Nothing

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

-- | Returns the index of the first occurrence of the first string in the
-- | second string, starting at the given index. Returns `Nothing` if there is
-- | no match.
indexOf' :: String -> Int -> String -> Maybe Int
indexOf' = _indexOf' Just Nothing

foreign import _indexOf' :: (forall a. a -> Maybe a)
                         -> (forall a. Maybe a)
                         -> String
                         -> Int
                         -> String
                         -> Maybe Int

-- | Returns the index of the last occurrence of the first string in the
-- | second string. Returns `Nothing` if there is no match.
lastIndexOf :: String -> String -> Maybe Int
lastIndexOf = _lastIndexOf Just Nothing

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

-- | Returns the index of the last occurrence of the first string in the
-- | second string, starting at the given index. Returns `Nothing` if there is
-- | no match.
lastIndexOf' :: String -> Int -> String -> Maybe Int
lastIndexOf' = _lastIndexOf' Just Nothing

foreign import _lastIndexOf' :: (forall a. a -> Maybe a)
                             -> (forall a. Maybe a)
                             -> String
                             -> Int
                             -> String
                             -> Maybe Int

-- | Returns the number of characters the string is composed of.
foreign import length :: String -> Int

-- | Locale-aware sort order comparison.
localeCompare :: String -> String -> Ordering
localeCompare = _localeCompare LT EQ GT

foreign import _localeCompare :: Ordering
                              -> Ordering
                              -> Ordering
                              -> String
                              -> String
                              -> Ordering

-- | Replaces the first occurence of the first argument with the second argument.
foreign import replace :: String -> String -> String -> String

-- | Returns the first `n` characters of the string.
foreign import take :: Int -> String -> String

-- | Returns the string without the first `n` characters.
foreign import drop :: Int -> String -> String

-- | Returns the number of contiguous characters at the beginning
-- | of the string for which the predicate holds.
foreign import count :: (Char -> Boolean) -> String -> Int

-- | Returns the substrings of the second string separated along occurences
-- | of the first string.
-- | * `split " " "hello world" == ["hello", "world"]`
foreign import split :: String -> String -> Array String

-- | Converts the string into an array of characters.
foreign import toCharArray :: String -> Array Char

-- | Returns the argument converted to lowercase.
foreign import toLower :: String -> String

-- | Returns the argument converted to uppercase.
foreign import toUpper :: String -> String

-- | Removes whitespace from the beginning and end of a string, including
-- | [whitespace characters](http://www.ecma-international.org/ecma-262/5.1/#sec-7.2)
-- | and [line terminators](http://www.ecma-international.org/ecma-262/5.1/#sec-7.3).
foreign import trim :: String -> String

-- | Joins the strings in the array together, inserting the first argument
-- | as separator between them.
foreign import joinWith :: String -> Array String -> String

-- | Wraps the functions of Javascript's `String` object.
-- | A String represents a sequence of characters.
-- | For details of the underlying implementation, see [String Reference at MDN](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String).
module Data.String
  ( charAt
  , charCodeAt
  , fromCharArray
  , toChar
  , contains
  , indexOf
  , indexOf'
  , lastIndexOf
  , lastIndexOf'
  , null
  , uncons
  , length
  , singleton
  , localeCompare
  , replace
  , take
  , takeWhile
  , drop
  , dropWhile
  , stripPrefix
  , stripSuffix
  , split
  , toCharArray
  , toLower
  , toUpper
  , trim
  , joinWith
  ) where

import Prelude

import Data.Maybe (Maybe(..), isJust)
import Data.String.Unsafe as U

-- | Returns the character at the given index, if the index is within bounds.
charAt :: Int -> String -> Maybe Char
charAt = _charAt Just Nothing

foreign import _charAt :: (forall a. a -> Maybe a)
                       -> (forall a. Maybe a)
                       -> Int
                       -> String
                       -> Maybe Char

-- | Returns a string of length `1` containing the given character.
-- | Same as `fromChar`.
foreign import singleton :: Char -> String

-- | Returns the numeric Unicode value of the character at the given index,
-- | if the index is within bounds.
charCodeAt :: Int -> String -> Maybe Int
charCodeAt = _charCodeAt Just Nothing

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

toChar :: String -> Maybe Char
toChar = _toChar Just Nothing

foreign import _toChar :: (forall a. a -> Maybe a)
                       -> (forall a. Maybe a)
                       -> String
                       -> Maybe Char

-- | Returns `true` if the given string is empty.
null :: String -> Boolean
null s = length s == zero

-- | Returns the first character and the rest of the string,
-- | if the string is not empty.
uncons :: String -> Maybe { head :: Char, tail :: String }
uncons "" = Nothing
uncons s  = Just { head: U.charAt zero s, tail: drop one s }

-- | Returns the longest prefix (possibly empty) of characters that satisfy
-- | the predicate:
takeWhile :: (Char -> Boolean) -> String -> String
takeWhile p s = take (count p s) s

-- | Returns the suffix remaining after `takeWhile`.
dropWhile :: (Char -> Boolean) -> String -> String
dropWhile p s = drop (count p s) s

-- | If the string starts with the given prefix, return the portion of the
-- | string left after removing it, as a Just value. Otherwise, return Nothing.
-- | * `stripPrefix "http:" "http://purescript.org" == Just "//purescript.org"`
-- | * `stripPrefix "http:" "https://purescript.org" == Nothing`
stripPrefix :: String -> String -> Maybe String
stripPrefix prefix str =
  case indexOf prefix str of
    Just 0 -> Just $ drop (length prefix) str
    _      -> Nothing

-- | If the string ends with the given suffix, return the portion of the
-- | string left after removing it, as a Just value. Otherwise, return Nothing.
-- | * `stripSuffix ".exe" "psc.exe" == Just "psc"`
-- | * `stripSuffix ".exe" "psc" == Nothing`
stripSuffix :: String -> String -> Maybe String
stripSuffix suffix str =
  case lastIndexOf suffix str of
    Just x | x == length str - length suffix ->
      Just $ take x str
    _ ->
      Nothing

-- | Converts an array of characters into a string.
foreign import fromCharArray :: Array Char -> String

-- | Checks whether the first string exists in the second string.
contains :: String -> String -> Boolean
contains x s = isJust (indexOf x s)

-- | Returns the index of the first occurrence of the first string in the
-- | second string. Returns `Nothing` if there is no match.
indexOf :: String -> String -> Maybe Int
indexOf = _indexOf Just Nothing

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

-- | Returns the index of the first occurrence of the first string in the
-- | second string, starting at the given index. Returns `Nothing` if there is
-- | no match.
indexOf' :: String -> Int -> String -> Maybe Int
indexOf' = _indexOf' Just Nothing

foreign import _indexOf' :: (forall a. a -> Maybe a)
                         -> (forall a. Maybe a)
                         -> String
                         -> Int
                         -> String
                         -> Maybe Int

-- | Returns the index of the last occurrence of the first string in the
-- | second string. Returns `Nothing` if there is no match.
lastIndexOf :: String -> String -> Maybe Int
lastIndexOf = _lastIndexOf Just Nothing

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

-- | Returns the index of the last occurrence of the first string in the
-- | second string, starting at the given index. Returns `Nothing` if there is
-- | no match.
lastIndexOf' :: String -> Int -> String -> Maybe Int
lastIndexOf' = _lastIndexOf' Just Nothing

foreign import _lastIndexOf' :: (forall a. a -> Maybe a)
                             -> (forall a. Maybe a)
                             -> String
                             -> Int
                             -> String
                             -> Maybe Int

-- | Returns the number of characters the string is composed of.
foreign import length :: String -> Int

-- | Locale-aware sort order comparison.
localeCompare :: String -> String -> Ordering
localeCompare = _localeCompare LT EQ GT

foreign import _localeCompare :: Ordering
                              -> Ordering
                              -> Ordering
                              -> String
                              -> String
                              -> Ordering

-- | Replaces the first occurence of the first argument with the second argument.
foreign import replace :: String -> String -> String -> String

-- | Returns the first `n` characters of the string.
foreign import take :: Int -> String -> String

-- | Returns the string without the first `n` characters.
foreign import drop :: Int -> String -> String

-- | Returns the number of contiguous characters at the beginning
-- | of the string for which the predicate holds.
foreign import count :: (Char -> Boolean) -> String -> Int

-- | Returns the substrings of the second string separated along occurences
-- | of the first string.
-- | * `split " " "hello world" == ["hello", "world"]`
foreign import split :: String -> String -> Array String

-- | Converts the string into an array of characters.
foreign import toCharArray :: String -> Array Char

-- | Returns the argument converted to lowercase.
foreign import toLower :: String -> String

-- | Returns the argument converted to uppercase.
foreign import toUpper :: String -> String

-- | Removes whitespace from the beginning and end of a string, including
-- | [whitespace characters](http://www.ecma-international.org/ecma-262/5.1/#sec-7.2)
-- | and [line terminators](http://www.ecma-international.org/ecma-262/5.1/#sec-7.3).
foreign import trim :: String -> String

-- | Joins the strings in the array together, inserting the first argument
-- | as separator between them.
foreign import joinWith :: String -> Array String -> String


Use Proxy to help in type inference

Use Proxy to help in type inference

module React.Redox
  ( withStore
  , connect'
  , connect
  , dispatch
  , RedoxContext
  , DispatchFn
  , unsafeShallowEqual
  , unsafeStrictEqual
  ) where

import Prelude
import React as R
import Redox as Redox
import Control.Monad.Aff (Canceler)
import Control.Monad.Eff (Eff, kind Effect)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Control.Monad.Free (Free)
import Data.Function.Uncurried (Fn2, runFn2)
import Data.Lens (Getter', view)
import Data.Maybe (Maybe(..))
import React (ReactClass, ReactSpec, ReactThis, getProps, readState, writeState)
import ReactHocs (CONTEXT, withContext, accessContext, readContext, getDisplayName)
import Redox.Store (ReadRedox, RedoxStore, Store, SubscribeRedox, SubscriptionId)
import Type.Proxy (Proxy(..))

type DispatchFn state dsl reff eff = Free dsl (state -> state) -> Eff (redox :: RedoxStore reff | eff) (Canceler (redox :: RedoxStore reff | eff))

foreign import unsafeShallowEqual :: forall a. Fn2 a a Boolean

foreign import unsafeStrictEqual :: forall a. Fn2 a a Boolean

-- | You need to wrap your most top-level component with `withStore`.  It makes
-- | the store and the bound dispatch function avaialble through React context.
-- | Then you can connect a component with `connect` (or `connect'`) and get
-- | access to the store and the dispatch function.
withStore
  :: forall state props dsl reff eff
  -- redox store
   . Store state
  -- bound redox dispatch function
  -> (Store state -> DispatchFn state dsl reff eff)
  -> ReactClass props
  -> ReactClass props
withStore store dispatch_ cls =
  withContext cls { redox: { store, dispatch: dispatch_ store } }

type RedoxContext state dsl reff eff =
  { store :: Store state
  , dispatch :: DispatchFn state dsl reff eff
  }

type ConnectState state = { state :: state, sid :: Maybe SubscriptionId }

_connect
  :: forall state state' dsl props props' reff eff
   . (ReactThis props' (ConnectState state')
      -> Eff
        (context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff) | eff)
        (RedoxContext state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff)
     )
  -> Getter' state state'
  -> ((DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff) -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state')
      ( context :: CONTEXT
      , redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff)
      | eff
      )
_connect ctxEff _lns _iso cls = (R.spec' getInitialState renderFn)
    { displayName = getDisplayName cls <> "Connect"
    , componentWillMount = componentWillMount
    , componentWillUnmount = componentWillUnmount
    , shouldComponentUpdate = shouldComponentUpdate
    }
  where

    -- Connect the child component to the context, this is required for the
    -- `dispatch` function.
    cls_ :: ReactClass props
    cls_ = accessContext cls

    update this state = do
      st <- readState this
      void $ writeState this (st { state = view _lns state })

    getInitialState this = do
      -- unsafeCoerceEff is used to add react effects to ctxEff
      ctx <- unsafeCoerceEff $ ctxEff this
      state <- Redox.getState ctx.store
      pure { state: view _lns state, sid: Nothing }

    componentWillMount this = do
      ctx <- unsafeCoerceEff $ ctxEff this
      sid <- Redox.subscribe ctx.store $ update this
      st <- readState this
      void $ writeState this (st { sid = Just sid })

    componentWillUnmount this = do
      ctx <- unsafeCoerceEff $ ctxEff this
      { sid: msid } <- R.readState this
      case msid of
        Nothing -> pure unit
        Just sid -> Redox.unsubscribe ctx.store sid

    shouldComponentUpdate this nPr nSt = do
      pr <- getProps this
      st <- readState this
      -- Take care only of `st.state` changes, `st.sid` is not used for
      -- rendering.
      pure $ not
         $ (runFn2 unsafeStrictEqual st.state nSt.state)
        && (runFn2 unsafeShallowEqual pr nPr)

    renderFn this = do
      props' <- R.getProps this
      ctx <- unsafeCoerceEff $ ctxEff this
      { state } <- R.readState this
      pure $ R.createElement cls_ (_iso ctx.dispatch state props') []

-- | You must wrap the resulting component with `ReactHocs.accessContext` from
-- | `purescript-react-hocs`.  Checkout `connect` bellow.  This function makes
-- | the redox store and dispatch function available through the context.
-- | The first argument is a `Lens` that identifies the part of the store state
-- | that you want to subscribe for.
-- | The second argument let you combine state and additional properties
-- | `props'` to get props of the class that you are connecting to the store.
-- | You can read the context with:
-- | ```purescript
-- | ReactHocs.readContext this >>= pure <<< _.redox :: Eff eff (RedoxContext state (Free dsl (state -> state))  eff)
-- | ```
connect'
  :: forall state state' dsl props props' reff eff
   . Proxy state
  -> Getter' state state'
  -> (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state') ( context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff) | eff )
connect' _ _lns _iso cls = _connect ctxEff _lns _iso cls
  where
    ctxEff this = _.redox <$> ctx
      where
        ctx = readContext (Proxy :: Proxy ({ redox :: RedoxContext state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff })) this

connect
  :: forall state state' dsl props props' reff eff'
   . Proxy state
  -> Getter' state state'
  -> (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff' -> state' -> props' -> props)
  -> ReactClass props
  -> ReactClass props'
connect p _lns _iso cls = accessContext $ R.createClass $ connect' p _lns _iso cls

-- | Light wieght version of `connect`.  It does not require wrapping a parent
-- | with `withStore` since it is not using react context to access the store.
-- | You just need to provide the store with your first argument.
-- |
-- | Note: it is not safe to do server side rendering and keep the store as
-- | a global reference.  However, you can safely use this method if you are
-- | passing the store explicitely through props.
connectStore
  :: forall state state' dsl props props' reff eff
   . Store state
  -> DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff
  -> Getter' state state'
  -> (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state') ( context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff) | eff )
connectStore store dispatch_ _lns _iso cls = _connect (const $ pure {store, dispatch: dispatch_}) _lns _iso cls

dispatch
  :: forall dsl rProps rState state reff eff
   . ReactThis rProps rState
  -> Free dsl (state -> state)
  -> Eff (context :: CONTEXT, redox :: RedoxStore reff | eff) (Canceler (context :: CONTEXT, redox :: RedoxStore reff | eff))
dispatch this dsl = do
  { dispatch: disp } <- _.redox <$> readContext (Proxy :: Proxy ({ redox :: RedoxContext state dsl reff (context :: CONTEXT | eff) }) ) this
  disp dsl

module React.Redox
  ( withStore
  , connect'
  , connect
  , dispatch
  , RedoxContext
  , DispatchFn
  , unsafeShallowEqual
  , unsafeStrictEqual
  ) where

import Prelude
import React as R
import Redox as Redox
import Control.Monad.Aff (Canceler)
import Control.Monad.Eff (Eff, kind Effect)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Control.Monad.Free (Free)
import Data.Function.Uncurried (Fn2, runFn2)
import Data.Lens (Getter', view)
import Data.Maybe (Maybe(..))
import React (ReactClass, ReactSpec, ReactThis, getProps, readState, writeState)
import ReactHocs (CONTEXT, withContext, accessContext, readContext, getDisplayName)
import Redox.Store (ReadRedox, RedoxStore, Store, SubscribeRedox, SubscriptionId)
import Type.Proxy (Proxy(..))

type DispatchFn state dsl reff eff = Free dsl (state -> state) -> Eff (redox :: RedoxStore reff | eff) (Canceler (redox :: RedoxStore reff | eff))

foreign import unsafeShallowEqual :: forall a. Fn2 a a Boolean

foreign import unsafeStrictEqual :: forall a. Fn2 a a Boolean

-- | You need to wrap your most top-level component with `withStore`.  It makes
-- | the store and the bound dispatch function avaialble through React context.
-- | Then you can connect a component with `connect` (or `connect'`) and get
-- | access to the store and the dispatch function.
withStore
  :: forall state props dsl reff eff
  -- redox store
   . Store state
  -- bound redox dispatch function
  -> (Store state -> DispatchFn state dsl reff eff)
  -> ReactClass props
  -> ReactClass props
withStore store dispatch_ cls =
  withContext cls { redox: { store, dispatch: dispatch_ store } }

type RedoxContext state dsl reff eff =
  { store :: Store state
  , dispatch :: DispatchFn state dsl reff eff
  }

type ConnectState state = { state :: state, sid :: Maybe SubscriptionId }

_connect
  :: forall state state' dsl props props' reff eff
   . (ReactThis props' (ConnectState state')
      -> Eff
        (context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff) | eff)
        (RedoxContext state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff)
     )
  -> Getter' state state'
  -> ((DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff) -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state')
      ( context :: CONTEXT
      , redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff)
      | eff
      )
_connect ctxEff _lns _iso cls = (R.spec' getInitialState renderFn)
    { displayName = getDisplayName cls <> "Connect"
    , componentWillMount = componentWillMount
    , componentWillUnmount = componentWillUnmount
    , shouldComponentUpdate = shouldComponentUpdate
    }
  where

    -- Connect the child component to the context, this is required for the
    -- `dispatch` function.
    cls_ :: ReactClass props
    cls_ = accessContext cls

    update this state = do
      st <- readState this
      void $ writeState this (st { state = view _lns state })

    getInitialState this = do
      -- unsafeCoerceEff is used to add react effects to ctxEff
      ctx <- unsafeCoerceEff $ ctxEff this
      state <- Redox.getState ctx.store
      pure { state: view _lns state, sid: Nothing }

    componentWillMount this = do
      ctx <- unsafeCoerceEff $ ctxEff this
      sid <- Redox.subscribe ctx.store $ update this
      st <- readState this
      void $ writeState this (st { sid = Just sid })

    componentWillUnmount this = do
      ctx <- unsafeCoerceEff $ ctxEff this
      { sid: msid } <- R.readState this
      case msid of
        Nothing -> pure unit
        Just sid -> Redox.unsubscribe ctx.store sid

    shouldComponentUpdate this nPr nSt = do
      pr <- getProps this
      st <- readState this
      -- Take care only of `st.state` changes, `st.sid` is not used for
      -- rendering.
      pure $ not
         $ (runFn2 unsafeStrictEqual st.state nSt.state)
        && (runFn2 unsafeShallowEqual pr nPr)

    renderFn this = do
      props' <- R.getProps this
      ctx <- unsafeCoerceEff $ ctxEff this
      { state } <- R.readState this
      pure $ R.createElement cls_ (_iso ctx.dispatch state props') []

-- | You must wrap the resulting component with `ReactHocs.accessContext` from
-- | `purescript-react-hocs`.  Checkout `connect` bellow.  This function makes
-- | the redox store and dispatch function available through the context.
-- | The first argument is a `Lens` that identifies the part of the store state
-- | that you want to subscribe for.
-- | The second argument let you combine state and additional properties
-- | `props'` to get props of the class that you are connecting to the store.
-- | You can read the context with:
-- | ```purescript
-- | ReactHocs.readContext this >>= pure <<< _.redox :: Eff eff (RedoxContext state (Free dsl (state -> state))  eff)
-- | ```
connect'
  :: forall state state' dsl props props' reff eff
   . Getter' state state'
   -> (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state') ( context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff) | eff )
connect' _lns _iso cls = _connect ctxEff _lns _iso cls
  where
    ctxEff this = _.redox <$> ctx
      where
        ctx = readContext (Proxy :: Proxy ({ redox :: RedoxContext state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff })) this

connect
  :: forall state state' dsl props props' reff eff'
   . Getter' state state'
  -> (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff' -> state' -> props' -> props)
  -> ReactClass props
  -> ReactClass props'
connect _lns _iso cls = accessContext $ R.createClass $ connect' _lns _iso cls

-- | Light wieght version of `connect`.  It does not require wrapping a parent
-- | with `withStore` since it is not using react context to access the store.
-- | You just need to provide the store with your first argument.
-- |
-- | Note: it is not safe to do server side rendering and keep the store as
-- | a global reference.  However, you can safely use this method if you are
-- | passing the store explicitely through props.
connectStore
  :: forall state state' dsl props props' reff eff
   . Store state
  -> DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff
  -> Getter' state state'
  -> (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff -> state' -> props' -> props)
  -> ReactClass props
  -> ReactSpec props' (ConnectState state') ( context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff) | eff )
connectStore store dispatch_ _lns _iso cls = _connect (const $ pure {store, dispatch: dispatch_}) _lns _iso cls

dispatch
  :: forall dsl rProps rState state reff eff
   . ReactThis rProps rState
  -> Free dsl (state -> state)
  -> Eff (context :: CONTEXT, redox :: RedoxStore reff | eff) (Canceler (context :: CONTEXT, redox :: RedoxStore reff | eff))
dispatch this dsl = do
  { dispatch: disp } <- _.redox <$> readContext (Proxy :: Proxy ({ redox :: RedoxContext state dsl reff (context :: CONTEXT | eff) }) ) this
  disp dsl


Signal.Time.now should return a function (an Eff)

module Signal.Time (
  Time(..),
  millisecond,
  second,
  every,
  now
  ) where

import Control.Monad.Eff
import Signal
import DOM

type Time = Number

millisecond :: Time
millisecond = 1

second :: Time
second = 1000

_constant = constant

foreign import every
  "function every(t) {\
  \  var out = _constant(now());\
  \  setInterval(function() {\
  \    out.set(now());\
  \  }, t);\
  \  return out;\
  \}" :: Time -> Signal Time

-- |Returns the number of milliseconds since an arbitrary, but constant, time in the past.
foreign import now
  "function now() {\
  \  var perf; try { perf = performance; } catch(e) { perf = null; }\
  \  return ((perf && (perf.now ||\
  \                    perf.webkitNow ||\
  \                    perf.msNow ||\
  \                    perf.oNow ||\
  \                    perf.mozNow)) ||\
  \          (process && process.hrtime && function() {\
  \            var t = process.hrtime();\
  \            return (t[0] * 1e9 + t[1]) / 1e6;\
  \          }) ||\
  \          function() { return Date.now(); });\
  \}" :: forall e. Eff (dom :: DOM | e) Time

module Signal.Time (
  Time(..),
  millisecond,
  second,
  every,
  now
  ) where

import Control.Monad.Eff
import Signal
import DOM

type Time = Number

millisecond :: Time
millisecond = 1

second :: Time
second = 1000

_constant = constant

foreign import every
  "function every(t) {\
  \  var out = _constant(now());\
  \  setInterval(function() {\
  \    out.set(now());\
  \  }, t);\
  \  return out;\
  \}" :: Time -> Signal Time

-- |Returns the number of milliseconds since an arbitrary, but constant, time in the past.
foreign import now
  "function now() {\
  \  var perf; try { perf = performance; } catch(e) { perf = null; }\
  \  return ((perf && (perf.now ||\
  \                    perf.webkitNow ||\
  \                    perf.msNow ||\
  \                    perf.oNow ||\
  \                    perf.mozNow)) ||\
  \          (process && process.hrtime && function() {\
  \            var t = process.hrtime();\
  \            return (t[0] * 1e9 + t[1]) / 1e6;\
  \          }) ||\
  \          function() { return Date.now(); })();\
  \}" :: forall e. Eff (dom :: DOM | e) Time


Use traverse instead of sequence

Use traverse instead of sequence

module Simple.JSON (
  readJSON
, readJSON'
, writeJSON
, write
, read

, class ReadForeign
, readImpl
, class ReadForeignFields
, getFields

, class WriteForeign
, writeImpl

, class WriteForeignFields
, writeImplFields

) where

import Prelude

import Control.Monad.Except (runExcept, withExcept)
import Data.Either (Either)
import Data.Foreign (F, Foreign, ForeignError(..), MultipleErrors, readArray, readBoolean, readChar, readInt, readNull, readNumber, readString, toForeign)
import Data.Foreign.Index (readProp)
import Data.Foreign.Internal (readStrMap)
import Data.Foreign.JSON (parseJSON)
import Data.Foreign.NullOrUndefined (NullOrUndefined(NullOrUndefined), readNullOrUndefined, unNullOrUndefined, undefined)
import Data.Maybe (Maybe(..), maybe)
import Data.Nullable (Nullable, toMaybe, toNullable)
import Data.Record (get)
import Data.Record.Builder (Builder)
import Data.Record.Builder as Builder
import Data.StrMap as StrMap
import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
import Data.Traversable (sequence, traverse)
import Global.Unsafe (unsafeStringify)
import Type.Row (class RowLacks, class RowToList, Cons, Nil, RLProxy(RLProxy), kind RowList)

-- | Read a JSON string to a type `a` while returning a `MultipleErrors` if the
-- | parsing failed.
readJSON :: forall a
  .  ReadForeign a
  => String
  -> Either MultipleErrors a
readJSON = runExcept <<< (readImpl <=< parseJSON)

-- | Read a JSON string to a type `a` using `F a`. Useful with record types.
readJSON' :: forall a
  .  ReadForeign a
  => String
  -> F a
readJSON' = readImpl <=< parseJSON

-- | Write a JSON string from a type `a`.
writeJSON :: forall a
  .  WriteForeign a
  => a
  -> String
writeJSON = unsafeStringify <<< writeImpl

write :: forall a
  .  WriteForeign a
  => a
  -> Foreign
write = writeImpl

read :: forall a
  .  ReadForeign a
  => Foreign
  -> F a
read = readImpl

-- | A class for reading foreign values to a type
class ReadForeign a where
  readImpl :: Foreign -> F a

instance readForeign :: ReadForeign Foreign where
  readImpl = pure

instance readChar :: ReadForeign Char where
  readImpl = readChar

instance readNumber :: ReadForeign Number where
  readImpl = readNumber

instance readInt :: ReadForeign Int where
  readImpl = readInt

instance readString :: ReadForeign String where
  readImpl = readString

instance readBoolean :: ReadForeign Boolean where
  readImpl = readBoolean

instance readArray :: ReadForeign a => ReadForeign (Array a) where
  readImpl = traverse readImpl <=< readArray

instance readNullOrUndefined :: ReadForeign a => ReadForeign (NullOrUndefined a) where
  readImpl = readNullOrUndefined readImpl

instance readMaybe :: ReadForeign a => ReadForeign (Maybe a) where
  readImpl = map unNullOrUndefined <<< readImpl

instance readNullable :: ReadForeign a => ReadForeign (Nullable a) where
  readImpl o = withExcept (map reformat) $
    map toNullable <$> traverse readImpl =<< readNull o
    where
      reformat error = case error of
        TypeMismatch inner other -> TypeMismatch ("Nullable " <> inner) other
        _ -> error

instance readStrMap :: ReadForeign a => ReadForeign (StrMap.StrMap a) where
  readImpl = sequence <<< StrMap.mapWithKey (const readImpl) <=< readStrMap

instance readRecord ::
  ( RowToList fields fieldList
  , ReadForeignFields fieldList () fields
  ) => ReadForeign (Record fields) where
  readImpl o = do
    steps <- getFields fieldListP o
    pure $ Builder.build steps {}
    where
      fieldListP = RLProxy :: RLProxy fieldList

-- | A class for reading foreign values from properties
class ReadForeignFields (xs :: RowList) (from :: # Type) (to :: # Type)
  | xs -> from to where
  getFields :: RLProxy xs
    -> Foreign
    -> F (Builder (Record from) (Record to))

instance readFieldsCons ::
  ( IsSymbol name
  , ReadForeign ty
  , ReadForeignFields tail from from'
  , RowLacks name from'
  , RowCons name ty from' to
  ) => ReadForeignFields (Cons name ty tail) from to where
  getFields _ obj = do
    value :: ty <- withExcept' $ readImpl =<< readProp name obj
    rest <- getFields tailP obj
    let
      first :: Builder (Record from') (Record to)
      first = Builder.insert nameP value
    pure $ first <<< rest
    where
      nameP = SProxy :: SProxy name
      tailP = RLProxy :: RLProxy tail
      name = reflectSymbol nameP
      withExcept' = withExcept <<< map $ ErrorAtProperty name

instance readFieldsNil ::
  ReadForeignFields Nil () () where
  getFields _ _ =
    pure id

-- | A class for writing a value into JSON
-- | need to do this intelligently using Foreign probably, because of null and undefined whatever
class WriteForeign a where
  writeImpl :: a -> Foreign

instance writeForeignForeign :: WriteForeign Foreign where
  writeImpl = id

instance writeForeignString :: WriteForeign String where
  writeImpl = toForeign

instance writeForeignInt :: WriteForeign Int where
  writeImpl = toForeign

instance writeForeignChar :: WriteForeign Char where
  writeImpl = toForeign

instance writeForeignNumber :: WriteForeign Number where
  writeImpl = toForeign

instance writeForeignBoolean :: WriteForeign Boolean where
  writeImpl = toForeign

instance writeForeignArray :: WriteForeign a => WriteForeign (Array a) where
  writeImpl xs = toForeign $ writeImpl <$> xs

instance writeForeignNullOrUndefined :: WriteForeign a => WriteForeign (NullOrUndefined a) where
  writeImpl (NullOrUndefined a) = maybe undefined writeImpl a

instance writeForeignMaybe :: WriteForeign a => WriteForeign (Maybe a) where
  writeImpl (Just a) = writeImpl a
  writeImpl Nothing = toForeign $ toNullable Nothing

instance writeForeignNullable :: WriteForeign a => WriteForeign (Nullable a) where
  writeImpl = writeImpl <<< toMaybe

instance writeForeignStrMap :: WriteForeign a => WriteForeign (StrMap.StrMap a) where
  writeImpl = toForeign <<< StrMap.mapWithKey (const writeImpl)

instance recordWriteForeign ::
  ( RowToList row rl
  , WriteForeignFields rl row () to
  ) => WriteForeign (Record row) where
  writeImpl rec = toForeign $ Builder.build steps {}
    where
      rlp = RLProxy :: RLProxy rl
      steps = writeImplFields rlp rec

class WriteForeignFields (rl :: RowList) row (from :: # Type) (to :: # Type)
  | rl -> row from to where
  writeImplFields :: forall g. g rl -> Record row -> Builder (Record from) (Record to)

instance consWriteForeignFields ::
  ( IsSymbol name
  , WriteForeign ty
  , WriteForeignFields tail row from from'
  , RowCons name ty whatever row
  , RowLacks name from'
  , RowCons name Foreign from' to
  ) => WriteForeignFields (Cons name ty tail) row from to where
  writeImplFields _ rec = result
    where
      namep = SProxy :: SProxy name
      value = writeImpl $ get namep rec
      tailp = RLProxy :: RLProxy tail
      rest = writeImplFields tailp rec
      result = Builder.insert namep value <<< rest
instance nilWriteForeignFields ::
  WriteForeignFields Nil row () () where
  writeImplFields _ _ = id

module Simple.JSON (
  readJSON
, readJSON'
, writeJSON
, write
, read

, class ReadForeign
, readImpl
, class ReadForeignFields
, getFields

, class WriteForeign
, writeImpl

, class WriteForeignFields
, writeImplFields

) where

import Prelude

import Control.Monad.Except (runExcept, withExcept)
import Data.Either (Either)
import Data.Foreign (F, Foreign, ForeignError(..), MultipleErrors, readArray, readBoolean, readChar, readInt, readNull, readNumber, readString, toForeign)
import Data.Foreign.Index (readProp)
import Data.Foreign.Internal (readStrMap)
import Data.Foreign.JSON (parseJSON)
import Data.Foreign.NullOrUndefined (NullOrUndefined(NullOrUndefined), readNullOrUndefined, unNullOrUndefined, undefined)
import Data.Maybe (Maybe(..), maybe)
import Data.Nullable (Nullable, toMaybe, toNullable)
import Data.Record (get)
import Data.Record.Builder (Builder)
import Data.Record.Builder as Builder
import Data.StrMap as StrMap
import Data.Symbol (class IsSymbol, SProxy(..), reflectSymbol)
import Data.Traversable (sequence, traverse)
import Global.Unsafe (unsafeStringify)
import Type.Row (class RowLacks, class RowToList, Cons, Nil, RLProxy(RLProxy), kind RowList)

-- | Read a JSON string to a type `a` while returning a `MultipleErrors` if the
-- | parsing failed.
readJSON :: forall a
  .  ReadForeign a
  => String
  -> Either MultipleErrors a
readJSON = runExcept <<< (readImpl <=< parseJSON)

-- | Read a JSON string to a type `a` using `F a`. Useful with record types.
readJSON' :: forall a
  .  ReadForeign a
  => String
  -> F a
readJSON' = readImpl <=< parseJSON

-- | Write a JSON string from a type `a`.
writeJSON :: forall a
  .  WriteForeign a
  => a
  -> String
writeJSON = unsafeStringify <<< writeImpl

write :: forall a
  .  WriteForeign a
  => a
  -> Foreign
write = writeImpl

read :: forall a
  .  ReadForeign a
  => Foreign
  -> F a
read = readImpl

-- | A class for reading foreign values to a type
class ReadForeign a where
  readImpl :: Foreign -> F a

instance readForeign :: ReadForeign Foreign where
  readImpl = pure

instance readChar :: ReadForeign Char where
  readImpl = readChar

instance readNumber :: ReadForeign Number where
  readImpl = readNumber

instance readInt :: ReadForeign Int where
  readImpl = readInt

instance readString :: ReadForeign String where
  readImpl = readString

instance readBoolean :: ReadForeign Boolean where
  readImpl = readBoolean

instance readArray :: ReadForeign a => ReadForeign (Array a) where
  readImpl = readElements <=< readArray
    where
      readElements xs = sequence $ readImpl <$> xs

instance readNullOrUndefined :: ReadForeign a => ReadForeign (NullOrUndefined a) where
  readImpl = readNullOrUndefined readImpl

instance readMaybe :: ReadForeign a => ReadForeign (Maybe a) where
  readImpl = map unNullOrUndefined <<< readImpl

instance readNullable :: ReadForeign a => ReadForeign (Nullable a) where
  readImpl o = withExcept (map reformat) $
    map toNullable <$> traverse readImpl =<< readNull o
    where
      reformat error = case error of
        TypeMismatch inner other -> TypeMismatch ("Nullable " <> inner) other
        _ -> error

instance readStrMap :: ReadForeign a => ReadForeign (StrMap.StrMap a) where
  readImpl = sequence <<< StrMap.mapWithKey (const readImpl) <=< readStrMap

instance readRecord ::
  ( RowToList fields fieldList
  , ReadForeignFields fieldList () fields
  ) => ReadForeign (Record fields) where
  readImpl o = do
    steps <- getFields fieldListP o
    pure $ Builder.build steps {}
    where
      fieldListP = RLProxy :: RLProxy fieldList

-- | A class for reading foreign values from properties
class ReadForeignFields (xs :: RowList) (from :: # Type) (to :: # Type)
  | xs -> from to where
  getFields :: RLProxy xs
    -> Foreign
    -> F (Builder (Record from) (Record to))

instance readFieldsCons ::
  ( IsSymbol name
  , ReadForeign ty
  , ReadForeignFields tail from from'
  , RowLacks name from'
  , RowCons name ty from' to
  ) => ReadForeignFields (Cons name ty tail) from to where
  getFields _ obj = do
    value :: ty <- withExcept' $ readImpl =<< readProp name obj
    rest <- getFields tailP obj
    let
      first :: Builder (Record from') (Record to)
      first = Builder.insert nameP value
    pure $ first <<< rest
    where
      nameP = SProxy :: SProxy name
      tailP = RLProxy :: RLProxy tail
      name = reflectSymbol nameP
      withExcept' = withExcept <<< map $ ErrorAtProperty name

instance readFieldsNil ::
  ReadForeignFields Nil () () where
  getFields _ _ =
    pure id

-- | A class for writing a value into JSON
-- | need to do this intelligently using Foreign probably, because of null and undefined whatever
class WriteForeign a where
  writeImpl :: a -> Foreign

instance writeForeignForeign :: WriteForeign Foreign where
  writeImpl = id

instance writeForeignString :: WriteForeign String where
  writeImpl = toForeign

instance writeForeignInt :: WriteForeign Int where
  writeImpl = toForeign

instance writeForeignChar :: WriteForeign Char where
  writeImpl = toForeign

instance writeForeignNumber :: WriteForeign Number where
  writeImpl = toForeign

instance writeForeignBoolean :: WriteForeign Boolean where
  writeImpl = toForeign

instance writeForeignArray :: WriteForeign a => WriteForeign (Array a) where
  writeImpl xs = toForeign $ writeImpl <$> xs

instance writeForeignNullOrUndefined :: WriteForeign a => WriteForeign (NullOrUndefined a) where
  writeImpl (NullOrUndefined a) = maybe undefined writeImpl a

instance writeForeignMaybe :: WriteForeign a => WriteForeign (Maybe a) where
  writeImpl (Just a) = writeImpl a
  writeImpl Nothing = toForeign $ toNullable Nothing

instance writeForeignNullable :: WriteForeign a => WriteForeign (Nullable a) where
  writeImpl = writeImpl <<< toMaybe

instance writeForeignStrMap :: WriteForeign a => WriteForeign (StrMap.StrMap a) where
  writeImpl = toForeign <<< StrMap.mapWithKey (const writeImpl)

instance recordWriteForeign ::
  ( RowToList row rl
  , WriteForeignFields rl row () to
  ) => WriteForeign (Record row) where
  writeImpl rec = toForeign $ Builder.build steps {}
    where
      rlp = RLProxy :: RLProxy rl
      steps = writeImplFields rlp rec

class WriteForeignFields (rl :: RowList) row (from :: # Type) (to :: # Type)
  | rl -> row from to where
  writeImplFields :: forall g. g rl -> Record row -> Builder (Record from) (Record to)

instance consWriteForeignFields ::
  ( IsSymbol name
  , WriteForeign ty
  , WriteForeignFields tail row from from'
  , RowCons name ty whatever row
  , RowLacks name from'
  , RowCons name Foreign from' to
  ) => WriteForeignFields (Cons name ty tail) row from to where
  writeImplFields _ rec = result
    where
      namep = SProxy :: SProxy name
      value = writeImpl $ get namep rec
      tailp = RLProxy :: RLProxy tail
      rest = writeImplFields tailp rec
      result = Builder.insert namep value <<< rest
instance nilWriteForeignFields ::
  WriteForeignFields Nil row () () where
  writeImplFields _ _ = id