Sort record fields before compare

Sort record fields before compare

module Data.Generic
  ( Generic
  , toSpine
  , toSignature
  , fromSpine
  , GenericSpine(..)
  , GenericSignature(..)
  , showSignature
  , DataConstructor()
  , showDataConstructor
  , isValidSpine
  , gShow
  , gEq
  , gCompare
  ) where

import Prelude

import Data.Either (Either(..))
import Data.Maybe (Maybe(..))
import Data.Tuple (Tuple(..))
import Data.Traversable (traverse)
import Data.Foldable (all, and, find, fold, intercalate)
import Data.Array (null, length, sortBy, zipWith)
import Data.String (joinWith)
import Type.Proxy (Proxy(..))

-- | A GenericSpine is a universal representation of an arbitrary data structure (that does not contain function arrows).
data GenericSpine = SProd String (Array (Unit -> GenericSpine))
                  | SRecord (Array { recLabel :: String, recValue :: Unit -> GenericSpine })
                  | SNumber Number
                  | SBoolean Boolean
                  | SInt Int
                  | SString String
                  | SChar Char
                  | SArray (Array (Unit -> GenericSpine))

-- | Identifies a data constructor.
type DataConstructor =
  { sigConstructor :: String
  , sigValues :: Array (Unit -> GenericSignature)
  }

-- | A GenericSignature is a universal representation of the structure of an arbitrary data structure (that does not contain function arrows).
data GenericSignature = SigProd String (Array DataConstructor)
                      | SigRecord (Array { recLabel :: String, recValue :: Unit -> GenericSignature })
                      | SigNumber
                      | SigBoolean
                      | SigInt
                      | SigString
                      | SigChar
                      | SigArray (Unit -> GenericSignature)

showSignature :: GenericSignature -> String
showSignature sig =
  fold $ case sig of
    SigProd tyName ctors ->
      ["SigProd ", show tyName, " ", showArray showDataConstructor ctors]
    SigRecord labels ->
      ["SigRecord ", showArray showLabel labels]
    SigNumber ->
      ["SigNumber"]
    SigBoolean ->
      ["SigBoolean"]
    SigInt ->
      ["SigInt"]
    SigString ->
      ["SigString"]
    SigChar ->
      ["SigChar"]
    SigArray sig' ->
      ["SigArray ", paren (force sig')]

  where
  paren s
    | needsParen s = "(" <> showSignature s <> ")"
    | otherwise = showSignature s

  needsParen s = case s of
    SigProd _ _ -> true
    SigRecord _ -> true
    SigNumber   -> false
    SigBoolean  -> false
    SigInt      -> false
    SigString   -> false
    SigChar     -> false
    SigArray _  -> true

instance showGenericSignature :: Show GenericSignature where
  show = showSignature

-- We use this instead of the default Show Array instance to avoid escaping
-- strings twice.
showArray :: forall a. (a -> String) -> Array a -> String
showArray f xs = "[ " <> intercalate ", " (map f xs) <> " ]"

showLabel ::
  { recLabel :: String, recValue :: Unit -> GenericSignature } -> String
showLabel l =
  "{ recLabel: " <> show l.recLabel <>
  ", recValue: " <> showSignature (force l.recValue) <>
  " }"

showDataConstructor :: DataConstructor -> String
showDataConstructor dc =
  "{ sigConstructor: " <> show dc.sigConstructor <>
  ", sigValues: " <> showArray (showSignature <<< force) dc.sigValues <>
  "}"

force :: forall a. (Unit -> a) -> a
force = ($ unit)

anyProxy :: forall a. Proxy a
anyProxy = Proxy

-- | The Generic typeclass provides methods for sending data to/from spine representations, as well as querying about the signatures of spine representations.
-- | For standard data structures, you can simply write `derive instance genericFoo :: Generic Foo` in the module they are declared, and the instance methods will be filled in for you.
class Generic a where
    toSpine :: a -> GenericSpine
    toSignature :: Proxy a -> GenericSignature
    fromSpine :: GenericSpine -> Maybe a

-- | Checks that the spine follows the structure defined by the signature
isValidSpine :: GenericSignature -> GenericSpine -> Boolean
isValidSpine SigBoolean (SBoolean _) = true
isValidSpine SigNumber (SNumber _) = true
isValidSpine SigInt (SInt _) = true
isValidSpine SigString (SString _) = true
isValidSpine SigChar (SChar _) = true
isValidSpine (SigArray sig) (SArray spines) = all (isValidSpine (sig unit) <<< (unit #)) spines
isValidSpine (SigProd _ alts) (SProd tag values) =
  case find ((tag ==) <<< _.sigConstructor) alts of
    Nothing -> false
    Just { sigValues: sigValues } ->
      and $ zipWith (\sig spine -> isValidSpine (sig unit) (spine unit)) sigValues values
isValidSpine (SigRecord fieldSigs) (SRecord fieldVals) =
  and $ zipWith (\sig val -> isValidSpine (sig.recValue unit) (val.recValue unit))
                (sortBy (\a b -> compare a.recLabel b.recLabel) fieldSigs)
                (sortBy (\a b -> compare a.recLabel b.recLabel) fieldVals)
isValidSpine _ _ = false

instance genericNumber :: Generic Number where
    toSpine x = SNumber x
    toSignature _ = SigNumber
    fromSpine (SNumber n) = Just n
    fromSpine _ = Nothing

instance genericInt :: Generic Int where
    toSpine x = SInt x
    toSignature _ = SigInt
    fromSpine (SInt n) = Just n
    fromSpine _ = Nothing

instance genericString :: Generic String where
    toSpine x = SString x
    toSignature _ = SigString
    fromSpine (SString s) = Just s
    fromSpine _ = Nothing

instance genericChar :: Generic Char where
    toSpine x = SChar x
    toSignature _ = SigChar
    fromSpine (SChar s) = Just s
    fromSpine _ = Nothing

instance genericBool :: Generic Boolean where
    toSpine b = SBoolean b
    toSignature _ = SigBoolean
    fromSpine (SBoolean b)  = Just b
    fromSpine _ = Nothing

instance genericArray :: (Generic a) => Generic (Array a) where
    toSpine xs = SArray ((\x y -> toSpine x) <$> xs)
    toSignature x = SigArray (\unit -> toSignature (lowerProxy x))
        where lowerProxy :: Proxy (Array a) -> Proxy a
              lowerProxy Proxy = (anyProxy :: Proxy a)

    fromSpine (SArray x) = traverse (fromSpine <<< ($ unit)) x
    fromSpine _ = Nothing

instance genericTuple :: (Generic a, Generic b) => Generic (Tuple a b) where
      toSpine (Tuple x y) = SProd "Data.Tuple.Tuple" [\u -> toSpine x, \u -> toSpine y]

      toSignature x = SigProd "Data.Tuple.Tuple"
                              [ { sigConstructor: "Data.Tuple.Tuple"
                                , sigValues: [\u -> toSignature (fstProxy x), \u -> toSignature (sndProxy x)]
                                }
                              ]
                    where fstProxy :: Proxy (Tuple a b) -> Proxy a
                          fstProxy Proxy = (anyProxy :: Proxy a)
                          sndProxy :: Proxy (Tuple a b) -> Proxy b
                          sndProxy Proxy = (anyProxy :: Proxy b)

      fromSpine (SProd "Data.Tuple.Tuple" [x,y]) = Tuple <$> fromSpine (x unit) <*> fromSpine (y unit)
      fromSpine _ = Nothing

instance genericMaybe :: (Generic a) => Generic (Maybe a) where
      toSpine (Just x) = SProd "Data.Maybe.Just" [\u -> toSpine x]
      toSpine Nothing = SProd "Data.Maybe.Nothing" []
      toSignature x = SigProd "Data.Maybe.Maybe"
                              [ { sigConstructor: "Data.Maybe.Just"
                                , sigValues: [\u -> toSignature (mbProxy x)]
                                }
                              , { sigConstructor: "Data.Maybe.Nothing"
                                , sigValues: []
                                }
                              ]
          where mbProxy :: Proxy (Maybe a) -> Proxy a
                mbProxy Proxy = (anyProxy :: Proxy a)
      fromSpine (SProd "Data.Maybe.Just" [x]) = Just <$> fromSpine (x unit)
      fromSpine (SProd "Data.Maybe.Nothing" []) = return Nothing
      fromSpine _ = Nothing

instance genericEither :: (Generic a, Generic b) => Generic (Either a b) where
    toSpine (Left x) = SProd "Data.Either.Left" [\u -> toSpine x]
    toSpine (Right x) = SProd "Data.Either.Right" [\u -> toSpine x]
    toSignature x = SigProd "Data.Either.Either"
                            [ { sigConstructor: "Data.Either.Left"
                              , sigValues: [\u -> toSignature (lproxy x)]
                              }
                            , { sigConstructor: "Data.Either.Right"
                              , sigValues: [\u -> toSignature (rproxy x)]
                              }
                            ]
          where lproxy :: Proxy (Either a b) -> Proxy a
                lproxy Proxy = (anyProxy :: Proxy a)
                rproxy :: Proxy (Either a b) -> Proxy b
                rproxy Proxy = (anyProxy :: Proxy b)
    fromSpine (SProd "Data.Either.Left"  [x]) = Left  <$> fromSpine (x unit)
    fromSpine (SProd "Data.Either.Right" [x]) = Right <$> fromSpine (x unit)
    fromSpine _ = Nothing

--- Generic Functions
genericShowPrec :: Int -> GenericSpine -> String
genericShowPrec d (SProd s arr) =
    if null arr
    then s
    else showParen (d > 10) $ s <> " " <> joinWith " " (map (\x -> genericShowPrec 11 (x unit)) arr)
  where showParen false x = x
        showParen true  x = "(" <> x <> ")"

genericShowPrec d (SRecord xs) = "{" <> joinWith ", " (map (\x -> x.recLabel <> ": " <> genericShowPrec 0 (x.recValue unit)) xs) <> "}"
genericShowPrec d (SBoolean x) = show x
genericShowPrec d (SInt x)     = show x
genericShowPrec d (SNumber x)  = show x
genericShowPrec d (SString x)  = show x
genericShowPrec d (SChar x)    = show x
genericShowPrec d (SArray xs)  = "[" <> joinWith ", "  (map (\x -> genericShowPrec 0 (x unit)) xs) <> "]"

-- | This function can be used as the default instance for Show for any instance of Generic
gShow :: forall a. (Generic a) => a -> String
gShow = genericShowPrec 0 <<< toSpine

foreign import zipAll :: forall a b. (a -> b -> Boolean) -> Array a -> Array b -> Boolean

instance eqGeneric :: Eq GenericSpine where
    eq (SProd s1 arr1) (SProd s2 arr2) = s1 == s2
                                      && length arr1 == length arr2
                                      && zipAll (\x y -> x unit == y unit) arr1 arr2
    eq (SRecord arr1) (SRecord arr2) = eqRecordSigs arr1 arr2
    eq (SNumber x)  (SNumber y)  = x == y
    eq (SBoolean x) (SBoolean y) = x == y
    eq (SInt x)     (SInt y)     = x == y
    eq (SString x)  (SString y)  = x == y
    eq (SChar x)    (SChar y)    = x == y
    eq (SArray xs)  (SArray ys)  = length xs == length ys && zipAll (\x y -> x unit == y unit) xs ys
    eq _ _ = false

instance eqGenericSignature :: Eq GenericSignature where
  eq (SigProd s1 arr1) (SigProd s2 arr2) = s1 == s2
                                        && length arr1 == length arr2
                                        && zipAll eqDataConstructor arr1 arr2
  eq (SigRecord arr1) (SigRecord arr2)   = eqRecordSigs arr1 arr2
  eq SigNumber   SigNumber               = true
  eq SigBoolean  SigBoolean              = true
  eq SigInt      SigInt                  = true
  eq SigString   SigString               = true
  eq SigChar     SigChar                 = true
  eq (SigArray t1) (SigArray t2)         = t1 unit == t2 unit
  eq _ _                                 = false

eqDataConstructor :: DataConstructor -> DataConstructor -> Boolean
eqDataConstructor p1 p2 = p1.sigConstructor == p2.sigConstructor
                       && zipAll (\x y -> x unit == y unit) p1.sigValues p2.sigValues

eqRecordSigs :: forall a. Eq a => Array {recLabel :: String, recValue :: Unit -> a}
                               -> Array {recLabel :: String, recValue :: Unit -> a}
                               -> Boolean
eqRecordSigs arr1 arr2 = length arr1 == length arr2
                      && zipAll doCmp sorted1 sorted2
  where
    labelCompare r1 r2 = compare r1.recLabel r2.recLabel
    sorted1 = sortBy labelCompare arr1
    sorted2 = sortBy labelCompare arr2
    doCmp x y = x.recLabel == y.recLabel && x.recValue unit == y.recValue unit

-- | This function can be used as the default instance for Eq for any instance of Generic
gEq :: forall a. (Generic a) => a -> a -> Boolean
gEq x y = toSpine x == toSpine y

foreign import zipCompare :: forall a b. (a -> b -> Int) -> Array a -> Array b -> Int

instance ordGeneric :: Ord GenericSpine where
    compare (SProd s1 arr1) (SProd s2 arr2) =
        case compare s1 s2 of
          EQ -> compare 0 $ zipCompare (\x y -> case compare (x unit) (y unit) of
                                                  EQ -> 0
                                                  LT -> 1
                                                  GT -> -1) arr1 arr2
          c1 -> c1
    compare (SProd _ _) _ = LT
    compare _ (SProd _ _) = GT
    compare (SRecord xs) (SRecord ys) = compare 0 $ zipCompare go xs ys
        where go x y = case compare x.recLabel y.recLabel of
                         EQ -> case compare (x.recValue unit) (y.recValue unit) of
                                 EQ -> 0
                                 LT -> 1
                                 GT -> -1
                         LT -> 1
                         GT -> -1
    compare (SRecord _) _ = LT
    compare _ (SRecord _) = GT
    compare (SInt x) (SInt y) = compare x y
    compare (SInt _) _ = LT
    compare _ (SInt _) = GT
    compare (SBoolean x) (SBoolean y) = compare x y
    compare (SBoolean _) _ = LT
    compare _ (SBoolean _) = GT
    compare (SNumber x) (SNumber y) = compare x y
    compare (SNumber _) _ = LT
    compare _ (SNumber _) = GT
    compare (SString x) (SString y) = compare x y
    compare (SString _) _ = LT
    compare _ (SString _) = GT
    compare (SChar x) (SChar y) = compare x y
    compare (SChar _) _ = LT
    compare _ (SChar _) = GT
    compare (SArray xs) (SArray ys) = compare 0 $ zipCompare (\x y -> case compare (x unit) (y unit) of
                                                                        EQ -> 0
                                                                        LT -> 1
                                                                        GT -> -1) xs ys

-- | This function can be used as the default instance for the compare method of Ord for any instance of Generic
gCompare :: forall a. (Generic a) => a -> a -> Ordering
gCompare x y = compare (toSpine x) (toSpine y)

module Data.Generic
  ( Generic
  , toSpine
  , toSignature
  , fromSpine
  , GenericSpine(..)
  , GenericSignature(..)
  , showSignature
  , DataConstructor()
  , showDataConstructor
  , isValidSpine
  , gShow
  , gEq
  , gCompare
  ) where

import Prelude

import Data.Either (Either(..))
import Data.Maybe (Maybe(..))
import Data.Tuple (Tuple(..))
import Data.Traversable (traverse)
import Data.Foldable (all, and, find, fold, intercalate)
import Data.Array (null, length, sortBy, zipWith)
import Data.String (joinWith)
import Type.Proxy (Proxy(..))

-- | A GenericSpine is a universal representation of an arbitrary data structure (that does not contain function arrows).
data GenericSpine = SProd String (Array (Unit -> GenericSpine))
                  | SRecord (Array { recLabel :: String, recValue :: Unit -> GenericSpine })
                  | SNumber Number
                  | SBoolean Boolean
                  | SInt Int
                  | SString String
                  | SChar Char
                  | SArray (Array (Unit -> GenericSpine))

-- | Identifies a data constructor.
type DataConstructor =
  { sigConstructor :: String
  , sigValues :: Array (Unit -> GenericSignature)
  }

-- | A GenericSignature is a universal representation of the structure of an arbitrary data structure (that does not contain function arrows).
data GenericSignature = SigProd String (Array DataConstructor)
                      | SigRecord (Array { recLabel :: String, recValue :: Unit -> GenericSignature })
                      | SigNumber
                      | SigBoolean
                      | SigInt
                      | SigString
                      | SigChar
                      | SigArray (Unit -> GenericSignature)

showSignature :: GenericSignature -> String
showSignature sig =
  fold $ case sig of
    SigProd tyName ctors ->
      ["SigProd ", show tyName, " ", showArray showDataConstructor ctors]
    SigRecord labels ->
      ["SigRecord ", showArray showLabel labels]
    SigNumber ->
      ["SigNumber"]
    SigBoolean ->
      ["SigBoolean"]
    SigInt ->
      ["SigInt"]
    SigString ->
      ["SigString"]
    SigChar ->
      ["SigChar"]
    SigArray sig' ->
      ["SigArray ", paren (force sig')]

  where
  paren s
    | needsParen s = "(" <> showSignature s <> ")"
    | otherwise = showSignature s

  needsParen s = case s of
    SigProd _ _ -> true
    SigRecord _ -> true
    SigNumber   -> false
    SigBoolean  -> false
    SigInt      -> false
    SigString   -> false
    SigChar     -> false
    SigArray _  -> true

instance showGenericSignature :: Show GenericSignature where
  show = showSignature

-- We use this instead of the default Show Array instance to avoid escaping
-- strings twice.
showArray :: forall a. (a -> String) -> Array a -> String
showArray f xs = "[ " <> intercalate ", " (map f xs) <> " ]"

showLabel ::
  { recLabel :: String, recValue :: Unit -> GenericSignature } -> String
showLabel l =
  "{ recLabel: " <> show l.recLabel <>
  ", recValue: " <> showSignature (force l.recValue) <>
  " }"

showDataConstructor :: DataConstructor -> String
showDataConstructor dc =
  "{ sigConstructor: " <> show dc.sigConstructor <>
  ", sigValues: " <> showArray (showSignature <<< force) dc.sigValues <>
  "}"

force :: forall a. (Unit -> a) -> a
force = ($ unit)

anyProxy :: forall a. Proxy a
anyProxy = Proxy

-- | The Generic typeclass provides methods for sending data to/from spine representations, as well as querying about the signatures of spine representations.
-- | For standard data structures, you can simply write `derive instance genericFoo :: Generic Foo` in the module they are declared, and the instance methods will be filled in for you.
class Generic a where
    toSpine :: a -> GenericSpine
    toSignature :: Proxy a -> GenericSignature
    fromSpine :: GenericSpine -> Maybe a

-- | Checks that the spine follows the structure defined by the signature
isValidSpine :: GenericSignature -> GenericSpine -> Boolean
isValidSpine SigBoolean (SBoolean _) = true
isValidSpine SigNumber (SNumber _) = true
isValidSpine SigInt (SInt _) = true
isValidSpine SigString (SString _) = true
isValidSpine SigChar (SChar _) = true
isValidSpine (SigArray sig) (SArray spines) = all (isValidSpine (sig unit) <<< (unit #)) spines
isValidSpine (SigProd _ alts) (SProd tag values) =
  case find ((tag ==) <<< _.sigConstructor) alts of
    Nothing -> false
    Just { sigValues: sigValues } ->
      and $ zipWith (\sig spine -> isValidSpine (sig unit) (spine unit)) sigValues values
isValidSpine (SigRecord fieldSigs) (SRecord fieldVals) =
  and $ zipWith (\sig val -> isValidSpine (sig.recValue unit) (val.recValue unit))
                (sortBy (\a b -> compare a.recLabel b.recLabel) fieldSigs)
                (sortBy (\a b -> compare a.recLabel b.recLabel) fieldVals)
isValidSpine _ _ = false

instance genericNumber :: Generic Number where
    toSpine x = SNumber x
    toSignature _ = SigNumber
    fromSpine (SNumber n) = Just n
    fromSpine _ = Nothing

instance genericInt :: Generic Int where
    toSpine x = SInt x
    toSignature _ = SigInt
    fromSpine (SInt n) = Just n
    fromSpine _ = Nothing

instance genericString :: Generic String where
    toSpine x = SString x
    toSignature _ = SigString
    fromSpine (SString s) = Just s
    fromSpine _ = Nothing

instance genericChar :: Generic Char where
    toSpine x = SChar x
    toSignature _ = SigChar
    fromSpine (SChar s) = Just s
    fromSpine _ = Nothing

instance genericBool :: Generic Boolean where
    toSpine b = SBoolean b
    toSignature _ = SigBoolean
    fromSpine (SBoolean b)  = Just b
    fromSpine _ = Nothing

instance genericArray :: (Generic a) => Generic (Array a) where
    toSpine xs = SArray ((\x y -> toSpine x) <$> xs)
    toSignature x = SigArray (\unit -> toSignature (lowerProxy x))
        where lowerProxy :: Proxy (Array a) -> Proxy a
              lowerProxy Proxy = (anyProxy :: Proxy a)

    fromSpine (SArray x) = traverse (fromSpine <<< ($ unit)) x
    fromSpine _ = Nothing

instance genericTuple :: (Generic a, Generic b) => Generic (Tuple a b) where
      toSpine (Tuple x y) = SProd "Data.Tuple.Tuple" [\u -> toSpine x, \u -> toSpine y]

      toSignature x = SigProd "Data.Tuple.Tuple"
                              [ { sigConstructor: "Data.Tuple.Tuple"
                                , sigValues: [\u -> toSignature (fstProxy x), \u -> toSignature (sndProxy x)]
                                }
                              ]
                    where fstProxy :: Proxy (Tuple a b) -> Proxy a
                          fstProxy Proxy = (anyProxy :: Proxy a)
                          sndProxy :: Proxy (Tuple a b) -> Proxy b
                          sndProxy Proxy = (anyProxy :: Proxy b)

      fromSpine (SProd "Data.Tuple.Tuple" [x,y]) = Tuple <$> fromSpine (x unit) <*> fromSpine (y unit)
      fromSpine _ = Nothing

instance genericMaybe :: (Generic a) => Generic (Maybe a) where
      toSpine (Just x) = SProd "Data.Maybe.Just" [\u -> toSpine x]
      toSpine Nothing = SProd "Data.Maybe.Nothing" []
      toSignature x = SigProd "Data.Maybe.Maybe"
                              [ { sigConstructor: "Data.Maybe.Just"
                                , sigValues: [\u -> toSignature (mbProxy x)]
                                }
                              , { sigConstructor: "Data.Maybe.Nothing"
                                , sigValues: []
                                }
                              ]
          where mbProxy :: Proxy (Maybe a) -> Proxy a
                mbProxy Proxy = (anyProxy :: Proxy a)
      fromSpine (SProd "Data.Maybe.Just" [x]) = Just <$> fromSpine (x unit)
      fromSpine (SProd "Data.Maybe.Nothing" []) = return Nothing
      fromSpine _ = Nothing

instance genericEither :: (Generic a, Generic b) => Generic (Either a b) where
    toSpine (Left x) = SProd "Data.Either.Left" [\u -> toSpine x]
    toSpine (Right x) = SProd "Data.Either.Right" [\u -> toSpine x]
    toSignature x = SigProd "Data.Either.Either"
                            [ { sigConstructor: "Data.Either.Left"
                              , sigValues: [\u -> toSignature (lproxy x)]
                              }
                            , { sigConstructor: "Data.Either.Right"
                              , sigValues: [\u -> toSignature (rproxy x)]
                              }
                            ]
          where lproxy :: Proxy (Either a b) -> Proxy a
                lproxy Proxy = (anyProxy :: Proxy a)
                rproxy :: Proxy (Either a b) -> Proxy b
                rproxy Proxy = (anyProxy :: Proxy b)
    fromSpine (SProd "Data.Either.Left"  [x]) = Left  <$> fromSpine (x unit)
    fromSpine (SProd "Data.Either.Right" [x]) = Right <$> fromSpine (x unit)
    fromSpine _ = Nothing

--- Generic Functions
genericShowPrec :: Int -> GenericSpine -> String
genericShowPrec d (SProd s arr) =
    if null arr
    then s
    else showParen (d > 10) $ s <> " " <> joinWith " " (map (\x -> genericShowPrec 11 (x unit)) arr)
  where showParen false x = x
        showParen true  x = "(" <> x <> ")"

genericShowPrec d (SRecord xs) = "{" <> joinWith ", " (map (\x -> x.recLabel <> ": " <> genericShowPrec 0 (x.recValue unit)) xs) <> "}"
genericShowPrec d (SBoolean x) = show x
genericShowPrec d (SInt x)     = show x
genericShowPrec d (SNumber x)  = show x
genericShowPrec d (SString x)  = show x
genericShowPrec d (SChar x)    = show x
genericShowPrec d (SArray xs)  = "[" <> joinWith ", "  (map (\x -> genericShowPrec 0 (x unit)) xs) <> "]"

-- | This function can be used as the default instance for Show for any instance of Generic
gShow :: forall a. (Generic a) => a -> String
gShow = genericShowPrec 0 <<< toSpine

foreign import zipAll :: forall a b. (a -> b -> Boolean) -> Array a -> Array b -> Boolean

instance eqGeneric :: Eq GenericSpine where
    eq (SProd s1 arr1) (SProd s2 arr2) = s1 == s2
                                      && length arr1 == length arr2
                                      && zipAll (\x y -> x unit == y unit) arr1 arr2
    eq (SRecord xs) (SRecord ys) = length xs == length ys && zipAll go xs ys
             where go x y = x.recLabel == y.recLabel && x.recValue unit == y.recValue unit
    eq (SNumber x)  (SNumber y)  = x == y
    eq (SBoolean x) (SBoolean y) = x == y
    eq (SInt x)     (SInt y)     = x == y
    eq (SString x)  (SString y)  = x == y
    eq (SChar x)    (SChar y)    = x == y
    eq (SArray xs)  (SArray ys)  = length xs == length ys && zipAll (\x y -> x unit == y unit) xs ys
    eq _ _ = false

eqDataConstructor :: DataConstructor -> DataConstructor -> Boolean
eqDataConstructor p1 p2 = p1.sigConstructor == p2.sigConstructor
                       && zipAll (\x y -> x unit == y unit) p1.sigValues p2.sigValues

instance eqGenericSignature :: Eq GenericSignature where
  eq (SigProd s1 arr1) (SigProd s2 arr2) = s1 == s2
                                        && length arr1 == length arr2
                                        && zipAll eqDataConstructor arr1 arr2
  eq (SigRecord arr1) (SigRecord arr2)   = length arr1 == length arr2
                                        && zipAll (\x y -> x.recLabel == y.recLabel) arr1 arr2
                                        && zipAll (\x y -> x.recValue unit == y.recValue unit) arr1 arr2
  eq SigNumber   SigNumber               = true
  eq SigBoolean  SigBoolean              = true
  eq SigInt      SigInt                  = true
  eq SigString   SigString               = true
  eq SigChar     SigChar                 = true
  eq (SigArray t1) (SigArray t2)         = t1 unit == t2 unit
  eq _ _                                 = false

-- | This function can be used as the default instance for Eq for any instance of Generic
gEq :: forall a. (Generic a) => a -> a -> Boolean
gEq x y = toSpine x == toSpine y

foreign import zipCompare :: forall a b. (a -> b -> Int) -> Array a -> Array b -> Int

instance ordGeneric :: Ord GenericSpine where
    compare (SProd s1 arr1) (SProd s2 arr2) =
        case compare s1 s2 of
          EQ -> compare 0 $ zipCompare (\x y -> case compare (x unit) (y unit) of
                                                  EQ -> 0
                                                  LT -> 1
                                                  GT -> -1) arr1 arr2
          c1 -> c1
    compare (SProd _ _) _ = LT
    compare _ (SProd _ _) = GT
    compare (SRecord xs) (SRecord ys) = compare 0 $ zipCompare go xs ys
        where go x y = case compare x.recLabel y.recLabel of
                         EQ -> case compare (x.recValue unit) (y.recValue unit) of
                                 EQ -> 0
                                 LT -> 1
                                 GT -> -1
                         LT -> 1
                         GT -> -1
    compare (SRecord _) _ = LT
    compare _ (SRecord _) = GT
    compare (SInt x) (SInt y) = compare x y
    compare (SInt _) _ = LT
    compare _ (SInt _) = GT
    compare (SBoolean x) (SBoolean y) = compare x y
    compare (SBoolean _) _ = LT
    compare _ (SBoolean _) = GT
    compare (SNumber x) (SNumber y) = compare x y
    compare (SNumber _) _ = LT
    compare _ (SNumber _) = GT
    compare (SString x) (SString y) = compare x y
    compare (SString _) _ = LT
    compare _ (SString _) = GT
    compare (SChar x) (SChar y) = compare x y
    compare (SChar _) _ = LT
    compare _ (SChar _) = GT
    compare (SArray xs) (SArray ys) = compare 0 $ zipCompare (\x y -> case compare (x unit) (y unit) of
                                                                        EQ -> 0
                                                                        LT -> 1
                                                                        GT -> -1) xs ys

-- | This function can be used as the default instance for the compare method of Ord for any instance of Generic
gCompare :: forall a. (Generic a) => a -> a -> Ordering
gCompare x y = compare (toSpine x) (toSpine y)


Fix shadowed import warnings

Fix shadowed import warnings

-- | This module re-exports the types for the `HTML` DSL, and values for all
-- | supported HTML elements.
module Halogen.HTML
  ( PlainHTML
  , fromPlainHTML
  , slot
  , slot'
  , module Halogen.HTML.Core
  , module Halogen.HTML.Elements
  , module Halogen.HTML.Properties
  ) where

import Prelude (Unit, Void, (<<<))

import Data.Functor as F
import Data.Maybe (Maybe(..))
import Halogen.Component (Component, ParentHTML, mkComponentSlot, unComponent)
import Halogen.Component.ChildPath (ChildPath, injSlot, prjQuery, injQuery)
import Halogen.HTML.Core (class IsProp, AttrName(..), ClassName(..), HTML(..), Namespace(..), PropName(..), ElemName(..), text, handler)
import Halogen.HTML.Core as Core
import Halogen.HTML.Elements
import Halogen.HTML.Properties (IProp, attr, attrNS, prop)
import Unsafe.Coerce (unsafeCoerce)

-- | A type useful for a chunk of HTML with no slot-embedding or query-raising.
-- |
-- | Often a polymorphic usage of `HTML` is good enough for this, but sometimes
-- | it's useful to have a type like this (and accompanying coercion) when doing
-- | things like creating components that accept a chunk of HTML as part of
-- | their configuration.
type PlainHTML = HTML Void Void

-- | Relaxes the type of `PlainHTML` to make it compatible with all `HTML`.
fromPlainHTML :: forall p i. PlainHTML -> HTML p i
fromPlainHTML = unsafeCoerce -- ≅ bimap absurd absurd

-- | Defines a slot for a child component. Takes:
-- | - the slot "address" value
-- | - the component for the slot
-- | - the input value to pass to the component
-- | - a function mapping outputs from the component to a query in the parent
slot
  :: forall f m p i o g
   . p
  -> Component HTML g i o m
  -> i
  -> (o -> Maybe (f Unit))
  -> ParentHTML f g p m
slot p component input outputQuery =
  let f = unComponent _.receiver component
  in Core.slot (mkComponentSlot p component input f outputQuery Just)

-- | Defines a slot for a child component when a parent has multiple types of
-- | child component. Takes:
-- | - the `ChildPath` for this particular child component type
-- | - the slot "address" value
-- | - the component for the slot
-- | - the input value to pass to the component
-- | - a function mapping outputs from the component to a query in the parent
slot'
  :: forall f g g' p p' i o m
   . ChildPath g g' p p'
  -> p
  -> Component HTML g i o m
  -> i
  -> (o -> Maybe (f Unit))
  -> ParentHTML f g' p' m
slot' i p component input outputQuery =
  let
    pq = prjQuery i
    f = F.map (injQuery i) <<< unComponent _.receiver component
  in
    Core.slot (mkComponentSlot (injSlot i p) component input f outputQuery pq)

-- | This module re-exports the types for the `HTML` DSL, and values for all
-- | supported HTML elements.
module Halogen.HTML
  ( PlainHTML
  , fromPlainHTML
  , slot
  , slot'
  , module Halogen.HTML.Core
  , module Halogen.HTML.Elements
  , module Halogen.HTML.Properties
  ) where

import Prelude

import Data.Functor as F
import Data.Maybe (Maybe(..))
import Halogen.Component (Component, ParentHTML, mkComponentSlot, unComponent)
import Halogen.Component.ChildPath (ChildPath, injSlot, prjQuery, injQuery)
import Halogen.HTML.Core (class IsProp, AttrName(..), ClassName(..), HTML(..), Namespace(..), PropName(..), ElemName(..), text, handler)
import Halogen.HTML.Core as Core
import Halogen.HTML.Elements (Leaf, Node, withKeys, withKeys_, a, a_, abbr, abbr_, address, address_, area, article, article_, aside, aside_, audio, audio_, b, b_, base, bdi, bdi_, bdo, bdo_, blockquote, blockquote_, body, body_, br, br_, button, button_, canvas, caption, caption_, cite, cite_, code, code_, col, colgroup, colgroup_, command, datalist, datalist_, dd, dd_, del, del_, details, details_, dfn, dfn_, dialog, dialog_, div, div_, dl, dl_, dt, dt_, element, elementNS, em, em_, embed, embed_, fieldset, fieldset_, figcaption, figcaption_, figure, figure_, footer, footer_, form, form_, h1, h1_, h2, h2_, h3, h3_, h4, h4_, h5, h5_, h6, h6_, head, head_, header, header_, hr, hr_, html, html_, i, i_, iframe, img, input, ins, ins_, kbd, kbd_, label, label_, legend, legend_, li, li_, link, main, main_, map, map_, mark, mark_, menu, menu_, menuitem, menuitem_, meta, meter, meter_, nav, nav_, noscript, noscript_, object, object_, ol, ol_, optgroup, optgroup_, option, option_, output, output_, p, p_, param, pre, pre_, progress, progress_, q, q_, rp, rp_, rt, rt_, ruby, ruby_, samp, samp_, script, script_, section, section_, select, select_, small, small_, source, span, span_, strong, strong_, style, style_, sub, sub_, summary, summary_, sup, sup_, table, table_, tbody, tbody_, td, td_, textarea, tfoot, tfoot_, th, th_, thead, thead_, time, time_, title, title_, tr, tr_, track, u, u_, ul, ul_, var, var_, video, video_, wbr)
import Halogen.HTML.Properties (IProp, attr, attrNS, prop)
import Unsafe.Coerce (unsafeCoerce)

-- | A type useful for a chunk of HTML with no slot-embedding or query-raising.
-- |
-- | Often a polymorphic usage of `HTML` is good enough for this, but sometimes
-- | it's useful to have a type like this (and accompanying coercion) when doing
-- | things like creating components that accept a chunk of HTML as part of
-- | their configuration.
type PlainHTML = HTML Void Void

-- | Relaxes the type of `PlainHTML` to make it compatible with all `HTML`.
fromPlainHTML :: forall p i. PlainHTML -> HTML p i
fromPlainHTML = unsafeCoerce -- ≅ bimap absurd absurd

-- | Defines a slot for a child component. Takes:
-- | - the slot "address" value
-- | - the component for the slot
-- | - the input value to pass to the component
-- | - a function mapping outputs from the component to a query in the parent
slot
  :: forall f m p i o g
   . p
  -> Component HTML g i o m
  -> i
  -> (o -> Maybe (f Unit))
  -> ParentHTML f g p m
slot p component input outputQuery =
  let f = unComponent _.receiver component
  in Core.slot (mkComponentSlot p component input f outputQuery Just)

-- | Defines a slot for a child component when a parent has multiple types of
-- | child component. Takes:
-- | - the `ChildPath` for this particular child component type
-- | - the slot "address" value
-- | - the component for the slot
-- | - the input value to pass to the component
-- | - a function mapping outputs from the component to a query in the parent
slot'
  :: forall f g g' p p' i o m
   . ChildPath g g' p p'
  -> p
  -> Component HTML g i o m
  -> i
  -> (o -> Maybe (f Unit))
  -> ParentHTML f g' p' m
slot' i p component input outputQuery =
  let
    pq = prjQuery i
    f = F.map (injQuery i) <<< unComponent _.receiver component
  in
    Core.slot (mkComponentSlot (injSlot i p) component input f outputQuery pq)


Use `<$>` for `Positional`

Use `<$>` for `Positional`

module Docopt.Parsers.Meta where

import Prelude
import Data.Monoid (mempty)
import Control.Apply ((*>), (<*))
import Data.Traversable (for, traverse)
import Debug.Trace (traceShow)
import Control.Monad
import Control.Alt ((<|>))
import Control.Monad.Eff.Console (log)
import Text.Parsing.Parser (Parser(), ParserT(..), PState(..))
import Text.Parsing.Parser.Pos (Position(..))
import Data.List (List(), (:))
import Text.Parsing.Parser.String (char, string, satisfy, eof, skipSpaces, whiteSpace)
import Text.Parsing.Parser.Combinators (try, sepBy)
import Data.Char (toString, toUpper)
import Data.String (charAt, fromChar, fromCharArray)
import Data.Maybe
import Data.Either
import qualified Data.List as List
import qualified Data.Array as Array
import Data.List (List(..), concat, toList, many)
import Docopt.Parsers.Base

-- | Represent a meta token, derived from a usage line
data Meta
  = Command String
  | Positional String
  | LongOpt String (Maybe String)
  | ShortOpt Char (Array Char) (Maybe String)

-- | Represent a single usage
type Usage = List Meta
type UsageBlock = List Usage

instance showMeta :: Show Meta where
  show (Command name) =
    "Command " ++ name
  show (Positional name) =
    "Positional " ++ name
  show (LongOpt name arg) =
    "LongOpt " ++ name ++ " " ++ show arg
  show (ShortOpt x xs arg) =
    "ShortOpt " ++ (show $ fromChar x ++ fromCharArray xs) ++ " " ++ show arg

-- | Parse an ARGNAME
_ARGNAME :: Parser String String
_ARGNAME = do
  x <- matches "[A-Z]"
  xs <- Array.many $ matches "[A-Z]"
  return $ fromCharArray $ Array.cons x xs

-- | Parse an <argname>
_argname_ :: Parser String String
_argname_ = do
  char '<'
  xs <- Array.some $ matches "[a-z]"
  char '>'
  return $ fromCharArray xs

-- | Parse a positional argument
positional :: Parser String Meta
positional = do
  Positional <$> (_ARGNAME <|> _argname_)

-- | Parse a long option
-- |
-- | --foo
-- | --foo <argument>|ARGUMENT
-- |
longOption :: Parser String Meta
longOption = do
  string "--"
  LongOpt
    <$> (fromCharArray <$> (Array.some $ matches "[a-z]"))
    <*> ((do many $ char ' '
             Just <$> (_ARGNAME <|> _argname_)) <|> return Nothing)

-- | Parse a short option
-- |
-- | -v
-- | -vv
-- | -xvzf
-- | -v <argument>|ARGUMENT
-- | -vv <argument>|ARGUMENT
-- | -xvzf <argument>|ARGUMENT
-- |
shortOption :: Parser String Meta
shortOption = do
  char '-'
  ShortOpt
    <$> (matches "[a-z]")
    <*> (Array.many $ matches "[a-z]")
    <*> ((do many $ char ' '
             Just <$> (_ARGNAME <|> _argname_)) <|> return Nothing)

-- | Parse any type of option
option :: Parser String Meta
option = longOption <|> shortOption

-- | Parse any valid usage token
usageToken :: Parser String Meta
usageToken = option <|> positional

-- | Parse a `Usage line` into tokens.
usage :: String -> Parser String Usage
usage program = do

  -- Program name
  string program <* space
  Position { column: col } <- getPosition

  -- First line of usage tokens
  x <- usageToken `sepBy` many space

  -- And the rest of 'em
  xs <- (many $ try do
          many space *> eol
          indent (col - 1)
          many space
          usageToken `sepBy` many space)

  return $ concat (x:xs)

-- | Parse a complete usage block
-- |
-- | Usage:
-- |    naval-fate -vvv
-- |               -v
-- |    naval-fate --debug
usageBlock :: String -> Parser String UsageBlock
usageBlock program = do
  -- Title
  string "Usage:" <* chompRight

  -- First usage line, indicates indentation
  many space
  Position { column: col } <- getPosition
  x <- usage program

  -- Subsequent usage lines
  xs <- many $ try $ do
    eol
    indent (col - 1)
    usage program <* many space <* eol

  return (x:xs)

meta :: String -> Parser String Unit
meta program = do
  skipSpaces
  x <- usageBlock program
  debug x
  return unit

module Docopt.Parsers.Meta where

import Prelude
import Data.Monoid (mempty)
import Control.Apply ((*>), (<*))
import Data.Traversable (for, traverse)
import Debug.Trace (traceShow)
import Control.Monad
import Control.Alt ((<|>))
import Control.Monad.Eff.Console (log)
import Text.Parsing.Parser (Parser(), ParserT(..), PState(..))
import Text.Parsing.Parser.Pos (Position(..))
import Data.List (List(), (:))
import Text.Parsing.Parser.String (char, string, satisfy, eof, skipSpaces, whiteSpace)
import Text.Parsing.Parser.Combinators (try, sepBy)
import Data.Char (toString, toUpper)
import Data.String (charAt, fromChar, fromCharArray)
import Data.Maybe
import Data.Either
import qualified Data.List as List
import qualified Data.Array as Array
import Data.List (List(..), concat, toList, many)
import Docopt.Parsers.Base

-- | Represent a meta token, derived from a usage line
data Meta
  = Command String
  | Positional String
  | LongOpt String (Maybe String)
  | ShortOpt Char (Array Char) (Maybe String)

-- | Represent a single usage
type Usage = List Meta
type UsageBlock = List Usage

instance showMeta :: Show Meta where
  show (Command name) =
    "Command " ++ name
  show (Positional name) =
    "Positional " ++ name
  show (LongOpt name arg) =
    "LongOpt " ++ name ++ " " ++ show arg
  show (ShortOpt x xs arg) =
    "ShortOpt " ++ (show $ fromChar x ++ fromCharArray xs) ++ " " ++ show arg

-- | Parse an ARGNAME
_ARGNAME :: Parser String String
_ARGNAME = do
  x <- matches "[A-Z]"
  xs <- Array.many $ matches "[A-Z]"
  return $ fromCharArray $ Array.cons x xs

-- | Parse an <argname>
_argname_ :: Parser String String
_argname_ = do
  char '<'
  xs <- Array.some $ matches "[a-z]"
  char '>'
  return $ fromCharArray xs

-- | Parse a positional argument
positional :: Parser String Meta
positional = do
  x <- _ARGNAME <|> _argname_
  return $ Positional x

-- | Parse a long option
-- |
-- | --foo
-- | --foo <argument>|ARGUMENT
-- |
longOption :: Parser String Meta
longOption = do
  string "--"
  LongOpt
    <$> (fromCharArray <$> (Array.some $ matches "[a-z]"))
    <*> ((do many $ char ' '
             Just <$> (_ARGNAME <|> _argname_)) <|> return Nothing)

-- | Parse a short option
-- |
-- | -v
-- | -vv
-- | -xvzf
-- | -v <argument>|ARGUMENT
-- | -vv <argument>|ARGUMENT
-- | -xvzf <argument>|ARGUMENT
-- |
shortOption :: Parser String Meta
shortOption = do
  char '-'
  ShortOpt
    <$> (matches "[a-z]")
    <*> (Array.many $ matches "[a-z]")
    <*> ((do many $ char ' '
             Just <$> (_ARGNAME <|> _argname_)) <|> return Nothing)

-- | Parse any type of option
option :: Parser String Meta
option = longOption <|> shortOption

-- | Parse any valid usage token
usageToken :: Parser String Meta
usageToken = option <|> positional

-- | Parse a `Usage line` into tokens.
usage :: String -> Parser String Usage
usage program = do

  -- Program name
  string program <* space
  Position { column: col } <- getPosition

  -- First line of usage tokens
  x <- usageToken `sepBy` many space

  -- And the rest of 'em
  xs <- (many $ try do
          many space *> eol
          indent (col - 1)
          many space
          usageToken `sepBy` many space)

  return $ concat (x:xs)

-- | Parse a complete usage block
-- |
-- | Usage:
-- |    naval-fate -vvv
-- |               -v
-- |    naval-fate --debug
usageBlock :: String -> Parser String UsageBlock
usageBlock program = do
  -- Title
  string "Usage:" <* chompRight

  -- First usage line, indicates indentation
  many space
  Position { column: col } <- getPosition
  x <- usage program

  -- Subsequent usage lines
  xs <- many $ try $ do
    eol
    indent (col - 1)
    usage program <* many space <* eol

  return (x:xs)

meta :: String -> Parser String Unit
meta program = do
  skipSpaces
  x <- usageBlock program
  debug x
  return unit


Swap out liftM

Swap out liftM

module Control.Monad.Maybe.Trans where

import Prelude
import Data.Maybe
import Control.Monad
import Control.Monad.Trans

data MaybeT m a = MaybeT (m (Maybe a))

instance (Prelude.Monad m) => Prelude.Monad (MaybeT m) where
  --return = lift <<< return -- TODO: doesn't type check?
  return x = MaybeT $ return $ Just x
  (>>=) x f = MaybeT $ do
    v <- runMaybeT x
    case v of
      Nothing -> return Nothing
      Just y  -> runMaybeT (f y)

instance Control.Monad.Trans.MonadTrans MaybeT where
  lift = MaybeT <<< (<$>) Just

runMaybeT :: forall m a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT x) = x

module Control.Monad.Maybe.Trans where

import Prelude
import Data.Maybe
import Control.Monad
import Control.Monad.Trans

data MaybeT m a = MaybeT (m (Maybe a))

instance (Prelude.Monad m) => Prelude.Monad (MaybeT m) where
  --return = lift <<< return -- TODO: doesn't type check?
  return x = MaybeT $ return $ Just x
  (>>=) x f = MaybeT $ do
    v <- runMaybeT x
    case v of
      Nothing -> return Nothing
      Just y  -> runMaybeT (f y)

instance Control.Monad.Trans.MonadTrans MaybeT where
  lift = MaybeT <<< liftM Just

runMaybeT :: forall m a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT x) = x


Clean up couple lines of code

Clean up couple lines of code

module Language.Docopt.Parser.Lexer where

import Debug.Trace
import Prelude
import Control.Apply ((*>), (<*))
import Control.Alt ((<|>))
import Control.Plus (empty)
import Control.Monad.State (State(), evalState, get)
import Control.Monad.Trans
import Data.Foldable (foldl)
import Data.String as Str
import Text.Parsing.Parser as P
import Text.Parsing.Parser.Combinators as P
import Text.Parsing.Parser.Token as P
import Text.Parsing.Parser.Pos as P
import Text.Parsing.Parser.String as P
import Data.List as L
import Data.Array as A
import Data.Char (toString, toLower, toUpper)
import Data.String (fromCharArray, fromChar, trim)
import Data.List (List(..), (:), fromList, many)
import Data.Either (Either(..))
import Data.Maybe (Maybe(..), maybe, fromMaybe, isNothing)
import Data.String.Ext ((^=))
import Language.Docopt.Parser.Base
import Language.Docopt.Parser.State
import Data.Tuple
import Data.Int
import Data.Int as I
import Global (isNaN, readFloat)

data Mode = Usage | Descriptions

isDescMode :: Mode -> Boolean
isDescMode Descriptions = true
isDescMode _ = false

isUsageMode :: Mode -> Boolean
isUsageMode Usage = true
isUsageMode _ = false

lex :: Mode -> String -> Either P.ParseError (List PositionedToken)
lex m = flip P.runParser (parseTokens m)

lexDescs :: String -> Either P.ParseError (List PositionedToken)
lexDescs = lex Descriptions

lexUsage :: String -> Either P.ParseError (List PositionedToken)
lexUsage = lex Usage

data Token
  = LParen
  | RParen
  | LSquare
  | RSquare
  | Dash
  | VBar
  | Colon
  | Comma
  | TripleDot
  | Reference String
  | LOpt String (Maybe { name :: String, optional :: Boolean })
  | SOpt Char (Array Char) (Maybe { name :: String, optional :: Boolean })
  | Tag String (Maybe String)
  | Name String
  | ShoutName String
  | AngleName String
  | Garbage Char
  | DoubleDash

prettyPrintToken :: Token -> String
prettyPrintToken LParen            = show '('
prettyPrintToken RParen            = show ')'
prettyPrintToken LSquare           = show '['
prettyPrintToken RSquare           = show ']'
prettyPrintToken Dash              = show '-'
prettyPrintToken VBar              = show '|'
prettyPrintToken Colon             = show ':'
prettyPrintToken Comma             = show ','
prettyPrintToken TripleDot         = "..."
prettyPrintToken DoubleDash        = "--"
prettyPrintToken (Reference r)     = "Reference " ++ show r
prettyPrintToken (Garbage   c)     = "Garbage "   ++ show c
prettyPrintToken (Tag k v)         = "Tag "       ++ k ++ " "  ++ (show v)
prettyPrintToken (Name      n)     = "Name "      ++ show n
prettyPrintToken (ShoutName n)     = "ShoutName " ++ show n
prettyPrintToken (AngleName n)     = "AngleName " ++ show n
prettyPrintToken (LOpt n arg)
  = "--" ++ n
         ++ (fromMaybe "" do
              a <- arg
              return $ if a.optional then "[" else ""
                ++ a.name
                ++ if a.optional then "]" else ""
            )
prettyPrintToken (SOpt n s arg)
  = "-" ++ (fromCharArray (A.cons n s))
        ++ (fromMaybe "" do
              a <- arg
              return $ if a.optional then "[" else ""
                ++ a.name
                ++ if a.optional then "]" else ""
            )

data PositionedToken = PositionedToken
  { sourcePos :: P.Position
  , token     :: Token
  }

instance showToken :: Show Token where
  show = show <<< prettyPrintToken

instance eqToken :: Eq Token where
  eq LParen            LParen             = true
  eq RParen            RParen             = true
  eq LSquare           LSquare            = true
  eq RSquare           RSquare            = true
  eq VBar              VBar               = true
  eq Colon             Colon              = true
  eq Comma             Comma              = true
  eq Dash              Dash               = true
  eq DoubleDash        DoubleDash         = true
  eq TripleDot         TripleDot          = true
  eq (Reference r)     (Reference r')     = r == r'
  eq (LOpt n arg)      (LOpt n' arg')
    = (n == n')
    && ((isNothing arg && isNothing arg')
        || (fromMaybe false do
              a  <- arg
              a' <- arg'
              return $ (a.name == a.name)
                    && (a.optional == a.optional)
            ))
  eq (SOpt n s arg)    (SOpt n' s' arg')
    = (n == n') && (s' == s')
    && ((isNothing arg && isNothing arg')
        || (fromMaybe false do
              a  <- arg
              a' <- arg'
              return $ (a.name == a.name)
                    && (a.optional == a.optional)
            ))
  eq (AngleName n)     (AngleName n')     = n == n'
  eq (ShoutName n)     (ShoutName n')     = n == n'
  eq (Name n)          (Name n')          = n == n'
  eq (Garbage c)       (Garbage c')       = c == c'
  eq _ _                                  = false

instance showPositionedToken :: Show PositionedToken where
  show (PositionedToken { sourcePos=pos, token=tok }) =
    (show tok) ++ " at " ++ (show pos)

parseTokens :: Mode -> P.Parser String (L.List PositionedToken)
parseTokens m = do
  P.skipSpaces
  xs <- L.many $ parsePositionedToken m
  P.eof <|> void do
    i <- getInput
    P.fail $ "Unexpected input: " ++ i
  return xs

parsePositionedToken :: Mode -> P.Parser String PositionedToken
parsePositionedToken m = P.try $ do
  pos <- getPosition
  tok <- parseToken m
  return $ PositionedToken { sourcePos: pos, token: tok }

parseToken :: Mode -> P.Parser String Token
parseToken m = P.choice (P.try <$> A.concat [
    [ P.char   '('   *> pure LParen
    , P.char   ')'   *> pure RParen
    ]
  , if isDescMode m then [ tag ] else []
  , [ reference
    , P.char   '['   *> pure LSquare
    , P.char   ']'   *> pure RSquare
    , P.char   '|'   *> pure VBar
    , P.char   ':'   *> pure Colon
    , P.char   ','   *> pure Comma
    , longOption
    , shortOption
    , AngleName <$> angleName
    , P.string "--"  *> pure DoubleDash
    , P.char   '-'   *> pure Dash
    , P.string "..." *> pure TripleDot
    , ShoutName <$> shoutName
    , Name      <$> name
    ]
  , if isDescMode m
        then [ Garbage <$> P.anyChar ]
        else []
  ])
  <* P.skipSpaces

 where

  whitespace :: P.Parser String Unit
  whitespace = do
    P.satisfy \c -> c == '\n' || c == '\r' || c == ' ' || c == '\t'
    pure unit

  reference :: P.Parser String Token
  reference = Reference <$> do
    P.between (P.char '[') (P.char ']') go

    where
      go = do
        many space
        x <- fromCharArray <<< fromList <$> do
          flip P.manyTill (P.lookAhead $ P.try end) do
            P.noneOf [']']
        end
        many space
        return x

      end = do
        many space
        P.optional $ P.string "-"
        string' "options"
        P.optional $ P.string "..."

  tag :: P.Parser String Token
  tag = P.between (P.char '[')
                  (P.char ']')
                  (withValue <|> withoutValue)

    where
      withValue = do
        many whitespace
        k <- fromCharArray <$> do A.many (P.noneOf [':'])
        P.char ':'
        many whitespace
        v <- trim <<< fromCharArray <$> do A.some $ P.noneOf [']']
        many whitespace
        return (Tag k (Just v))
      withoutValue = do
        k <- trim <<< fromCharArray <$> do A.some $ P.noneOf [']']
        return (Tag k Nothing)

  shoutName :: P.Parser String String
  shoutName = do
    n <- fromCharArray <$> do
      A.cons
        <$> upperAlpha
        <*> (A.many $ regex "[A-Z_-]")
    P.notFollowedBy lowerAlpha
    return n

  name :: P.Parser String String
  name = do
    n  <- alphaNum
    ns <- do
      A.many $ P.try $ do
        P.choice $ P.try <$> [
          identLetter
        , P.char '.' <* (P.notFollowedBy $ P.string "..")
        , P.oneOf [ '-', '_' ]
      ]
    return $ fromCharArray (n A.: ns)

  angleName :: P.Parser String String
  angleName = do
    P.char '<'
    n <- fromCharArray <$> do
      A.some $ P.choice [
        identLetter
        -- disallow swallowing new `<`s in order to avoid creating hard to trace
        -- errors for the user
      , P.try $ P.noneOf [ '<', '>' ]
      ]
    P.char '>'
    return n

  shortOption :: P.Parser String Token
  shortOption = do
    P.char '-'
    x  <- alphaNum
    xs <- A.many alphaNum

    arg <- P.choice $ P.try <$> [

      -- Case 1: OPTION = ARG
      Just <$> do
        -- XXX: Drop the spaces?
        many space *> P.char '=' <* many space
        n <- P.choice $ P.try <$> [ angleName, shoutName, name ]
        return { name:     n
               , optional: false
               }

      -- Case 2: Option[ = ARG ]
    , Just <$> do
        P.char '[' <* many space
        -- XXX: Drop the spaces?
        P.optional (many space *> P.char '=' <* many space)
        n <- P.choice $ P.try <$> [ angleName, shoutName, name ]
        many space *> P.char ']' <* many space
        return { name:     n
               , optional: true
               }

      -- Case 3: Option[ARG]
    , Just <$> do
        -- XXX: Drop the spaces?
        many space *> P.char '[' <* many space
        many space *> P.char '=' <* many space
        n <- P.choice $ P.try <$> [ angleName, shoutName, name ]
        many space *> P.char ']' <* many space
        return { name:     n
               , optional: true
               }

      -- Case 4: Option<ARG>
    , Just <$> do
        n <- angleName
        return { name:     n
               , optional: false
               }

    , return Nothing
    ]

    -- Ensure the argument is correctly bounded
    P.lookAhead $ P.choice [
      P.eof
    , P.try $ void $ P.whiteSpace
    , P.try $ void $ P.char ','
    , P.try $ void $ P.char '|'
    , P.try $ void $ P.char '['
    , P.try $ void $ P.char '('
    , P.try $ void $ P.string "..."
    ]

    return $ SOpt x xs arg

  longOption :: P.Parser String Token
  longOption = do
    P.string "--"

    name' <- fromCharArray <$> do
      A.cons
        <$> alphaNum
        <*> (A.many $ P.choice [
              alphaNum
            , P.oneOf [ '-' ] <* P.lookAhead alphaNum
            ])

    arg <- P.choice $ P.try <$> [

      -- Case 1: OPTION = ARG
      Just <$> do
        -- XXX: Drop the spaces?
        many space *> P.char '=' <* many space
        n <- P.choice $ P.try <$> [ angleName, shoutName, name ]
        return { name:     n
               , optional: false
               }

      -- Case 2: Option[ = ARG ]
    , Just <$> do
        P.char '[' <* many space
        -- XXX: Drop the spaces?
        P.optional (many space *> P.char '=' <* many space)
        n <- P.choice $ P.try <$> [ angleName, shoutName, name ]
        many space *> P.char ']' <* many space
        return { name:     n
               , optional: true
               }

      -- Case 2: Option[ = ARG ]
    , Just <$> do
        P.char '[' <* many space
        -- XXX: Drop the spaces?
        P.optional (many space *> P.char '=' <* many space)
        n <- P.choice $ P.try <$> [ angleName, shoutName, name ]
        many space *> P.char ']' <* many space
        return { name:     n
               , optional: true
               }

      -- Case 3: Option[ARG]
    , Just <$> do
        -- XXX: Drop the spaces?
        many space *> P.char '[' <* many space
        many space *> P.char '=' <* many space
        n <- P.choice $ P.try <$> [ angleName, shoutName, name ]
        many space *> P.char ']' <* many space
        return { name:     n
               , optional: true
               }

    , return Nothing
    ]

    -- Ensure the argument is correctly bounded
    P.lookAhead $ P.choice [
      P.eof
    , P.try $ void $ P.whiteSpace
    , P.try $ void $ P.char ','
    , P.try $ void $ P.char '|'
    , P.try $ void $ P.char '['
    , P.try $ void $ P.char '('
    , P.try $ void $ P.string "..."
    ]

    return $ LOpt name' arg

  identStart :: P.Parser String Char
  identStart = alpha

  identLetter :: P.Parser String Char
  identLetter = alphaNum <|> P.oneOf ['_', '-']

  flag :: P.Parser String Char
  flag = lowerAlphaNum

-- | Parser that  parses a stream of tokens
type TokenParser a = P.ParserT (List PositionedToken) (State ParserState) a

-- | Test the token at the head of the stream
token :: forall a. (Token -> Maybe a) -> TokenParser a
token test = P.ParserT $ \(P.PState { input: toks, position: pos }) ->
  return $ case toks of
    Cons x@(PositionedToken { token: tok, sourcePos: ppos }) xs ->
      case test tok of
        Just a ->
          let nextpos =
              case xs of
                Cons (PositionedToken { sourcePos: npos }) _ -> npos
                Nil -> ppos
          in
            { consumed: true
            , input: xs
            , result: Right a
            , position: nextpos }
        -- XXX: Fix this error message, it makes no sense!
        Nothing -> P.parseFailed toks pos "a better error message!"
    _ -> P.parseFailed toks pos "expected token, met EOF"

-- | Match the token at the head of the stream
match :: forall a. Token -> TokenParser Unit
match tok = token (\tok' -> if (tok' == tok) then Just unit else Nothing)
            P.<?> prettyPrintToken tok

anyToken = token $ Just

eof :: TokenParser Unit
eof = P.notFollowedBy anyToken

lparen :: TokenParser Unit
lparen = match LParen

rparen :: TokenParser Unit
rparen = match RParen

lsquare :: TokenParser Unit
lsquare = match LSquare

rsquare :: TokenParser Unit
rsquare = match RSquare

dash :: TokenParser Unit
dash = match Dash

doubleDash :: TokenParser Unit
doubleDash = match DoubleDash

vbar :: TokenParser Unit
vbar = match VBar

comma :: TokenParser Unit
comma = match Comma

colon :: TokenParser Unit
colon = match Colon

tripleDot :: TokenParser Unit
tripleDot = match TripleDot

garbage :: TokenParser Unit
garbage = token go P.<?> "garbage"
  where
    go (Garbage _) = Just unit
    go _           = Nothing

lopt :: TokenParser { name :: String
                    , arg  :: Maybe { name :: String
                                    , optional :: Boolean
                                    } }
lopt = token go P.<?> "long-option"
  where
    go (LOpt n a) = Just { name: n, arg: a }
    go _          = Nothing

sopt :: TokenParser { flag  :: Char
                    , stack :: Array Char
                    , arg   :: Maybe { name :: String
                                     , optional :: Boolean
                                     } }
sopt = token go P.<?> "short-option"
  where
    go (SOpt n s a) = Just { flag: n , stack: s , arg: a }
    go _ = Nothing

name :: TokenParser String
name = token go P.<?> "name"
  where
    go (Name n) = Just n
    go _        = Nothing

tag :: String -> TokenParser String
tag s = token go P.<?> ("tag: " ++ s)
  where
    go (Tag k (Just v)) | k ^= s = Just v
    go _                         = Nothing

reference :: TokenParser String
reference = token go P.<?> "reference"
  where
    go (Reference r) = Just r
    go _             = Nothing

angleName :: TokenParser String
angleName = token go P.<?> "<name>"
  where
    go (AngleName n) = Just n
    go _             = Nothing

shoutName :: TokenParser String
shoutName = token go P.<?> "NAME"
  where
    go (ShoutName n) = Just n
    go _             = Nothing

-- | Return the next token's position w/o consuming anything
nextTokPos :: TokenParser P.Position
nextTokPos = P.ParserT $ \(P.PState { input: toks, position: pos }) ->
  return $ case toks of
    Cons x@(PositionedToken { token: tok, sourcePos: ppos }) xs ->
      { consumed: false
      , input: toks
      , result: Right ppos
      , position: pos }
    _ -> P.parseFailed toks pos "expected token, met EOF"

runTokenParser :: forall a.
                  (List PositionedToken)
                -> TokenParser a
                -> Either P.ParseError a
runTokenParser s =
  flip evalState ({ indentation: 0, line: 0 })
        <<< P.runParserT (P.PState { input: s, position: P.initialPos })


Include better failure messages

Include better failure messages

module JSON where

  import Prelude
  import Either
  import Monad
  import Maybe
  import Arrays
  import Tuples

  foreign import data JSON :: *

  foreign import fromString "function fromString (str) { \
                            \  try { \
                            \    return _ps.Either.Right(JSON.parse(str)); \
                            \  } catch (e) { \
                            \    return _ps.Either.Left(e.toString()); \
                            \  } \
                            \}" :: String -> Either String JSON

  foreign import readPrimType "function readPrimType (typeName) { \
                              \  return function (value) { \
                              \    if (toString.call(value) == '[object ' + typeName + ']') { \
                              \      return _ps.Either.Right(value);\
                              \    } \
                              \    return _ps.Either.Left('Value is not a ' + typeName + ''); \
                              \  }; \
                              \}" :: forall a. String -> JSON -> Either String a

  foreign import readMaybe "function readMaybe (value) { \
                           \  return value === undefined || value === null ? _ps.Maybe.Nothing : _ps.Maybe.Just(value); \
                           \}" :: forall a. JSON -> Maybe.Maybe JSON

  foreign import readProp "function readProp (k) { \
                          \  return function (obj) { \
                          \    return _ps.Either.Right(obj[k]);\
                          \  }; \
                          \}" :: forall a. String -> JSON -> Either String JSON

  foreign import showJSON "function showJSON (obj) { \
                          \  return JSON.stringify(obj); \
                          \}" :: JSON -> String

  instance Prelude.Show JSON where
    show = showJSON

  data JSONParser a = JSONParser (JSON -> Either String a)

  str :: JSONParser String
  str = JSONParser $ readPrimType "String"

  num :: JSONParser Number
  num = JSONParser $ readPrimType "Number"

  bool :: JSONParser Boolean
  bool = JSONParser $ readPrimType "Boolean"

  arr :: JSONParser [JSON]
  arr = JSONParser $ readPrimType "Array"

  mayb :: JSONParser (Maybe.Maybe JSON)
  mayb = JSONParser $ Right <<< readMaybe

  prop :: String -> JSONParser JSON
  prop p = JSONParser \x -> readProp p x

  runParser :: forall a. JSONParser a -> JSON -> Either String a
  runParser (JSONParser p) x = p x

  instance Prelude.Monad JSONParser where
    return x = JSONParser \_ -> Right x
    (>>=) (JSONParser p) f = JSONParser \x -> case p x of
        Left err -> Left err
        Right x' -> runParser (f x') x

  instance Prelude.Applicative JSONParser where
    pure x = JSONParser \_ -> Right x
    (<*>) (JSONParser f) (JSONParser p) = JSONParser \x -> case f x of
        Left err -> Left err
        Right f' -> f' <$> p x

  instance Prelude.Functor JSONParser where
    (<$>) f (JSONParser p) = JSONParser \x -> f <$> p x

  class ReadJSON a where
    readJSON :: JSONParser a

  instance ReadJSON String where
    readJSON = str

  instance ReadJSON Number where
    readJSON = num

  instance ReadJSON Boolean where
    readJSON = bool

  instance (ReadJSON a) => ReadJSON [a] where
    readJSON = arr >>= \xs -> JSONParser $ \_ ->
      readArrayItem `mapM` (zip (range 0 (length xs)) xs)

  readArrayItem :: forall a. (ReadJSON a) => Tuple Number JSON -> Either String a
  readArrayItem (Tuple i x) = case runParser readJSON x of
      Right result -> Right result
      Left err -> Left $ "Error reading item at index " ++ (show i) ++ ":\n" ++ err

  instance (ReadJSON a) => ReadJSON (Maybe a) where
    readJSON = mayb >>= \x -> JSONParser $ \_ -> case x of
      Just x' -> runParser readJSON x' >>= return <<< Just
      Nothing -> return Nothing

  readJSONProp :: forall a. (ReadJSON a) => String -> JSONParser a
  readJSONProp p = (prop p) >>= \x -> JSONParser $ \_ ->
    case runParser readJSON x of
      Right result -> Right result
      Left err -> Left $ "Error reading property '" ++ p ++ "':\n" ++ err

module Main where

  import Prelude
  import JSON
  import Either
  import Monad
  import Maybe
  import Eff

  foreign import toJSON "function toJSON (obj) { return obj; }" :: forall a. a -> JSON

  showUnsafe :: forall a. a -> String
  showUnsafe = showJSON <<< toJSON

  data Object = Object { foo :: String
                       , bar :: Boolean
                       , baz :: Number
                       , list :: [ListItem] }

  data ListItem = ListItem { x :: Number
                           , y :: Number
                           , z :: Maybe Number }

  instance JSON.ReadJSON ListItem where
    readJSON = do
      x <- readJSONProp "x"
      y <- readJSONProp "y"
      z <- readJSONProp "z"
      return $ ListItem { x: x, y: y, z: z }

  instance JSON.ReadJSON Object where
    readJSON = do
      foo <- readJSONProp "foo"
      bar <- readJSONProp "bar"
      baz <- readJSONProp "baz"
      list <- readJSONProp "list"
      return $ Object { foo: foo, bar: bar, baz: baz, list: list }

  main = do

    let objPass = fromString "{\"foo\":\"hello\",\"bar\":true,\"baz\":1,\"list\":[{\"x\":1,\"y\":2},{\"x\":3,\"y\":4,\"z\":999}]}"
    Trace.print $ case objPass of
      Left err ->  "Error parsing JSON string: " ++ err
      Right obj -> case runParser readJSON obj of
        Left err -> "Error parsing JSON object: " ++ err
        Right (Object result) -> showUnsafe result

    Trace.trace ""

    let objFail = fromString "{\"foo\":\"hello\",\"bar\":true,\"baz\":1,\"list\":[{\"x\":1,\"y\":2},{\"x\":3,\"y\":4,\"z\":false}]}"
    Trace.print $ case objFail of
      Left err ->  "Error parsing JSON string: " ++ err
      Right obj -> case runParser readJSON obj of
        Left err -> "Error parsing JSON object: " ++ err
        Right (Object result) -> showUnsafe result

module JSON where

  import Prelude
  import Either
  import Monad
  import Maybe

  foreign import data JSON :: *

  foreign import fromString "function fromString (str) { \
                            \  try { \
                            \    return _ps.Either.Right(JSON.parse(str)); \
                            \  } catch (e) { \
                            \    return _ps.Either.Left(e.toString()); \
                            \  } \
                            \}" :: String -> Either String JSON

  foreign import readPrimType "function readPrimType (typeName) { \
                              \  return function (value) { \
                              \    if (toString.call(value) == '[object ' + typeName + ']') { \
                              \      return _ps.Either.Right(value);\
                              \    } \
                              \    return _ps.Either.Left('Value is not a ' + typeName + ''); \
                              \  }; \
                              \}" :: forall a. String -> JSON -> Either String a

  foreign import readMaybe "function readMaybe (value) { \
                           \  return value === undefined || value === null ? _ps.Maybe.Nothing : _ps.Maybe.Just(value); \
                           \}" :: forall a. JSON -> Maybe.Maybe JSON

  foreign import readProp "function readProp (k) { \
                          \  return function (obj) { \
                          \    return _ps.Either.Right(obj[k]);\
                          \  }; \
                          \}" :: forall a. String -> JSON -> Either String JSON

  foreign import showJSON "function showJSON (obj) { \
                          \  return JSON.stringify(obj); \
                          \}" :: JSON -> String

  instance Prelude.Show JSON where
    show = showJSON

  data JSONParser a = JSONParser (JSON -> Either String a)

  str :: JSONParser String
  str = JSONParser $ readPrimType "String"

  num :: JSONParser Number
  num = JSONParser $ readPrimType "Number"

  bool :: JSONParser Boolean
  bool = JSONParser $ readPrimType "Boolean"

  arr :: JSONParser [JSON]
  arr = JSONParser $ readPrimType "Array"

  mayb :: JSONParser (Maybe.Maybe JSON)
  mayb = JSONParser $ Right <<< readMaybe

  prop :: String -> JSONParser JSON
  prop p = JSONParser \x -> readProp p x

  runParser :: forall a. JSONParser a -> JSON -> Either String a
  runParser (JSONParser p) x = p x

  instance Prelude.Monad JSONParser where
    return x = JSONParser \_ -> Right x
    (>>=) (JSONParser p) f = JSONParser \x -> case p x of
        Left err -> Left err
        Right x' -> runParser (f x') x

  instance Prelude.Applicative JSONParser where
    pure x = JSONParser \_ -> Right x
    (<*>) (JSONParser f) (JSONParser p) = JSONParser \x -> case f x of
        Left err -> Left err
        Right f' -> f' <$> p x

  instance Prelude.Functor JSONParser where
    (<$>) f (JSONParser p) = JSONParser \x -> f <$> p x

  class ReadJSON a where
    readJSON :: JSONParser a

  instance ReadJSON String where
    readJSON = str

  instance ReadJSON Number where
    readJSON = num

  instance ReadJSON Boolean where
    readJSON = bool

  instance (ReadJSON a) => ReadJSON [a] where
    readJSON = arr >>= \xs -> JSONParser $ \_ -> (runParser readJSON) `mapM` xs

  instance (ReadJSON a) => ReadJSON (Maybe a) where
    readJSON = mayb >>= \x -> JSONParser $ \_ -> case x of
      Just x' -> runParser readJSON x' >>= return <<< Just
      Nothing -> return Nothing

  readJSONProp :: forall a. (ReadJSON a) => String -> JSONParser a
  readJSONProp p = (prop p) >>= \x -> JSONParser $ \_ -> runParser readJSON x

module Main where

  import Prelude
  import JSON
  import Either
  import Monad
  import Maybe
  import Trace

  foreign import toJSON "function toJSON (obj) { return obj; }" :: forall a. a -> JSON

  showUnsafe :: forall a. a -> String
  showUnsafe = showJSON <<< toJSON

  data Object = Object { foo :: String
                       , bar :: Boolean
                       , baz :: Number
                       , list :: [ListItem] }

  data ListItem = ListItem { x :: Number
                           , y :: Number
                           , z :: Maybe Number }

  instance JSON.ReadJSON ListItem where
    readJSON = do
      x <- readJSONProp "x"
      y <- readJSONProp "y"
      z <- readJSONProp "z"
      return $ ListItem { x: x, y: y, z: z }

  instance JSON.ReadJSON Object where
    readJSON = do
      foo <- readJSONProp "foo"
      bar <- readJSONProp "bar"
      baz <- readJSONProp "baz"
      list <- readJSONProp "list"
      return $ Object { foo: foo, bar: bar, baz: baz, list: list }

  main = do
    let obj = fromString "{\"foo\":\"hello\",\"bar\":true,\"baz\":1,\"list\":[{\"x\":1,\"y\":2},{\"x\":3,\"y\":4,\"z\":999}]}"
    case obj of
      Left err -> Trace.print $ "Error parsing: " ++ err
      Right obj -> case runParser readJSON obj of
        Left err -> Trace.print err
        Right (Object result) -> Trace.print $ showUnsafe result


Fixed tests after dataset changed

Fixed tests after dataset changed

module Test.Data.TimeSeries.IO (testIO) where

import Prelude
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (log, CONSOLE)
import Data.Array as A
import Data.Maybe (fromMaybe)
import Data.Tuple(fst, snd)
import Node.Encoding (Encoding(..))
import Node.FS (FS)
import Node.FS.Sync (readTextFile)
import Test.Assert (assert, ASSERT)

import Data.TimeSeries as TS
import Data.TimeSeries.IO as IO

testIO :: ∀ eff. Eff (console :: CONSOLE, assert :: ASSERT, exception :: EXCEPTION, fs :: FS  | eff) Unit
testIO = do

  log "\n# IO tests"
  singleColumnTest
  multiColumnTest
  fromFileTest
  toCsvTest

singleColumnTest :: ∀ eff. Eff (console :: CONSOLE, assert :: ASSERT, exception :: EXCEPTION, fs :: FS  | eff) Unit
singleColumnTest = do
  log "Load single column from CSV"
  let csv1 = "ts,v\n2015-01-02T12:34:56,123.45\n2015-01-02T12:34:57,124\n2015-01-02T12:34:58,125\n"
  let s1 = fromMaybe TS.empty $ A.head $ IO.fromCsv csv1
  assert $ TS.values s1 == [123.45, 124.0, 125.0]

multiColumnTest :: ∀ eff. Eff (console :: CONSOLE, assert :: ASSERT, exception :: EXCEPTION, fs :: FS  | eff) Unit
multiColumnTest = do
  log "Load 2 Time Series from CSV"
  let csv2 = "ts,v1,v2\n2015-01-02T12:34:56,123.45,0.5\n2015-01-02T12:34:57,124,34\n2015-01-02T12:34:58,125,12\n"
  let xs = IO.fromCsv csv2
  assert $ A.length xs == 2

fromFileTest :: ∀ eff. Eff (console :: CONSOLE, assert :: ASSERT, exception :: EXCEPTION, fs :: FS  | eff) Unit
fromFileTest = do
  log "Test load 60K from file"
  csv <- readTextFile UTF8 "testdata/test60k.csv"
  let s1 = fromMaybe TS.empty (A.index (IO.fromCsv csv) 0)
  assert $ TS.length s1 == 59041
  -- Index should increase
  let idx1 = TS.index s1
  let idx2 = A.zip idx1 (fromMaybe [] (A.tail idx1))
  let idx3 = A.filter (\tu -> (fst tu) > (snd tu)) idx2
  assert $ A.length idx3 == 0

toCsvTest :: ∀ eff. Eff (console :: CONSOLE, assert :: ASSERT, exception :: EXCEPTION, fs :: FS  | eff) Unit
toCsvTest = do
  log "Save to CSV"
  let csv1 = "time,value\n2015-01-02T12:34:56.000Z,123.45\n2015-01-02T12:34:57.000Z,124.0\n2015-01-02T12:34:58.000Z,125.0\n"
  let s1 = fromMaybe TS.empty $ A.head $ IO.fromCsv csv1
  assert $ IO.toCsv s1 == csv1

module Test.Data.TimeSeries.IO (testIO) where

import Prelude
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (log, CONSOLE)
import Data.Array as A
import Data.Maybe (fromMaybe)
import Data.Tuple(fst, snd)
import Node.Encoding (Encoding(..))
import Node.FS (FS)
import Node.FS.Sync (readTextFile)
import Test.Assert (assert, ASSERT)

import Data.TimeSeries as TS
import Data.TimeSeries.IO as IO

testIO :: ∀ eff. Eff (console :: CONSOLE, assert :: ASSERT, exception :: EXCEPTION, fs :: FS  | eff) Unit
testIO = do

  log "\n# IO tests"
  singleColumnTest
  multiColumnTest
  fromFileTest
  toCsvTest

singleColumnTest :: ∀ eff. Eff (console :: CONSOLE, assert :: ASSERT, exception :: EXCEPTION, fs :: FS  | eff) Unit
singleColumnTest = do
  log "Load single column from CSV"
  let csv1 = "ts,v\n2015-01-02T12:34:56,123.45\n2015-01-02T12:34:57,124\n2015-01-02T12:34:58,125\n"
  let s1 = fromMaybe TS.empty $ A.head $ IO.fromCsv csv1
  assert $ TS.values s1 == [123.45, 124.0, 125.0]

multiColumnTest :: ∀ eff. Eff (console :: CONSOLE, assert :: ASSERT, exception :: EXCEPTION, fs :: FS  | eff) Unit
multiColumnTest = do
  log "Load 2 Time Series from CSV"
  let csv2 = "ts,v1,v2\n2015-01-02T12:34:56,123.45,0.5\n2015-01-02T12:34:57,124,34\n2015-01-02T12:34:58,125,12\n"
  let xs = IO.fromCsv csv2
  assert $ A.length xs == 2

fromFileTest :: ∀ eff. Eff (console :: CONSOLE, assert :: ASSERT, exception :: EXCEPTION, fs :: FS  | eff) Unit
fromFileTest = do
  log "Test load 60K from file"
  csv <- readTextFile UTF8 "testdata/test60k.csv"
  let s1 = fromMaybe TS.empty (A.index (IO.fromCsv csv) 0)
  assert $ TS.length s1 == 59042
  -- Index should increase
  let idx1 = TS.index s1
  let idx2 = A.zip idx1 (fromMaybe [] (A.tail idx1))
  let idx3 = A.filter (\tu -> (fst tu) > (snd tu)) idx2
  assert $ A.length idx3 == 0

toCsvTest :: ∀ eff. Eff (console :: CONSOLE, assert :: ASSERT, exception :: EXCEPTION, fs :: FS  | eff) Unit
toCsvTest = do
  log "Save to CSV"
  let csv1 = "time,value\n2015-01-02T12:34:56.000Z,123.45\n2015-01-02T12:34:57.000Z,124.0\n2015-01-02T12:34:58.000Z,125.0\n"
  let s1 = fromMaybe TS.empty $ A.head $ IO.fromCsv csv1
  assert $ IO.toCsv s1 == csv1


Use Eq only for state'

Use Eq only for state'

module React.Redox
  ( ConnectState(..)
  , DispatchFn
  , RedoxContext
  , RedoxSpec
  , withStore
  , connect'
  , connect
  , withDispatch
  , dispatch
  , asReactClass
  , overRedoxSpec
  , unsafeShallowEqual
  , unsafeStrictEqual
  ) where

import Prelude

import Control.Monad.Aff (Fiber)
import Control.Monad.Eff (Eff, kind Effect)
import Control.Monad.Eff.Uncurried (EffFn1, EffFn2, runEffFn1, runEffFn2)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Control.Monad.Free (Free)
import Data.Function.Uncurried (Fn2, Fn3, mkFn2, runFn2, runFn3)
import Data.Lens (Getter', view)
import Data.Maybe (Maybe(Just, Nothing))
import Data.Newtype (class Newtype, over)
import React (ReactClass, ReactElement, ReactSpec, ReactThis, childrenToArray, createClass, createElement, forceUpdate, getProps, readState, writeState)
import React as R
import ReactHocs (CONTEXT, withContext, accessContext, readContext, getDisplayName)
import Redox as Redox
import Redox.Store (ReadRedox, RedoxStore, Store, SubscribeRedox, SubscriptionId)
import Type.Proxy (Proxy(..))
import Unsafe.Coerce (unsafeCoerce)

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

-- | Shallowly compare two objects.  If the first argument is true it skips
-- | comparing the `key` property which should not be accessed on a property
-- | object.
foreign import unsafeShallowEqual :: forall a. Fn3 Boolean a a Boolean

-- | Compare two objects using strict equality `===`
foreign import unsafeStrictEqual :: forall a. Fn2 a a Boolean

foreign import writeIsMountedImpl
  :: forall props state e
   . EffFn2 e (ReactThis props state) Boolean Unit

writeIsMounted :: forall props state e. ReactThis props state -> Boolean -> Eff e Unit
writeIsMounted this isMounted = runEffFn2 writeIsMountedImpl this isMounted

foreign import readIsMountedImpl
  :: forall props state e
   . EffFn1 e (ReactThis props state) Boolean

readIsMounted :: forall props state e. ReactThis props state -> Eff e Boolean
readIsMounted this = runEffFn1 readIsMountedImpl this

createClassStatelessWithContext
  :: forall props ctx
   . (props -> ctx -> ReactElement)
  -> ReactClass props
createClassStatelessWithContext fn = unsafeCoerce f
  where
    f :: Fn2 props { ctx :: ctx } ReactElement
    f = mkFn2 (\a { ctx } -> fn a ctx)

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

-- | You need to wrap your most top-level component with `withStore`.  It makes
-- | the store and the bound dispatch function available 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
  -> Eff eff (ReactClass props)
withStore store dispatch_ cls =
  pure $ withContext cls { redox: RedoxContext { store, dispatch: dispatch_ store } }

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

derive instance newtypeConnectState :: Newtype (ConnectState state) _

_connect
  :: forall state state' dsl props props' reff eff
   . Eq state'
  => (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"
    , componentDidMount = componentDidMount
    , 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
      isMounted <- readIsMounted this
      when isMounted do
        void $ writeState this $ over ConnectState (_ { state = view _lns state }) st

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

    -- | Subscription to redox store happens in `componentDidMount`, rather than
    -- | on `componentWillMount`.  This is because `componentWillUnmount` and
    -- | `componentDidMount` do not fire in SSR. Otherwise we'd have a memory
    -- | leak.
    componentDidMount this = do
      writeIsMounted this true
      RedoxContext { store } <- unsafeCoerceEff $ ctxEff this
      st@ConnectState { state } <- readState this
      sid <- Redox.subscribe store $ update this
      _ <- writeState this (over ConnectState (_ { sid = Just sid }) st)
      state' <- view _lns <$> Redox.getState store
      when
        (runFn2 unsafeStrictEqual state state')
        (forceUpdate this)

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

    -- | If `Eq state'` and `Eq props'` are not tight enought you might end up
    -- | with an infitinte loop of actions.  If you see a stack overflow error
    -- | this the usal the cause.  You can use `Data.Record.equal` or one of
    -- | `unsafeShallowEqual`, `unsafeStrictEqual` functions.
    shouldComponentUpdate this nPr (ConnectState nSt) = do
      pr <- getProps this
      ConnectState st <- readState this
      -- Take care only of `st.state` changes, `st.sid` is not used for
      -- rendering.
      pure $ st.state /= nSt.state || not (runFn3 unsafeShallowEqual true pr nPr)

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

-- | Newtype wrapper around `ReactSpec`.  Use  `overRedoxSpec` to change the
-- | underlying spec and `asReactClass` to create a react class.
newtype RedoxSpec props state eff = RedoxSpec (ReactSpec props state eff)

overRedoxSpec
  :: forall props state eff
   . (ReactSpec props state eff ->  ReactSpec props state eff)
  -> RedoxSpec props state eff
  -> RedoxSpec props state eff
overRedoxSpec f (RedoxSpec spec) = RedoxSpec <<< f $ spec

asReactClass :: forall props state eff. RedoxSpec props state eff -> ReactClass props
asReactClass (RedoxSpec spec) = accessContext <<< createClass $ spec

-- | This function makes the redox store and dispatch function available
-- | through context.  The first argument is a lens that identifies the part
-- | of redox store's state that you want to subscribe for.  The view on this
-- | lens will be checked for changes, so if you want to optimise your code,
-- | return as 'tight' lens as possible.
-- |
-- | Use `asReactClass` function to create react class from `RedoxSpec` that
-- | this function returns and `overRedoxSpec` to possibly change the spec, for
-- | example by changing the `shouldComponentUpdate` react life cycle method.
-- |
-- | 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)
-- | ```
-- |
-- | Not the `Eq` type classes must be resolved when you apply this fuction.
-- | Otherwise you will endup with
-- | [re-mounts](https://github.com/purescript-contrib/purescript-react/issues/105).
-- | This can lead to components loosing focus (in case of `input` elements).
connect'
  :: forall state state' dsl props props' reff eff
   . Eq state'
  => Proxy state
  -> Getter' state state'
  -> (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff -> state' -> props' -> props)
  -> ReactClass props
  -> RedoxSpec props' (ConnectState state') ( context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff) | eff )
connect' _ _lns _iso cls = RedoxSpec $ _connect ctxEff _lns _iso cls
  where
    proxy :: Proxy ({ redox :: RedoxContext state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff })
    proxy = Proxy

    ctxEff this = _.redox <$> readContext proxy this

-- | Like `connect'` but for `ReactClass`-es.
connect
  :: forall state state' dsl props props' reff eff'
   . Eq state'
  => 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 = asReactClass $ connect' p _lns _iso cls

-- | If you just want to wrap your actions with a dispatch function use this
-- | function.  Unlike `connect'` (and `connect`) it does not wrap your
-- | component inside another component.
withDispatch
  :: forall state props props' dsl reff eff'
   . (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff' -> props' -> props)
  -> ReactClass props
  -> ReactClass props'
withDispatch fn cls = accessContext $ createClassStatelessWithContext
  \props' { redox: RedoxContext { dispatch: disp }}
  -- todo: childrenToArray
  -> createElement cls (fn disp props') (childrenToArray (unsafeCoerce props').children)

-- | The component must be wrapped with `accessContext` to use this function.
-- | `connect` and `asReactClass` do that for you.
dispatch
  :: forall dsl rProps rState state reff eff
   . ReactThis rProps rState
  -> Free dsl (state -> state)
  -> Eff (context :: CONTEXT, redox :: RedoxStore reff | eff) (Fiber (context :: CONTEXT, redox :: RedoxStore reff | eff) Unit)
dispatch this dsl =
  let proxy :: Proxy ({ redox :: RedoxContext state dsl reff (context :: CONTEXT | eff) })
      proxy = Proxy
  in do
    { redox: RedoxContext { dispatch: disp } } <- readContext proxy this
    disp dsl

module React.Redox
  ( ConnectState(..)
  , DispatchFn
  , RedoxContext
  , RedoxSpec
  , withStore
  , connect'
  , connect
  , withDispatch
  , dispatch
  , asReactClass
  , overRedoxSpec
  , unsafeShallowEqual
  , unsafeStrictEqual
  ) where

import Prelude

import Control.Monad.Aff (Fiber)
import Control.Monad.Eff (Eff, kind Effect)
import Control.Monad.Eff.Uncurried (EffFn1, EffFn2, runEffFn1, runEffFn2)
import Control.Monad.Eff.Unsafe (unsafeCoerceEff)
import Control.Monad.Free (Free)
import Data.Function.Uncurried (Fn2, Fn3, mkFn2, runFn2)
import Data.Lens (Getter', view)
import Data.Maybe (Maybe(Just, Nothing))
import Data.Newtype (class Newtype, over)
import React (ReactClass, ReactElement, ReactSpec, ReactThis, childrenToArray, createClass, createElement, forceUpdate, getProps, readState, writeState)
import React as R
import ReactHocs (CONTEXT, withContext, accessContext, readContext, getDisplayName)
import Redox as Redox
import Redox.Store (ReadRedox, RedoxStore, Store, SubscribeRedox, SubscriptionId)
import Type.Proxy (Proxy(..))
import Unsafe.Coerce (unsafeCoerce)

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

-- | Shallowly compare two objects.  If the first argument is true it skips
-- | comparing the `key` property which should not be accessed on a property
-- | object.
foreign import unsafeShallowEqual :: forall a. Fn3 Boolean a a Boolean

-- | Compare two objects using strict equality `===`
foreign import unsafeStrictEqual :: forall a. Fn2 a a Boolean

foreign import writeIsMountedImpl
  :: forall props state e
   . EffFn2 e (ReactThis props state) Boolean Unit

writeIsMounted :: forall props state e. ReactThis props state -> Boolean -> Eff e Unit
writeIsMounted this isMounted = runEffFn2 writeIsMountedImpl this isMounted

foreign import readIsMountedImpl
  :: forall props state e
   . EffFn1 e (ReactThis props state) Boolean

readIsMounted :: forall props state e. ReactThis props state -> Eff e Boolean
readIsMounted this = runEffFn1 readIsMountedImpl this

createClassStatelessWithContext
  :: forall props ctx
   . (props -> ctx -> ReactElement)
  -> ReactClass props
createClassStatelessWithContext fn = unsafeCoerce f
  where
    f :: Fn2 props { ctx :: ctx } ReactElement
    f = mkFn2 (\a { ctx } -> fn a ctx)

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

-- | You need to wrap your most top-level component with `withStore`.  It makes
-- | the store and the bound dispatch function available 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
  -> Eff eff (ReactClass props)
withStore store dispatch_ cls =
  pure $ withContext cls { redox: RedoxContext { store, dispatch: dispatch_ store } }

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

derive instance newtypeConnectState :: Newtype (ConnectState state) _

_connect
  :: forall state state' dsl props props' reff eff
   . Eq state'
  => Eq props'
  => (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"
    , componentDidMount = componentDidMount
    , 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
      isMounted <- readIsMounted this
      when isMounted do
        void $ writeState this $ over ConnectState (_ { state = view _lns state }) st

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

    -- | Subscription to redox store happens in `componentDidMount`, rather than
    -- | on `componentWillMount`.  This is because `componentWillUnmount` and
    -- | `componentDidMount` do not fire in SSR. Otherwise we'd have a memory
    -- | leak.
    componentDidMount this = do
      writeIsMounted this true
      RedoxContext { store } <- unsafeCoerceEff $ ctxEff this
      st@ConnectState { state } <- readState this
      sid <- Redox.subscribe store $ update this
      _ <- writeState this (over ConnectState (_ { sid = Just sid }) st)
      state' <- view _lns <$> Redox.getState store
      when
        (runFn2 unsafeStrictEqual state state')
        (forceUpdate this)

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

    -- | If `Eq state'` and `Eq props'` are not tight enought you might end up
    -- | with an infitinte loop of actions.  If you see a stack overflow error
    -- | this the usal the cause.  You can use `Data.Record.equal` or one of
    -- | `unsafeShallowEqual`, `unsafeStrictEqual` functions.
    shouldComponentUpdate this nPr (ConnectState nSt) = do
      pr <- getProps this
      ConnectState st <- readState this
      -- Take care only of `st.state` changes, `st.sid` is not used for
      -- rendering.
      pure $ st.state /= nSt.state || pr /= nPr

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

-- | Newtype wrapper around `ReactSpec`.  Use  `overRedoxSpec` to change the
-- | underlying spec and `asReactClass` to create a react class.
newtype RedoxSpec props state eff = RedoxSpec (ReactSpec props state eff)

overRedoxSpec
  :: forall props state eff
   . (ReactSpec props state eff ->  ReactSpec props state eff)
  -> RedoxSpec props state eff
  -> RedoxSpec props state eff
overRedoxSpec f (RedoxSpec spec) = RedoxSpec <<< f $ spec

asReactClass :: forall props state eff. RedoxSpec props state eff -> ReactClass props
asReactClass (RedoxSpec spec) = accessContext <<< createClass $ spec

-- | This function makes the redox store and dispatch function available
-- | through context.  The first argument is a lens that identifies the part
-- | of redox store's state that you want to subscribe for.  The view on this
-- | lens will be checked for changes, so if you want to optimise your code,
-- | return as 'tight' lens as possible.
-- |
-- | Use `asReactClass` function to create react class from `RedoxSpec` that
-- | this function returns and `overRedoxSpec` to possibly change the spec, for
-- | example by changing the `shouldComponentUpdate` react life cycle method.
-- |
-- | 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)
-- | ```
-- |
-- | Not the `Eq` type classes must be resolved when you apply this fuction.
-- | Otherwise you will endup with
-- | [re-mounts](https://github.com/purescript-contrib/purescript-react/issues/105).
-- | This can lead to components loosing focus (in case of `input` elements).
connect'
  :: forall state state' dsl props props' reff eff
   . Eq state'
  => Eq props'
  => Proxy state
  -> Getter' state state'
  -> (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff -> state' -> props' -> props)
  -> ReactClass props
  -> RedoxSpec props' (ConnectState state') ( context :: CONTEXT, redox :: RedoxStore (read :: ReadRedox, subscribe :: SubscribeRedox | reff) | eff )
connect' _ _lns _iso cls = RedoxSpec $ _connect ctxEff _lns _iso cls
  where
    proxy :: Proxy ({ redox :: RedoxContext state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff })
    proxy = Proxy

    ctxEff this = _.redox <$> readContext proxy this

-- | Like `connect'` but for `ReactClass`-es.
connect
  :: forall state state' dsl props props' reff eff'
   . Eq state'
  => Eq props'
  => 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 = asReactClass $ connect' p _lns _iso cls

-- | If you just want to wrap your actions with a dispatch function use this
-- | function.  Unlike `connect'` (and `connect`) it does not wrap your
-- | component inside another component.
withDispatch
  :: forall state props props' dsl reff eff'
   . (DispatchFn state dsl (read :: ReadRedox, subscribe :: SubscribeRedox | reff) eff' -> props' -> props)
  -> ReactClass props
  -> ReactClass props'
withDispatch fn cls = accessContext $ createClassStatelessWithContext
  \props' { redox: RedoxContext { dispatch: disp }}
  -- todo: childrenToArray
  -> createElement cls (fn disp props') (childrenToArray (unsafeCoerce props').children)

-- | The component must be wrapped with `accessContext` to use this function.
-- | `connect` and `asReactClass` do that for you.
dispatch
  :: forall dsl rProps rState state reff eff
   . ReactThis rProps rState
  -> Free dsl (state -> state)
  -> Eff (context :: CONTEXT, redox :: RedoxStore reff | eff) (Fiber (context :: CONTEXT, redox :: RedoxStore reff | eff) Unit)
dispatch this dsl =
  let proxy :: Proxy ({ redox :: RedoxContext state dsl reff (context :: CONTEXT | eff) })
      proxy = Proxy
  in do
    { redox: RedoxContext { dispatch: disp } } <- readContext proxy this
    disp dsl