renderForeignError renders nested ForeignError recursively

-- | This module defines types and functions for working with _foreign_
-- | data.

module Data.Foreign
  ( Foreign
  , ForeignError(..)
  , MultipleErrors(..)
  , F
  , renderForeignError
  , toForeign
  , unsafeFromForeign
  , unsafeReadTagged
  , typeOf
  , tagOf
  , isNull
  , isUndefined
  , isArray
  , readString
  , readChar
  , readBoolean
  , readNumber
  , readInt
  , readArray
  , readNull
  , readUndefined
  , readNullOrUndefined
  , fail
  ) where

import Prelude

import Control.Monad.Except (Except, throwError, mapExcept)

import Data.Either (Either(..), either)
import Data.Int as Int
import Data.List.NonEmpty (NonEmptyList)
import Data.List.NonEmpty as NEL
import Data.Maybe (Maybe(..), maybe)
import Data.String (toChar)

-- | A type for _foreign data_.
-- |
-- | Foreign data is data from any external _unknown_ or _unreliable_
-- | source, for which it cannot be guaranteed that the runtime representation
-- | conforms to that of any particular type.
-- |
-- | Suitable applications of `Foreign` are
-- |
-- | - To represent responses from web services
-- | - To integrate with external JavaScript libraries.
foreign import data Foreign :: Type

-- | A type for foreign type errors
data ForeignError
  = ForeignError String
  | TypeMismatch String String
  | ErrorAtIndex Int ForeignError
  | ErrorAtProperty String ForeignError
  | JSONError String

derive instance eqForeignError :: Eq ForeignError
derive instance ordForeignError :: Ord ForeignError

instance showForeignError :: Show ForeignError where
  show (ForeignError msg) = "(ForeignError " <> show msg <> ")"
  show (ErrorAtIndex i e) = "(ErrorAtIndex " <> show i <> " " <> show e <> ")"
  show (ErrorAtProperty prop e) = "(ErrorAtProperty " <> show prop <> " " <> show e <> ")"
  show (JSONError s) = "(JSONError " <> show s <> ")"
  show (TypeMismatch exps act) = "(TypeMismatch " <> show exps <> " " <> show act <> ")"

-- | A type for accumulating multiple `ForeignError`s.
type MultipleErrors = NonEmptyList ForeignError

renderForeignError :: ForeignError -> String
renderForeignError (ForeignError msg) = msg
renderForeignError (ErrorAtIndex i e) = "Error at array index " <> show i <> ": " <> renderForeignError e
renderForeignError (ErrorAtProperty prop e) = "Error at property " <> prop <> ": " <> renderForeignError e
renderForeignError (JSONError s) = "JSON error: " <> s
renderForeignError (TypeMismatch exp act) = "Type mismatch: expected " <> exp <> ", found " <> act

-- | An error monad, used in this library to encode possible failures when
-- | dealing with foreign data.
-- |
-- | The `Alt` instance for `Except` allows us to accumulate errors,
-- | unlike `Either`, which preserves only the last error.
type F = Except MultipleErrors

-- | Coerce any value to the a `Foreign` value.
foreign import toForeign :: forall a. a -> Foreign

-- | Unsafely coerce a `Foreign` value.
foreign import unsafeFromForeign :: forall a. Foreign -> a

-- | Read the Javascript _type_ of a value
foreign import typeOf :: Foreign -> String

-- | Read the Javascript _tag_ of a value.
-- |
-- | This function wraps the `Object.toString` method.
foreign import tagOf :: Foreign -> String

-- | Unsafely coerce a `Foreign` value when the value has a particular `tagOf`
-- | value.
unsafeReadTagged :: forall a. String -> Foreign -> F a
unsafeReadTagged tag value
  | tagOf value == tag = pure (unsafeFromForeign value)
  | otherwise = fail $ TypeMismatch tag (tagOf value)

-- | Test whether a foreign value is null
foreign import isNull :: Foreign -> Boolean

-- | Test whether a foreign value is undefined
foreign import isUndefined :: Foreign -> Boolean

-- | Test whether a foreign value is an array
foreign import isArray :: Foreign -> Boolean

-- | Attempt to coerce a foreign value to a `String`.
readString :: Foreign -> F String
readString = unsafeReadTagged "String"

-- | Attempt to coerce a foreign value to a `Char`.
readChar :: Foreign -> F Char
readChar value = mapExcept (either (const error) fromString) (readString value)
  where
  fromString = maybe error pure <<< toChar
  error = Left $ NEL.singleton $ TypeMismatch "Char" (tagOf value)

-- | Attempt to coerce a foreign value to a `Boolean`.
readBoolean :: Foreign -> F Boolean
readBoolean = unsafeReadTagged "Boolean"

-- | Attempt to coerce a foreign value to a `Number`.
readNumber :: Foreign -> F Number
readNumber = unsafeReadTagged "Number"

-- | Attempt to coerce a foreign value to an `Int`.
readInt :: Foreign -> F Int
readInt value = mapExcept (either (const error) fromNumber) (readNumber value)
  where
  fromNumber = maybe error pure <<< Int.fromNumber
  error = Left $ NEL.singleton $ TypeMismatch "Int" (tagOf value)

-- | Attempt to coerce a foreign value to an array.
readArray :: Foreign -> F (Array Foreign)
readArray value
  | isArray value = pure $ unsafeFromForeign value
  | otherwise = fail $ TypeMismatch "array" (tagOf value)

readNull :: Foreign -> F (Maybe Foreign)
readNull value
  | isNull value = pure Nothing
  | otherwise = pure (Just value)

readUndefined :: Foreign -> F (Maybe Foreign)
readUndefined value
  | isUndefined value = pure Nothing
  | otherwise = pure (Just value)

readNullOrUndefined :: Foreign -> F (Maybe Foreign)
readNullOrUndefined value
  | isNull value || isUndefined value = pure Nothing
  | otherwise = pure (Just value)

-- | Throws a failure error in `F`.
fail :: forall a. ForeignError -> F a
fail = throwError <<< NEL.singleton

-- | This module defines types and functions for working with _foreign_
-- | data.

module Data.Foreign
  ( Foreign
  , ForeignError(..)
  , MultipleErrors(..)
  , F
  , renderForeignError
  , toForeign
  , unsafeFromForeign
  , unsafeReadTagged
  , typeOf
  , tagOf
  , isNull
  , isUndefined
  , isArray
  , readString
  , readChar
  , readBoolean
  , readNumber
  , readInt
  , readArray
  , readNull
  , readUndefined
  , readNullOrUndefined
  , fail
  ) where

import Prelude

import Control.Monad.Except (Except, throwError, mapExcept)

import Data.Either (Either(..), either)
import Data.Int as Int
import Data.List.NonEmpty (NonEmptyList)
import Data.List.NonEmpty as NEL
import Data.Maybe (Maybe(..), maybe)
import Data.String (toChar)

-- | A type for _foreign data_.
-- |
-- | Foreign data is data from any external _unknown_ or _unreliable_
-- | source, for which it cannot be guaranteed that the runtime representation
-- | conforms to that of any particular type.
-- |
-- | Suitable applications of `Foreign` are
-- |
-- | - To represent responses from web services
-- | - To integrate with external JavaScript libraries.
foreign import data Foreign :: Type

-- | A type for foreign type errors
data ForeignError
  = ForeignError String
  | TypeMismatch String String
  | ErrorAtIndex Int ForeignError
  | ErrorAtProperty String ForeignError
  | JSONError String

derive instance eqForeignError :: Eq ForeignError
derive instance ordForeignError :: Ord ForeignError

instance showForeignError :: Show ForeignError where
  show (ForeignError msg) = "(ForeignError " <> show msg <> ")"
  show (ErrorAtIndex i e) = "(ErrorAtIndex " <> show i <> " " <> show e <> ")"
  show (ErrorAtProperty prop e) = "(ErrorAtProperty " <> show prop <> " " <> show e <> ")"
  show (JSONError s) = "(JSONError " <> show s <> ")"
  show (TypeMismatch exps act) = "(TypeMismatch " <> show exps <> " " <> show act <> ")"

-- | A type for accumulating multiple `ForeignError`s.
type MultipleErrors = NonEmptyList ForeignError

renderForeignError :: ForeignError -> String
renderForeignError (ForeignError msg) = msg
renderForeignError (ErrorAtIndex i e) = "Error at array index " <> show i <> ": " <> show e
renderForeignError (ErrorAtProperty prop e) = "Error at property " <> show prop <> ": " <> show e
renderForeignError (JSONError s) = "JSON error: " <> s
renderForeignError (TypeMismatch exp act) = "Type mismatch: expected " <> exp <> ", found " <> act

-- | An error monad, used in this library to encode possible failures when
-- | dealing with foreign data.
-- |
-- | The `Alt` instance for `Except` allows us to accumulate errors,
-- | unlike `Either`, which preserves only the last error.
type F = Except MultipleErrors

-- | Coerce any value to the a `Foreign` value.
foreign import toForeign :: forall a. a -> Foreign

-- | Unsafely coerce a `Foreign` value.
foreign import unsafeFromForeign :: forall a. Foreign -> a

-- | Read the Javascript _type_ of a value
foreign import typeOf :: Foreign -> String

-- | Read the Javascript _tag_ of a value.
-- |
-- | This function wraps the `Object.toString` method.
foreign import tagOf :: Foreign -> String

-- | Unsafely coerce a `Foreign` value when the value has a particular `tagOf`
-- | value.
unsafeReadTagged :: forall a. String -> Foreign -> F a
unsafeReadTagged tag value
  | tagOf value == tag = pure (unsafeFromForeign value)
  | otherwise = fail $ TypeMismatch tag (tagOf value)

-- | Test whether a foreign value is null
foreign import isNull :: Foreign -> Boolean

-- | Test whether a foreign value is undefined
foreign import isUndefined :: Foreign -> Boolean

-- | Test whether a foreign value is an array
foreign import isArray :: Foreign -> Boolean

-- | Attempt to coerce a foreign value to a `String`.
readString :: Foreign -> F String
readString = unsafeReadTagged "String"

-- | Attempt to coerce a foreign value to a `Char`.
readChar :: Foreign -> F Char
readChar value = mapExcept (either (const error) fromString) (readString value)
  where
  fromString = maybe error pure <<< toChar
  error = Left $ NEL.singleton $ TypeMismatch "Char" (tagOf value)

-- | Attempt to coerce a foreign value to a `Boolean`.
readBoolean :: Foreign -> F Boolean
readBoolean = unsafeReadTagged "Boolean"

-- | Attempt to coerce a foreign value to a `Number`.
readNumber :: Foreign -> F Number
readNumber = unsafeReadTagged "Number"

-- | Attempt to coerce a foreign value to an `Int`.
readInt :: Foreign -> F Int
readInt value = mapExcept (either (const error) fromNumber) (readNumber value)
  where
  fromNumber = maybe error pure <<< Int.fromNumber
  error = Left $ NEL.singleton $ TypeMismatch "Int" (tagOf value)

-- | Attempt to coerce a foreign value to an array.
readArray :: Foreign -> F (Array Foreign)
readArray value
  | isArray value = pure $ unsafeFromForeign value
  | otherwise = fail $ TypeMismatch "array" (tagOf value)

readNull :: Foreign -> F (Maybe Foreign)
readNull value
  | isNull value = pure Nothing
  | otherwise = pure (Just value)

readUndefined :: Foreign -> F (Maybe Foreign)
readUndefined value
  | isUndefined value = pure Nothing
  | otherwise = pure (Just value)

readNullOrUndefined :: Foreign -> F (Maybe Foreign)
readNullOrUndefined value
  | isNull value || isUndefined value = pure Nothing
  | otherwise = pure (Just value)

-- | Throws a failure error in `F`.
fail :: forall a. ForeignError -> F a
fail = throwError <<< NEL.singleton


Fix Ordering generic instance

Fix Ordering generic instance

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

import Prelude

import Data.Array (null, length, sortBy, zipWith)
import Data.Either (Either(..))
import Data.Foldable (all, and, find, fold, intercalate)
import Data.Maybe (Maybe(..))
import Data.String (joinWith)
import Data.Traversable (traverse)
import Data.Tuple (Tuple(..))
import Type.Proxy (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

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

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

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

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

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

instance genericArray :: Generic a => Generic (Array a) where
  toSpine = SArray <<< map (\x _ -> toSpine x)
  toSignature x = SigArray (\_ -> toSignature (lowerProxy x))
    where
    lowerProxy :: Proxy (Array a) -> Proxy a
    lowerProxy _ = Proxy
  fromSpine (SArray x) = traverse (fromSpine <<< force) x
  fromSpine _ = Nothing

instance genericUnit :: Generic Unit where
  toSpine _ = SUnit
  toSignature _ = SigUnit
  fromSpine SUnit = Just unit
  fromSpine _ = Nothing

instance genericTuple :: (Generic a, Generic b) => Generic (Tuple a b) where
  toSpine (Tuple x y) =
    SProd "Data.Tuple.Tuple" [\_ -> toSpine x, \_ -> toSpine y]
  toSignature x =
    SigProd
      "Data.Tuple.Tuple"
      [ { sigConstructor: "Data.Tuple.Tuple"
        , sigValues:
            [ \_ -> toSignature (fstProxy x)
            , \_ -> toSignature (sndProxy x)
            ]
        }
      ]
    where
    fstProxy :: Proxy (Tuple a b) -> Proxy a
    fstProxy _ = Proxy
    sndProxy :: Proxy (Tuple a b) -> Proxy b
    sndProxy _ = Proxy
  fromSpine (SProd "Data.Tuple.Tuple" [x, y]) =
    Tuple <$> fromSpine (force x) <*> fromSpine (force y)
  fromSpine _ = Nothing

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

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

instance genericOrdering :: Generic Ordering where
  toSpine = case _ of
    LT -> SProd "Data.Ordering.LT" []
    EQ -> SProd "Data.Ordering.EQ" []
    GT -> SProd "Data.Ordering.GT" []
  toSignature _ =
    SigProd
      "Data.Ordering.Ordering"
      [ { sigConstructor: "Data.Ordering.LT", sigValues: [] }
      , { sigConstructor: "Data.Ordering.EQ", sigValues: [] }
      , { sigConstructor: "Data.Ordering.GT", sigValues: [] }
      ]
  fromSpine = case _ of
    SProd "Data.Ordering.LT" [] -> Just LT
    SProd "Data.Ordering.EQ" [] -> Just EQ
    SProd "Data.Ordering.GT" [] -> Just GT
    _ -> Nothing

-- | 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))
  | SUnit

instance eqGenericSpine :: Eq GenericSpine where
  eq (SProd s1 arr1) (SProd s2 arr2) =
    s1 == s2 && length arr1 == length arr2 && zipAll eqThunk 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 eqThunk xs ys
  eq SUnit SUnit = true
  eq _ _ = false

instance ordGenericSpine :: Ord GenericSpine where
  compare (SProd s1 arr1) (SProd s2 arr2) =
    case compare s1 s2 of
      EQ -> compare 0 $ zipCompare compareThunk 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 -> orderingToInt $ compare (force x.recValue) (force y.recValue)
      c -> orderingToInt c
  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 compareThunk xs ys
  compare (SArray _) _ = LT
  compare _ (SArray _) = GT
  compare SUnit SUnit = EQ

-- | 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)
  | SigUnit

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) = eqThunk t1 t2
  eq SigUnit SigUnit = true
  eq _ _ = false

instance showGenericSignature :: Show GenericSignature where
  show = showSignature

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

eqDataConstructor :: DataConstructor -> DataConstructor -> Boolean
eqDataConstructor p1 p2
  = p1.sigConstructor == p2.sigConstructor
  && zipAll eqThunk p1.sigValues p2.sigValues

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

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')]
    SigUnit -> ["SigUnit"]

  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
    SigUnit -> false

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

-- | 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 (force sig) <<< force) spines
isValidSpine (SigProd _ alts) (SProd tag values) =
  case find (\alt -> alt.sigConstructor == tag) alts of
    Nothing -> false
    Just { sigValues } ->
      and $ zipWith
        (\sig spine -> isValidSpine (force sig) (force spine))
        sigValues
        values
isValidSpine (SigRecord fieldSigs) (SRecord fieldVals) =
  and $ zipWith
    (\sig val -> isValidSpine (force sig.recValue) (force val.recValue))
    (sortBy (\a b -> compare a.recLabel b.recLabel) fieldSigs)
    (sortBy (\a b -> compare a.recLabel b.recLabel) fieldVals)
isValidSpine SigUnit SUnit = true
isValidSpine _ _ = false

-- ## Generic Functions

-- | 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

genericShowPrec :: Int -> GenericSpine -> String
genericShowPrec d (SProd s arr)
  | null arr = s
  | otherwise =
      showParen (d > 10) $
        s <> " " <> joinWith " " (map (\x -> genericShowPrec 11 (force x)) arr)
      where
      showParen false x = x
      showParen true  x = "(" <> x <> ")"
genericShowPrec _ (SRecord xs) =
  "{" <> joinWith ", " (map showLabelPart xs) <> "}"
  where
  showLabelPart x = x.recLabel <> ": " <> genericShowPrec 0 (force x.recValue)
genericShowPrec _ (SBoolean x) = show x
genericShowPrec _ (SInt x) = show x
genericShowPrec _ (SNumber x) = show x
genericShowPrec _ (SString x) = show x
genericShowPrec _ (SChar x) = show x
genericShowPrec _ (SArray xs) =
  "[" <> joinWith ", "  (map (\x -> genericShowPrec 0 (force x)) xs) <> "]"
genericShowPrec _ SUnit = "unit"

-- | This function can be used as an implementation of the `eq` function of `Eq`
-- | for any type with a `Generic` instance.
-- |
-- | **Note**: It is preferrable to use `derive instance` for `Eq` instances
-- | rather than relying on `gEq`, where possible.
gEq :: forall a. Generic a => a -> a -> Boolean
gEq x y = toSpine x == toSpine y

-- | This function can be used as an implementation of the `compare` function
-- | of `Ord` for any type with a `Generic` instance.
-- |
-- | **Note**: It is preferrable to use `derive instance` for `Ord` instances
-- | rather than relying on `gCompare`, where possible.
gCompare :: forall a. Generic a => a -> a -> Ordering
gCompare x y = compare (toSpine x) (toSpine y)

-- ## Internal functions

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

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

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

compareThunk :: forall a. Ord a => (Unit -> a) -> (Unit -> a) -> Int
compareThunk x y = orderingToInt $ compare (force x) (force y)

eqThunk :: forall a. Eq a => (Unit -> a) -> (Unit -> a) -> Boolean
eqThunk x y = force x == force y

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 && force x.recValue == force y.recValue

orderingToInt :: Ordering -> Int
orderingToInt = case _ of
  EQ -> 0
  LT -> 1
  GT -> -1

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

import Prelude

import Data.Array (null, length, sortBy, zipWith)
import Data.Either (Either(..))
import Data.Foldable (all, and, find, fold, intercalate)
import Data.Maybe (Maybe(..))
import Data.String (joinWith)
import Data.Traversable (traverse)
import Data.Tuple (Tuple(..))
import Type.Proxy (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

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

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

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

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

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

instance genericArray :: Generic a => Generic (Array a) where
  toSpine = SArray <<< map (\x _ -> toSpine x)
  toSignature x = SigArray (\_ -> toSignature (lowerProxy x))
    where
    lowerProxy :: Proxy (Array a) -> Proxy a
    lowerProxy _ = Proxy
  fromSpine (SArray x) = traverse (fromSpine <<< force) x
  fromSpine _ = Nothing

instance genericUnit :: Generic Unit where
  toSpine _ = SUnit
  toSignature _ = SigUnit
  fromSpine SUnit = Just unit
  fromSpine _ = Nothing

instance genericTuple :: (Generic a, Generic b) => Generic (Tuple a b) where
  toSpine (Tuple x y) =
    SProd "Data.Tuple.Tuple" [\_ -> toSpine x, \_ -> toSpine y]
  toSignature x =
    SigProd
      "Data.Tuple.Tuple"
      [ { sigConstructor: "Data.Tuple.Tuple"
        , sigValues:
            [ \_ -> toSignature (fstProxy x)
            , \_ -> toSignature (sndProxy x)
            ]
        }
      ]
    where
    fstProxy :: Proxy (Tuple a b) -> Proxy a
    fstProxy _ = Proxy
    sndProxy :: Proxy (Tuple a b) -> Proxy b
    sndProxy _ = Proxy
  fromSpine (SProd "Data.Tuple.Tuple" [x, y]) =
    Tuple <$> fromSpine (force x) <*> fromSpine (force y)
  fromSpine _ = Nothing

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

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

instance genericOrdering :: Generic Ordering where
  toSpine = case _ of
    LT -> SProd "Data.Ordering.LT" []
    EQ -> SProd "Data.Ordering.EQ" []
    GT -> SProd "Data.Ordering.GT" []
  toSignature _ =
    SigProd
      "Data.Ordering.Ordering"
      [ { sigConstructor: "Data.Ordering.LT", sigValues: [] }
      , { sigConstructor: "Data.Ordering.EQ", sigValues: [] }
      , { sigConstructor: "Data.Ordering.GT", sigValues: [] }
      ]
  fromSpine = case _ of
    SProd "Data.Either.LT" [] -> Just LT
    SProd "Data.Either.EQ" [] -> Just EQ
    SProd "Data.Either.GT" [] -> Just GT
    _ -> Nothing

-- | 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))
  | SUnit

instance eqGenericSpine :: Eq GenericSpine where
  eq (SProd s1 arr1) (SProd s2 arr2) =
    s1 == s2 && length arr1 == length arr2 && zipAll eqThunk 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 eqThunk xs ys
  eq SUnit SUnit = true
  eq _ _ = false

instance ordGenericSpine :: Ord GenericSpine where
  compare (SProd s1 arr1) (SProd s2 arr2) =
    case compare s1 s2 of
      EQ -> compare 0 $ zipCompare compareThunk 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 -> orderingToInt $ compare (force x.recValue) (force y.recValue)
      c -> orderingToInt c
  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 compareThunk xs ys
  compare (SArray _) _ = LT
  compare _ (SArray _) = GT
  compare SUnit SUnit = EQ

-- | 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)
  | SigUnit

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) = eqThunk t1 t2
  eq SigUnit SigUnit = true
  eq _ _ = false

instance showGenericSignature :: Show GenericSignature where
  show = showSignature

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

eqDataConstructor :: DataConstructor -> DataConstructor -> Boolean
eqDataConstructor p1 p2
  = p1.sigConstructor == p2.sigConstructor
  && zipAll eqThunk p1.sigValues p2.sigValues

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

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')]
    SigUnit -> ["SigUnit"]

  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
    SigUnit -> false

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

-- | 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 (force sig) <<< force) spines
isValidSpine (SigProd _ alts) (SProd tag values) =
  case find (\alt -> alt.sigConstructor == tag) alts of
    Nothing -> false
    Just { sigValues } ->
      and $ zipWith
        (\sig spine -> isValidSpine (force sig) (force spine))
        sigValues
        values
isValidSpine (SigRecord fieldSigs) (SRecord fieldVals) =
  and $ zipWith
    (\sig val -> isValidSpine (force sig.recValue) (force val.recValue))
    (sortBy (\a b -> compare a.recLabel b.recLabel) fieldSigs)
    (sortBy (\a b -> compare a.recLabel b.recLabel) fieldVals)
isValidSpine SigUnit SUnit = true
isValidSpine _ _ = false

-- ## Generic Functions

-- | 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

genericShowPrec :: Int -> GenericSpine -> String
genericShowPrec d (SProd s arr)
  | null arr = s
  | otherwise =
      showParen (d > 10) $
        s <> " " <> joinWith " " (map (\x -> genericShowPrec 11 (force x)) arr)
      where
      showParen false x = x
      showParen true  x = "(" <> x <> ")"
genericShowPrec _ (SRecord xs) =
  "{" <> joinWith ", " (map showLabelPart xs) <> "}"
  where
  showLabelPart x = x.recLabel <> ": " <> genericShowPrec 0 (force x.recValue)
genericShowPrec _ (SBoolean x) = show x
genericShowPrec _ (SInt x) = show x
genericShowPrec _ (SNumber x) = show x
genericShowPrec _ (SString x) = show x
genericShowPrec _ (SChar x) = show x
genericShowPrec _ (SArray xs) =
  "[" <> joinWith ", "  (map (\x -> genericShowPrec 0 (force x)) xs) <> "]"
genericShowPrec _ SUnit = "unit"

-- | This function can be used as an implementation of the `eq` function of `Eq`
-- | for any type with a `Generic` instance.
-- |
-- | **Note**: It is preferrable to use `derive instance` for `Eq` instances
-- | rather than relying on `gEq`, where possible.
gEq :: forall a. Generic a => a -> a -> Boolean
gEq x y = toSpine x == toSpine y

-- | This function can be used as an implementation of the `compare` function
-- | of `Ord` for any type with a `Generic` instance.
-- |
-- | **Note**: It is preferrable to use `derive instance` for `Ord` instances
-- | rather than relying on `gCompare`, where possible.
gCompare :: forall a. Generic a => a -> a -> Ordering
gCompare x y = compare (toSpine x) (toSpine y)

-- ## Internal functions

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

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

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

compareThunk :: forall a. Ord a => (Unit -> a) -> (Unit -> a) -> Int
compareThunk x y = orderingToInt $ compare (force x) (force y)

eqThunk :: forall a. Eq a => (Unit -> a) -> (Unit -> a) -> Boolean
eqThunk x y = force x == force y

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 && force x.recValue == force y.recValue

orderingToInt :: Ordering -> Int
orderingToInt = case _ of
  EQ -> 0
  LT -> 1
  GT -> -1


Remove last remnant of `Eff` from the module docs (#44)

-- | ## Overview of the Problem
-- |
-- | This module provides a way of dealing with the JS idiom of options
-- | objects in PureScript, by giving you the tools to provide a reasonably
-- | comfortable typed layer on top of JavaScript APIs which make use of this
-- | idiom.
-- |
-- | Many JavaScript APIs include functions which take an object argument,
-- | where the object's properties come from a fixed set of optional
-- | configuration values. For example, the `createWriteStream` function from
-- | the Node.js `fs` module may contain properties such as:
-- |
-- | - `flags`, which should be a `String`, such as `"w"`, `"rw"`, or `"r+"`,
-- | - `defaultEncoding`, which should be a `String` representing an
-- |   encoding, such as `"utf8"`,
-- |
-- | and so on.
-- |
-- | ## Why PureScript Records Don't Work
-- |
-- | PureScript's record types can be a little awkward for this, since it is
-- | usually the case that any subset of these properties can be specified;
-- | however, a value of  type `{ flags :: String, defaultEncoding :: String, [...] }`
-- | must include every property listed, even if you only want to specify
-- | one or two properties.
-- |
-- | ## Using this Library
-- |
-- | This library provides a better solution for this problem. Using this
-- | module, you could wrap `fs.createWriteStream` as follows:
-- |
-- | First, create a phantom type used for the options object:
-- |
-- | ```purescript
-- | data CreateWriteStreamOptions
-- | ```
-- |
-- | Then, create `Option` values for each of the options:
-- |
-- | ```purescript
-- | flags :: Option CreateWriteStreamOptions String
-- | flags = opt "flags"
-- |
-- | defaultEncoding :: Option CreateWriteStreamOptions String
-- | defaultEncoding = opt "defaultEncoding"
-- |
-- | -- and so on
-- | ```
-- |
-- | Import the function you're wrapping using the FFI, using the `Foreign`
-- | type for the options object:
-- |
-- | ```purescript
-- | -- don't export this!
-- | foreign import createWriteStreamImpl :: FilePath -> Foreign -> Effect Unit
-- | ```
-- |
-- | Finally, in the function you are going to export, take an `Options` value
-- | for the options argument, and use the `options` function provided by this
-- | library to convert it into a `Foreign` value, which will then have a
-- | suitable representation for passing to the JavaScript API.
-- |
-- | ```
-- | createWriteStream :: FilePath -> Options CreateWriteStreamOptions -> Effect Unit
-- | createWriteStream path opts = createWriteStreamImpl path (options opts)
-- | ```
-- |
-- | Then, users of your API can create `Options` values using the `:=`
-- | operator to assign values for the options they want to configure, and the
-- | `Monoid Options` instance to combine them. For example, as a user of this
-- | API, you might write:
-- |
-- | ```purescript
-- | FS.createWriteStream "file.txt" $
-- |    defaultEncoding := "utf8" <>
-- |    flags := "rw"
-- | ```
-- |
-- | ## Increasing Type Safety
-- |
-- | You can also use more specific types for more type safety. For example,
-- | it would be safer to use the existing `FileFlags` and `Encoding` types
-- | already provided by the `node-fs` library. However, we cannot use them
-- | directly because they will have the wrong runtime representation. This is
-- | where the `Contravariant` instance for `Option` comes in; it can be used
-- | to transform an option's value to give it a suitable runtime
-- | representation based on what the JS API is expecting. For example:
-- |
-- | ```purescript
-- | flags :: Option CreateWriteStreamOptions FileFlags
-- | flags = cmap fileFlagsToNode (opt "flags")
-- | ```
-- |
-- | Note that `fileFlagsToNode` takes a `FileFlags` and returns a `String`
-- | suitable for passing to a Node.js API.
module Data.Options
  ( Options(..)
  , options
  , Option
  , assoc, (:=)
  , optional
  , opt
  , tag
  , defaultToOptions
  ) where

import Prelude

import Data.Maybe (Maybe, maybe)
import Data.Newtype (class Newtype, unwrap)
import Data.Op (Op(..))
import Data.Tuple (Tuple(..))
import Foreign (Foreign, unsafeToForeign)
import Foreign.Object as Object

-- | The `Options` type represents a set of options. The type argument is a
-- | phantom type, which is useful for ensuring that options for one particular
-- | API are not accidentally passed to some other API.
newtype Options :: forall k. k -> Type
newtype Options opt = Options (Array (Tuple String Foreign))

type role Options nominal

derive instance newtypeOptions :: Newtype (Options opt) _
derive newtype instance semigroupOptions ∷ Semigroup (Options opt)
derive newtype instance monoidOptions ∷ Monoid (Options opt)

-- | Convert an `Options` value into a JavaScript object, suitable for passing
-- | to JavaScript APIs.
options :: forall opt. Options opt -> Foreign
options (Options os) = unsafeToForeign (Object.fromFoldable os)

-- | An `Option` represents an opportunity to configure a specific attribute
-- | of a call to some API. This normally corresponds to one specific property
-- | of an "options" object in JavaScript APIs, but can in general correspond
-- | to zero or more actual properties.
type Option :: forall k. k -> (Type -> Type)
type Option opt = Op (Options opt)

-- | Associates a value with a specific option.
assoc :: forall opt value. Option opt value -> value -> Options opt
assoc = unwrap

-- | An infix version of `assoc`.
infixr 6 assoc as :=

-- | A version of `assoc` which takes possibly absent values. `Nothing` values
-- | are ignored; passing `Nothing` for the second argument will result in an
-- | empty `Options`.
optional :: forall opt value. Option opt value -> Option opt (Maybe value)
optional option = Op $ maybe mempty (option := _)

-- | The default way of creating `Option` values. Constructs an `Option` with
-- | the given key, which passes the given value through unchanged.
opt :: forall opt value. String -> Option opt value
opt = Op <<< defaultToOptions

-- | Create a `tag`, by fixing an `Option` to a single value.
tag :: forall opt value. Option opt value -> value -> Option opt Unit
tag o value = Op \_ -> o := value

-- | The default method for turning a string property key into an
-- | `Option`. This function simply calls `unsafeToForeign` on the value. If
-- | you need some other behaviour, you can write your own function to replace
-- | this one, and construct an `Option` yourself.
defaultToOptions :: forall opt value. String -> value -> Options opt
defaultToOptions k v = Options [Tuple k (unsafeToForeign v)]

-- | ## Overview of the Problem
-- |
-- | This module provides a way of dealing with the JS idiom of options
-- | objects in PureScript, by giving you the tools to provide a reasonably
-- | comfortable typed layer on top of JavaScript APIs which make use of this
-- | idiom.
-- |
-- | Many JavaScript APIs include functions which take an object argument,
-- | where the object's properties come from a fixed set of optional
-- | configuration values. For example, the `createWriteStream` function from
-- | the Node.js `fs` module may contain properties such as:
-- |
-- | - `flags`, which should be a `String`, such as `"w"`, `"rw"`, or `"r+"`,
-- | - `defaultEncoding`, which should be a `String` representing an
-- |   encoding, such as `"utf8"`,
-- |
-- | and so on.
-- |
-- | ## Why PureScript Records Don't Work
-- |
-- | PureScript's record types can be a little awkward for this, since it is
-- | usually the case that any subset of these properties can be specified;
-- | however, a value of  type `{ flags :: String, defaultEncoding :: String, [...] }`
-- | must include every property listed, even if you only want to specify
-- | one or two properties.
-- |
-- | ## Using this Library
-- |
-- | This library provides a better solution for this problem. Using this
-- | module, you could wrap `fs.createWriteStream` as follows:
-- |
-- | First, create a phantom type used for the options object:
-- |
-- | ```purescript
-- | data CreateWriteStreamOptions
-- | ```
-- |
-- | Then, create `Option` values for each of the options:
-- |
-- | ```purescript
-- | flags :: Option CreateWriteStreamOptions String
-- | flags = opt "flags"
-- |
-- | defaultEncoding :: Option CreateWriteStreamOptions String
-- | defaultEncoding = opt "defaultEncoding"
-- |
-- | -- and so on
-- | ```
-- |
-- | Import the function you're wrapping using the FFI, using the `Foreign`
-- | type for the options object:
-- |
-- | ```purescript
-- | -- don't export this!
-- | foreign import createWriteStreamImpl :: FilePath -> Foreign -> Effect Unit
-- | ```
-- |
-- | Finally, in the function you are going to export, take an `Options` value
-- | for the options argument, and use the `options` function provided by this
-- | library to convert it into a `Foreign` value, which will then have a
-- | suitable representation for passing to the JavaScript API.
-- |
-- | ```
-- | createWriteStream :: forall eff. FilePath -> Options CreateWriteStreamOptions -> Effect Unit
-- | createWriteStream path opts = createWriteStreamImpl path (options opts)
-- | ```
-- |
-- | Then, users of your API can create `Options` values using the `:=`
-- | operator to assign values for the options they want to configure, and the
-- | `Monoid Options` instance to combine them. For example, as a user of this
-- | API, you might write:
-- |
-- | ```purescript
-- | FS.createWriteStream "file.txt" $
-- |    defaultEncoding := "utf8" <>
-- |    flags := "rw"
-- | ```
-- |
-- | ## Increasing Type Safety
-- |
-- | You can also use more specific types for more type safety. For example,
-- | it would be safer to use the existing `FileFlags` and `Encoding` types
-- | already provided by the `node-fs` library. However, we cannot use them
-- | directly because they will have the wrong runtime representation. This is
-- | where the `Contravariant` instance for `Option` comes in; it can be used
-- | to transform an option's value to give it a suitable runtime
-- | representation based on what the JS API is expecting. For example:
-- |
-- | ```purescript
-- | flags :: Option CreateWriteStreamOptions FileFlags
-- | flags = cmap fileFlagsToNode (opt "flags")
-- | ```
-- |
-- | Note that `fileFlagsToNode` takes a `FileFlags` and returns a `String`
-- | suitable for passing to a Node.js API.
module Data.Options
  ( Options(..)
  , options
  , Option
  , assoc, (:=)
  , optional
  , opt
  , tag
  , defaultToOptions
  ) where

import Prelude

import Data.Maybe (Maybe, maybe)
import Data.Newtype (class Newtype, unwrap)
import Data.Op (Op(..))
import Data.Tuple (Tuple(..))
import Foreign (Foreign, unsafeToForeign)
import Foreign.Object as Object

-- | The `Options` type represents a set of options. The type argument is a
-- | phantom type, which is useful for ensuring that options for one particular
-- | API are not accidentally passed to some other API.
newtype Options :: forall k. k -> Type
newtype Options opt = Options (Array (Tuple String Foreign))

type role Options nominal

derive instance newtypeOptions :: Newtype (Options opt) _
derive newtype instance semigroupOptions ∷ Semigroup (Options opt)
derive newtype instance monoidOptions ∷ Monoid (Options opt)

-- | Convert an `Options` value into a JavaScript object, suitable for passing
-- | to JavaScript APIs.
options :: forall opt. Options opt -> Foreign
options (Options os) = unsafeToForeign (Object.fromFoldable os)

-- | An `Option` represents an opportunity to configure a specific attribute
-- | of a call to some API. This normally corresponds to one specific property
-- | of an "options" object in JavaScript APIs, but can in general correspond
-- | to zero or more actual properties.
type Option :: forall k. k -> (Type -> Type)
type Option opt = Op (Options opt)

-- | Associates a value with a specific option.
assoc :: forall opt value. Option opt value -> value -> Options opt
assoc = unwrap

-- | An infix version of `assoc`.
infixr 6 assoc as :=

-- | A version of `assoc` which takes possibly absent values. `Nothing` values
-- | are ignored; passing `Nothing` for the second argument will result in an
-- | empty `Options`.
optional :: forall opt value. Option opt value -> Option opt (Maybe value)
optional option = Op $ maybe mempty (option := _)

-- | The default way of creating `Option` values. Constructs an `Option` with
-- | the given key, which passes the given value through unchanged.
opt :: forall opt value. String -> Option opt value
opt = Op <<< defaultToOptions

-- | Create a `tag`, by fixing an `Option` to a single value.
tag :: forall opt value. Option opt value -> value -> Option opt Unit
tag o value = Op \_ -> o := value

-- | The default method for turning a string property key into an
-- | `Option`. This function simply calls `unsafeToForeign` on the value. If
-- | you need some other behaviour, you can write your own function to replace
-- | this one, and construct an `Option` yourself.
defaultToOptions :: forall opt value. String -> value -> Options opt
defaultToOptions k v = Options [Tuple k (unsafeToForeign v)]


Fix the Ord instance for Argument

Fix the Ord instance for Argument

module Docopt.Types where

import Prelude
import Debug.Trace
import Data.Either (Either(..))
import Data.Maybe (Maybe(..))
import Data.List (List(..))
import Data.Function (on)
import Data.Foldable (intercalate)
import Data.Monoid (Monoid)
import Data.String (fromChar)
import Control.Apply ((*>))

type Name = String
type IsRepeatable = Boolean
type IsOptional = Boolean
type TakesArgument = Boolean
type Flag = Char

data Program = Program (List Application)
data Application = Application (List Branch)
data Branch = Branch (List Argument)
data Argument
  = Command     String
  | Positional  String IsRepeatable
  | Option      (Maybe Flag)
                (Maybe Name)
                (Maybe OptionArgument)
                IsRepeatable
  | Group       IsOptional (List Branch) IsRepeatable
  | EOA

data OptionArgument = OptionArgument Name (Maybe Value)

data Value
  = StringValue String
  | BoolValue   Boolean
  | ArrayValue  (Array Value)

--------------------------------------------------------------------------------
-- Instances -------------------------------------------------------------------
--------------------------------------------------------------------------------

instance showApplication :: Show Application where
  show (Application xs) = "Application " ++ show (show <$> xs)

instance eqApplication :: Eq Application where
  eq (Application xs) (Application ys) = xs == ys

instance showBranch :: Show Branch where
  show (Branch xs) = "Branch " ++ show (show <$> xs)

instance eqBranch :: Eq Branch where
  eq (Branch xs) (Branch xs') = (xs == xs')

instance showArgument :: Show Argument where
  show (EOA) = "--"
  show (Command n)
    = intercalate " " [ "Command", show n ]
  show (Positional n r)
    = intercalate " " [ "Positional", show n, show r ]
  show (Group o bs r)
    = intercalate " " [ "Group", show o, show bs, show r ]
  show (Option f n a r)
    = intercalate " " [ "Option", show f, show n, show a, show r ]

instance ordArgument :: Ord Argument where
  -- XXX: Implement a more efficient `compare` function
  compare = compare `on` show

instance eqArgument :: Eq Argument where
  eq (EOA)            (EOA)                = true
  eq (Command n)      (Command n')         = (n == n')
  eq (Positional n r) (Positional n' r')   = (n == n') && (r == r')
  eq (Group o bs r)   (Group o' bs' r')    = (o == o') && (bs == bs') && (r == r')
  eq (Option f  n  (Just (OptionArgument a  _)) r)
     (Option f' n' (Just (OptionArgument a' _)) r')
      = (f == f') && (n == n') && (a == a') && (r == r')
  eq (Option f  n  Nothing r)
     (Option f' n' Nothing r')
      = (f == f') && (n == n') && (r == r')
  eq _                _                    = false

instance showOptionArgument :: Show OptionArgument where
  show (OptionArgument n a) = (show n) ++ " " ++ (show a)

instance eqOptionArgument :: Eq OptionArgument where
  eq (OptionArgument n a) (OptionArgument n' a') = (n == n') && (a == a')

instance showValue :: Show Value where
  show (StringValue s) = "StringValue " ++ s
  show (BoolValue b)   = "BoolValue "   ++ (show b)
  show (ArrayValue xs) = "ArrayValue "  ++ show (show <$> xs)

instance eqValue :: Eq Value where
  eq (StringValue s) (StringValue s') = (s == s')
  eq (BoolValue b)   (BoolValue b')   = (b == b')
  eq (ArrayValue xs) (ArrayValue xs') = (xs == xs')
  eq _               _                = false

instance semigroupApplication :: Semigroup Application where
  append (Application xs) (Application ys) = Application (xs <> ys)

instance monoidApplication :: Monoid Application where
  mempty = Application Nil

--------------------------------------------------------------------------------
-- Errors (XXX: needs migration and improvement) -------------------------------
--------------------------------------------------------------------------------

import qualified Text.Parsing.Parser as P

data SolveError = SolveError

instance showSolveError :: Show SolveError where
  show SolveError = "SolveError"

data DocoptError
  = DocoptScanError   P.ParseError
  | DocoptParseError  P.ParseError
  | DocoptSolveError  SolveError

instance showDocoptError :: Show DocoptError where
  show (DocoptScanError err)  = "DocoptScanError "  ++ show err
  show (DocoptParseError err) = "DocoptParseError " ++ show err
  show (DocoptSolveError err) = "DocoptSolveError"  ++ show err

--------------------------------------------------------------------------------
-- Utilities
--------------------------------------------------------------------------------

isRepeatable :: Argument -> Boolean
isRepeatable (Option _ _ _ r) = r
isRepeatable (Positional _ r) = r
isRepeatable _                = false

hasDefault :: Argument -> Boolean
hasDefault (Option _ _ (Just (OptionArgument _ (Just _))) _) = true
hasDefault _                                                 = false

takesArgument :: Argument -> Boolean
takesArgument (Option _ _ (Just _) _) = true
takesArgument _                       = false

isFlag :: Argument -> Boolean
isFlag (Option _ _ (Just (OptionArgument _ (Just (BoolValue _)))) _) = true
isFlag _                                                             = false

isSameValueType :: Value -> Value -> Boolean
isSameValueType (StringValue _) (StringValue _) = true
isSameValueType (BoolValue _)   (BoolValue _)   = true
isSameValueType (ArrayValue _)  (ArrayValue _)  = true
isSameValueType _               _               = false

isBoolValue :: Value -> Boolean
isBoolValue (BoolValue _) = true
isBoolValue _             = false

isArrayValue :: Value -> Boolean
isArrayValue (ArrayValue _) = true
isArrayValue _              = false

module Docopt.Types where

import Prelude
import Data.Either
import Data.Maybe
import Debug.Trace
import Data.List
import Data.Foldable (intercalate)
import Data.Monoid (Monoid)
import Data.String (fromChar)
import Control.Apply ((*>))

type Name = String
type IsRepeatable = Boolean
type IsOptional = Boolean
type TakesArgument = Boolean
type Flag = Char

data Program = Program (List Application)
data Application = Application (List Branch)
data Branch = Branch (List Argument)
data Argument
  = Command     String
  | Positional  String IsRepeatable
  | Option      (Maybe Flag)
                (Maybe Name)
                (Maybe OptionArgument)
                IsRepeatable
  | Group       IsOptional (List Branch) IsRepeatable
  | EOA

data OptionArgument = OptionArgument Name (Maybe Value)

data Value
  = StringValue String
  | BoolValue   Boolean
  | ArrayValue  (Array Value)

--------------------------------------------------------------------------------
-- Instances -------------------------------------------------------------------
--------------------------------------------------------------------------------

instance showApplication :: Show Application where
  show (Application xs) = "Application " ++ show (show <$> xs)

instance eqApplication :: Eq Application where
  eq (Application xs) (Application ys) = xs == ys

instance showBranch :: Show Branch where
  show (Branch xs) = "Branch " ++ show (show <$> xs)

instance eqBranch :: Eq Branch where
  eq (Branch xs) (Branch xs') = (xs == xs')

instance showArgument :: Show Argument where
  show (EOA) = "--"
  show (Command n)
    = intercalate " " [ "Command", show n ]
  show (Positional n r)
    = intercalate " " [ "Positional", show n, show r ]
  show (Group o bs r)
    = intercalate " " [ "Group", show o, show bs, show r ]
  show (Option f n a r)
    = intercalate " " [ "Option", show f, show n, show a, show r ]

instance ordArgument :: Ord Argument where
  compare _ _ = EQ

instance eqArgument :: Eq Argument where
  eq (EOA)            (EOA)                = true
  eq (Command n)      (Command n')         = (n == n')
  eq (Positional n r) (Positional n' r')   = (n == n') && (r == r')
  eq (Group o bs r)   (Group o' bs' r')    = (o == o') && (bs == bs') && (r == r')
  eq (Option f  n  (Just (OptionArgument a  _)) r)
     (Option f' n' (Just (OptionArgument a' _)) r')
      = (f == f') && (n == n') && (a == a') && (r == r')
  eq (Option f  n  Nothing r)
     (Option f' n' Nothing r')
      = (f == f') && (n == n') && (r == r')
  eq _                _                    = false

instance showOptionArgument :: Show OptionArgument where
  show (OptionArgument n a) = (show n) ++ " " ++ (show a)

instance eqOptionArgument :: Eq OptionArgument where
  eq (OptionArgument n a) (OptionArgument n' a') = (n == n') && (a == a')

instance showValue :: Show Value where
  show (StringValue s) = "StringValue " ++ s
  show (BoolValue b)   = "BoolValue "   ++ (show b)
  show (ArrayValue xs) = "ArrayValue "  ++ show (show <$> xs)

instance eqValue :: Eq Value where
  eq (StringValue s) (StringValue s') = (s == s')
  eq (BoolValue b)   (BoolValue b')   = (b == b')
  eq (ArrayValue xs) (ArrayValue xs') = (xs == xs')
  eq _               _                = false

instance semigroupApplication :: Semigroup Application where
  append (Application xs) (Application ys) = Application (xs <> ys)

instance monoidApplication :: Monoid Application where
  mempty = Application Nil

--------------------------------------------------------------------------------
-- Errors (XXX: needs migration and improvement) -------------------------------
--------------------------------------------------------------------------------

import qualified Text.Parsing.Parser as P

data SolveError = SolveError

instance showSolveError :: Show SolveError where
  show SolveError = "SolveError"

data DocoptError
  = DocoptScanError   P.ParseError
  | DocoptParseError  P.ParseError
  | DocoptSolveError  SolveError

instance showDocoptError :: Show DocoptError where
  show (DocoptScanError err)  = "DocoptScanError "  ++ show err
  show (DocoptParseError err) = "DocoptParseError " ++ show err
  show (DocoptSolveError err) = "DocoptSolveError"  ++ show err

--------------------------------------------------------------------------------
-- Utilities
--------------------------------------------------------------------------------

isRepeatable :: Argument -> Boolean
isRepeatable (Option _ _ _ r) = r
isRepeatable (Positional _ r) = r
isRepeatable _                = false

hasDefault :: Argument -> Boolean
hasDefault (Option _ _ (Just (OptionArgument _ (Just _))) _) = true
hasDefault _                                                 = false

takesArgument :: Argument -> Boolean
takesArgument (Option _ _ (Just _) _) = true
takesArgument _                       = false

isFlag :: Argument -> Boolean
isFlag (Option _ _ (Just (OptionArgument _ (Just (BoolValue _)))) _) = true
isFlag _                                                             = false

isSameValueType :: Value -> Value -> Boolean
isSameValueType (StringValue _) (StringValue _) = true
isSameValueType (BoolValue _)   (BoolValue _)   = true
isSameValueType (ArrayValue _)  (ArrayValue _)  = true
isSameValueType _               _               = false

isBoolValue :: Value -> Boolean
isBoolValue (BoolValue _) = true
isBoolValue _             = false

isArrayValue :: Value -> Boolean
isArrayValue (ArrayValue _) = true
isArrayValue _              = false


rotate changed

rotate changed

module Main where

import Prelude
import qualified Math as M
import qualified Data.Vector2 as V
import qualified Data.Vector as V
import Control.Monad.Eff
import Control.Monad.Eff.Console
import Control.Monad.ST
import Control.Monad.Eff.Random
import Control.Apply
import Data.Array.ST
import Graphics.Canvas
import Data.Maybe
import DOM
import Signal
import Signal.Time

foreign import windowWidth :: forall eff. Eff ( dom :: DOM | eff ) Number
foreign import windowHeight :: forall eff. Eff ( dom :: DOM | eff ) Number

main = do
  Just element <- getCanvasElementById "canvas"
  width <- windowWidth
  height <- windowHeight
  setCanvasWidth width element
  setCanvasHeight height element
  context <- getContext2D element
  initRef <- emptySTArray
  forE 0.0 50.0 (\_ -> do
       x <- map (* width) random
       y <- map (* height) random
       r <- map (\x -> x * 70.0 + 50.0) random
       c <- map (\x -> "hsla(" ++ show (x * 360.0) ++ ",100%,50%, 0.4)") random
       pushSTArray initRef $ {x:x, y:y, r:r, c:c}
       return unit)
  runSignal $ loop ~> (\angle -> do
       clearRect context {x:0.0,y:0.0,w:width,h:height}
       init <- toAssocArray initRef
       foreachE init (\{index:_, value:{x:x,y:y,r:r,c:c}} -> do
                             draw context x y r (angle * (50.0/r)) c
                             return unit))

loop = foldp (\a b -> b + 0.2) 0.0 (every $ 50.0 * millisecond)

draw context x y radius baseAngle color = do
  beginPath context
  translate { translateX : x, translateY : y } context
  setGlobalAlpha context 0.0
  setLineWidth 2.5 context
  setFillStyle color context
  forE 0.0 samples (\i ->
       let
        -- previus
        preAngle = M.pi * 2.0 * (i - 1.0) / samples
        preR = (func (preAngle * 10.0) radius) + radius
        prePos = V.scale preR $ V.vec2 (M.sin preAngle) (M.cos preAngle)
        -- current
        angle = M.pi * 2.0 * i / samples
        r = (func (angle * 10.0) radius) + radius
        pos = V.scale r $ V.vec2 (M.sin $ angle + baseAngle) (M.cos $ angle + baseAngle)
       in
        do
          line context prePos pos
          return unit
  )
  closePath context
  fill context
  translate { translateX : (0.0 - x), translateY : (0.0 - y) } context
  where
        samples = 200.0

func angle radius =
     let
       a = radius / 20.0
     in
        a * (10.0 * M.pow (M.sin $ angle / 2.0 + 1.0) 3.0) + (20.0 * (M.sin $ angle + 3.0))

line context origin to =
  let
    originX = V.get2X origin + 0.5
    originY = V.get2Y origin + 0.5
    toX = V.get2X to + 0.5
    toY = V.get2Y to + 0.5
  in
     lineTo context toX toY

module Main where

import Prelude
import qualified Math as M
import qualified Data.Vector2 as V
import qualified Data.Vector as V
import Control.Monad.Eff
import Control.Monad.Eff.Console
import Control.Monad.ST
import Control.Monad.Eff.Random
import Control.Apply
import Data.Array.ST
import Graphics.Canvas
import Data.Maybe
import DOM
import Signal
import Signal.Time

foreign import windowWidth :: forall eff. Eff ( dom :: DOM | eff ) Number
foreign import windowHeight :: forall eff. Eff ( dom :: DOM | eff ) Number

main = do
  Just element <- getCanvasElementById "canvas"
  width <- windowWidth
  height <- windowHeight
  setCanvasWidth width element
  setCanvasHeight height element
  context <- getContext2D element
  initRef <- emptySTArray
  forE 0.0 50.0 (\_ -> do
       x <- map (* width) random
       y <- map (* height) random
       r <- map (\x -> x * 70.0 + 50.0) random
       c <- map (\x -> "hsla(" ++ show (x * 360.0) ++ ",100%,50%, 0.4)") random
       pushSTArray initRef $ {x:x, y:y, r:r, c:c}
       return unit)
  runSignal $ loop ~> (\angle -> do
       clearRect context {x:0.0,y:0.0,w:width,h:height}
       init <- toAssocArray initRef
       foreachE init (\{index:_, value:{x:x,y:y,r:r,c:c}} -> do
                             draw context x y r (angle * (r/100.0)) c
                             return unit))

loop = foldp (\a b -> b + 0.2) 0.0 (every $ 50.0 * millisecond)

draw context x y radius baseAngle color = do
  beginPath context
  translate { translateX : x, translateY : y } context
  setGlobalAlpha context 0.0
  setLineWidth 2.5 context
  setFillStyle color context
  forE 0.0 samples (\i ->
       let
        -- previus
        preAngle = M.pi * 2.0 * (i - 1.0) / samples
        preR = (func (preAngle * 10.0) radius) + radius
        prePos = V.scale preR $ V.vec2 (M.sin preAngle) (M.cos preAngle)
        -- current
        angle = M.pi * 2.0 * i / samples
        r = (func (angle * 10.0) radius) + radius
        pos = V.scale r $ V.vec2 (M.sin $ angle + baseAngle) (M.cos $ angle + baseAngle)
       in
        do
          line context prePos pos
          return unit
  )
  closePath context
  fill context
  translate { translateX : (0.0 - x), translateY : (0.0 - y) } context
  where
        samples = 200.0

func angle radius =
     let
       a = radius / 20.0
     in
        a * (10.0 * M.pow (M.sin $ angle / 2.0 + 1.0) 3.0) + (20.0 * (M.sin $ angle + 3.0))

line context origin to =
  let
    originX = V.get2X origin + 0.5
    originY = V.get2Y origin + 0.5
    toX = V.get2X to + 0.5
    toY = V.get2Y to + 0.5
  in
     lineTo context toX toY


Use normal IN queries

Use normal IN queries

{-
Copyright 2015 SlamData, Inc.

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

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

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

module Test.SlamData.Feature.Test.Markdown where

import Data.String (joinWith)
import Control.Apply ((*>))
import Prelude
import Test.Feature.Log (successMsg)
import Test.SlamData.Feature.Monad (SlamFeature)
import Test.SlamData.Feature.Interactions as Interact
import Test.SlamData.Feature.Expectations as Expect
import Test.Feature.Scenario (scenario)

mdScenario ∷ String → Array String → SlamFeature Unit → SlamFeature Unit
mdScenario =
  scenario
    "Markdown"
    (Interact.createWorkspaceInTestFolder "Markdown")
    (Interact.deleteFileInTestFolder "Untitled Workspace.slam"
       *> Interact.browseRootFolder)

test ∷ SlamFeature Unit
test = do
  mdScenario "Provide and play markdown" ["https://github.com/slamdata/slamdata/issues/987"] do
    Interact.insertMdCardInLastDeck
    Interact.provideMdInLastMdCard
      $ joinWith "\n\n"
          [ "discipline = __"
          , "sport = __ (Bobsleigh)"
          , "age = #__"
          , "year = #__ (2002)"
          , "startDate = __ - __ - __"
          , "finishDate = __ - __ - __ (2002-06-06)"
          , "startTime = __ : __"
          , "finishTime = __ : __ (20:39)"
          , "event = {1000m, 1500m, 3000m} (1500m)"
          , "gender = []M []W []X"
          , "color = [x]Red []Green [x]Blue"
          , "type = (x)Gold ()Silver ()Bronze"
          ]
    Interact.runQuery
    Interact.accessNextCardInLastDeck
    Interact.insertDisplayMarkdownCardInLastDeck
    Expect.fieldInLastMdCard "discipline" "text" ""
    Expect.fieldInLastMdCard "sport" "text" "Bobsleigh"
    Expect.fieldInLastMdCard "age" "number" ""
    Expect.fieldInLastMdCard "year" "number" "2002"
    Expect.fieldInLastMdCard "startDate" "date" ""
    Expect.fieldInLastMdCard "finishDate" "date" "2002-06-06"
    Expect.fieldInLastMdCard "startTime" "time" ""
    Expect.fieldInLastMdCard "finishTime" "time" "20:39"
    Expect.labelInLastMdCard "event"
    Expect.dropdownInLastMdCard "1500m" ["1000m", "1500m", "3000m"]
    Expect.labelInLastMdCard "gender"
    Expect.checkableFieldInLastMdCard "X" "checkbox" false
    Expect.checkableFieldInLastMdCard "W" "checkbox" false
    Expect.checkableFieldInLastMdCard "M" "checkbox" false
    Expect.labelInLastMdCard "color"
    Expect.checkableFieldInLastMdCard "Red" "checkbox" true
    Expect.checkableFieldInLastMdCard "Green" "checkbox" false
    Expect.checkableFieldInLastMdCard "Blue" "checkbox" true
    Expect.labelInLastMdCard "type"
    Expect.checkableFieldInLastMdCard "Gold" "radio" true
    Expect.checkableFieldInLastMdCard "Silver" "radio" false
    Expect.checkableFieldInLastMdCard "Bronze" "radio" false

    successMsg "Ok, succesfully provided and played markdown."

  mdScenario "Change and play markdown" [] do
    Interact.insertMdCardInLastDeck
    Interact.provideMdInLastMdCard "discipline = __"
    Interact.runQuery
    Interact.accessNextCardInLastDeck
    Interact.insertDisplayMarkdownCardInLastDeck
    Interact.accessPreviousCardInLastDeck
    Interact.provideMdInLastMdCard "sport =  __ (Bobsleigh)"
    Interact.runQuery
    Interact.accessNextCardInLastDeck

    Expect.fieldInLastMdCard "sport" "text" "Bobsleigh"
    successMsg "Ok, successfully changed and played markdown."

  mdScenario "Provide and play markdown with evaluated content" [] do
    Interact.insertMdCardInLastDeck
    Interact.provideMdInLastMdCard $ joinWith "\n\n"
      [ "discipline = __ (!``SELECT discipline FROM `/test-mount/testDb/olympics` LIMIT 1``)"
      , "year = __ (!``SELECT year FROM `/test-mount/testDb/olympics` LIMIT 1``)"
      , "country = {!``SELECT DISTINCT country FROM `/test-mount/testDb/olympics` ``} (!``SELECT country FROM `/test-mount/testDb/olympics` LIMIT 1``)"
      , "type = (!``SELECT DISTINCT type FROM `/test-mount/testDb/olympics` LIMIT 1``) !``SELECT DISTINCT type FROM `/test-mount/testDb/olympics` OFFSET 1``"
      , "gender = [!``SELECT gender FROM `/test-mount/testDb/olympics` LIMIT 1``] !``SELECT DISTINCT gender FROM `/test-mount/testDb/olympics` ``"
      ]
    Interact.runQuery
    Interact.accessNextCardInLastDeck
    Interact.insertDisplayMarkdownCardInLastDeck
    Expect.fieldInLastMdCard "discipline" "text" "Figure skating"
    Expect.fieldInLastMdCard "year" "text" "1924"
    Expect.labelInLastMdCard "country"
    Expect.dropdownInLastMdCard "AUT"
      [ "LAT"
      , "CZE"
      , "UKR"
      , "SLO"
      , "RUS"
      , "SVK"
      , "KAZ"
      , "AUS"
      , "LUX"
      , "UZB"
      , "EUN"
      , "DEN"
      , "CHN"
      , "ROU"
      , "GDR"
      , "PRK"
      , "CRO"
      , "URS"
      , "BLR"
      , "BUL"
      , "POL"
      , "EUA"
      , "KOR"
      , "NED"
      , "ITA"
      , "FRG"
      , "EST"
      , "SWE"
      , "GBR"
      , "TCH"
      , "BEL"
      , "FIN"
      , "USA"
      , "YUG"
      , "SUI"
      , "LIE"
      , "CAN"
      , "JPN"
      , "HUN"
      , "GER"
      , "NOR"
      , "NZL"
      , "FRA"
      , "AUT"
      , "ESP"
      ]
    Expect.labelInLastMdCard "gender"
    Expect.checkableFieldInLastMdCard "X" "checkbox" false
    Expect.checkableFieldInLastMdCard "W" "checkbox" true
    Expect.checkableFieldInLastMdCard "M" "checkbox" false
    Expect.labelInLastMdCard "type"
    Expect.checkableFieldInLastMdCard "Gold" "radio" false
    Expect.checkableFieldInLastMdCard "Silver" "radio" true
    Expect.checkableFieldInLastMdCard "Bronze" "radio" false
    successMsg "Ok, successfully provided and played markdown with evaluated content"

  mdScenario "Filter query results with default field values" [] do
    Interact.insertMdCardInLastDeck
    Interact.provideMdInLastMdCard $ joinWith "\n\n"
      [ "discipline = __ (!``SELECT discipline FROM `/test-mount/testDb/olympics` LIMIT 1``)"
      , "year = __ (!``SELECT year FROM `/test-mount/testDb/olympics` LIMIT 1``)"
      , "country = {!``SELECT DISTINCT country FROM `/test-mount/testDb/olympics` ``} (!``SELECT country FROM `/test-mount/testDb/olympics` LIMIT 1``)"
      , "type = (!``SELECT DISTINCT type FROM `/test-mount/testDb/olympics` LIMIT 1``) !``SELECT DISTINCT type FROM `/test-mount/testDb/olympics` OFFSET 1``"
      , "gender = [!``SELECT gender FROM `/test-mount/testDb/olympics` LIMIT 1``] !``SELECT DISTINCT gender FROM `/test-mount/testDb/olympics` ``"
      ]
    Interact.runQuery
    Interact.accessNextCardInLastDeck
    Interact.insertDisplayMarkdownCardInLastDeck
    Expect.displayMarkdownCardPresented
    Interact.accessNextCardInLastDeck
    Interact.insertQueryCardInLastDeck
    Interact.provideQueryInLastQueryCard
      "SELECT * FROM `/test-mount/testDb/olympics` WHERE discipline = :discipline AND type != :type AND gender IN :gender AND year > :year AND country = :country"
    Interact.runQuery
    Interact.accessNextCardInLastDeck
    Interact.selectBuildChart
    Interact.insertPivotCard
    Interact.addColumn "discipline"
    Interact.addColumn "country"
    Interact.addColumn "gender"
    Interact.addColumn "year"
    Interact.addColumn "type"
    Interact.accessNextCardInLastDeck
    Interact.insertChartCardInLastDeck
    Expect.cardsInTableColumnInLastCardToEq 2 "discipline" "Figure skating"
    Expect.cardsInTableColumnInLastCardToEq 2 "country" "AUT"
    Expect.cardsInTableColumnInLastCardToEq 2 "gender" "W"
    Expect.cardsInTableColumnInLastCardToBeGT 2 "year" "1924"
    Expect.cardsInTableColumnInLastCardToNotEq 2 "type" "Silver"
    successMsg "Ok, Filtered query results with fields"

  mdScenario "Filter query results by changing field values" [] do
    Interact.insertMdCardInLastDeck
    Interact.provideMdInLastMdCard $ joinWith "\n\n"
      [ "discipline = __ (!``SELECT discipline FROM `/test-mount/testDb/olympics` LIMIT 1``)"
      , "year = __ (!``SELECT year FROM `/test-mount/testDb/olympics` LIMIT 1``)"
      , "country = {!``SELECT DISTINCT country FROM `/test-mount/testDb/olympics` ``} (!``SELECT country FROM `/test-mount/testDb/olympics` LIMIT 1``)"
      , "type = (!``SELECT DISTINCT type FROM `/test-mount/testDb/olympics` LIMIT 1``) !``SELECT DISTINCT type FROM `/test-mount/testDb/olympics` OFFSET 1``"
      , "gender = [!``SELECT gender FROM `/test-mount/testDb/olympics` LIMIT 1``] !``SELECT DISTINCT gender FROM `/test-mount/testDb/olympics` ``"
      ]
    Interact.runQuery
    Interact.accessNextCardInLastDeck
    Interact.insertDisplayMarkdownCardInLastDeck
    Expect.displayMarkdownCardPresented
    Interact.accessNextCardInLastDeck
    Interact.insertQueryCardInLastDeck
    Interact.provideQueryInLastQueryCard
      "SELECT * FROM `/test-mount/testDb/olympics` WHERE discipline = :discipline AND type != :type AND gender IN :gender AND year > :year AND country = :country"
    Interact.runQuery
    Interact.accessNextCardInLastDeck
    Interact.selectBuildChart
    Interact.insertPivotCard

    Interact.addColumn "discipline"
    Interact.addColumn "gender"
    Interact.addColumn "year"
    Interact.addColumn "type"
    Interact.addColumn "country"
    Interact.accessNextCardInLastDeck
    Interact.insertChartCardInLastDeck
    Interact.accessPreviousCardInLastDeck
    Interact.accessPreviousCardInLastDeck
    Interact.accessPreviousCardInLastDeck
    Interact.provideFieldValueInLastDeck "discipline" "Luge"
    Interact.provideFieldValueInLastDeck "year" "1950"
    Interact.uncheckFieldInLastDeck "W"
    Interact.checkFieldInLastDeck "X"
    Interact.checkFieldInLastDeck "M"
    Interact.pushRadioButtonInLastDeck "Gold"
    Interact.selectFromDropdownInLastDeck "country" "GDR"
    Interact.accessNextCardInLastDeck
    Interact.accessNextCardInLastDeck
    Interact.accessNextCardInLastDeck
    Expect.cardsInTableColumnInLastCardToEq 8 "discipline" "Luge"
    Expect.cardsInTableColumnInLastCardToEqOneOf 8 "gender" ["M", "X"]
    Expect.cardsInTableColumnInLastCardToBeGT 8 "year" "1950"
    Expect.cardsInTableColumnInLastCardToNotEq 8 "type" "Gold"
    successMsg "Ok, Filtered query results by changing field values"

  mdScenario "Markdown chaining" [] do
    Interact.insertMdCardInLastDeck
    Interact.provideMdInLastMdCard $
      "state = {!``select distinct state from `/test-mount/testDb/zips` order by asc``}"
      <> "(!``select state from `/test-mount/testDb/zips` limit 1 ``)"
    Interact.runQuery
    Interact.accessNextCardInLastDeck
    Interact.insertDisplayMarkdownCardInLastDeck

    Interact.accessNextCardInLastDeck
    Interact.insertMdCardInLastDeck
    Interact.provideMdInLastMdCard $
      "city = ___"
      <> "(!``select city from `/test-mount/testDb/zips` where state = :state order by asc limit 1``)"
    Interact.runQuery
    Interact.accessNextCardInLastDeck
    Interact.insertDisplayMarkdownCardInLastDeck
    Expect.fieldInLastMdCard "city" "text" "AGAWAM"
    Interact.accessPreviousCardInLastDeck
    Interact.accessPreviousCardInLastDeck
    Interact.selectFromDropdownInLastDeck "state" "RI"
    Interact.accessNextCardInLastDeck
    Interact.accessNextCardInLastDeck
    Expect.fieldInLastMdCard "city" "text" "ASHAWAY"
    successMsg "Ok, variables from md card could be used in md card"

{-
Copyright 2015 SlamData, Inc.

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

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

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

module Test.SlamData.Feature.Test.Markdown where

import Data.String (joinWith)
import Control.Apply ((*>))
import Prelude
import Test.Feature.Log (successMsg)
import Test.SlamData.Feature.Monad (SlamFeature)
import Test.SlamData.Feature.Interactions as Interact
import Test.SlamData.Feature.Expectations as Expect
import Test.Feature.Scenario (scenario)

mdScenario ∷ String → Array String → SlamFeature Unit → SlamFeature Unit
mdScenario =
  scenario
    "Markdown"
    (Interact.createWorkspaceInTestFolder "Markdown")
    (Interact.deleteFileInTestFolder "Untitled Workspace.slam"
       *> Interact.browseRootFolder)

test ∷ SlamFeature Unit
test = do
  mdScenario "Provide and play markdown" ["https://github.com/slamdata/slamdata/issues/987"] do
    Interact.insertMdCardInLastDeck
    Interact.provideMdInLastMdCard
      $ joinWith "\n\n"
          [ "discipline = __"
          , "sport = __ (Bobsleigh)"
          , "age = #__"
          , "year = #__ (2002)"
          , "startDate = __ - __ - __"
          , "finishDate = __ - __ - __ (2002-06-06)"
          , "startTime = __ : __"
          , "finishTime = __ : __ (20:39)"
          , "event = {1000m, 1500m, 3000m} (1500m)"
          , "gender = []M []W []X"
          , "color = [x]Red []Green [x]Blue"
          , "type = (x)Gold ()Silver ()Bronze"
          ]
    Interact.runQuery
    Interact.accessNextCardInLastDeck
    Interact.insertDisplayMarkdownCardInLastDeck
    Expect.fieldInLastMdCard "discipline" "text" ""
    Expect.fieldInLastMdCard "sport" "text" "Bobsleigh"
    Expect.fieldInLastMdCard "age" "number" ""
    Expect.fieldInLastMdCard "year" "number" "2002"
    Expect.fieldInLastMdCard "startDate" "date" ""
    Expect.fieldInLastMdCard "finishDate" "date" "2002-06-06"
    Expect.fieldInLastMdCard "startTime" "time" ""
    Expect.fieldInLastMdCard "finishTime" "time" "20:39"
    Expect.labelInLastMdCard "event"
    Expect.dropdownInLastMdCard "1500m" ["1000m", "1500m", "3000m"]
    Expect.labelInLastMdCard "gender"
    Expect.checkableFieldInLastMdCard "X" "checkbox" false
    Expect.checkableFieldInLastMdCard "W" "checkbox" false
    Expect.checkableFieldInLastMdCard "M" "checkbox" false
    Expect.labelInLastMdCard "color"
    Expect.checkableFieldInLastMdCard "Red" "checkbox" true
    Expect.checkableFieldInLastMdCard "Green" "checkbox" false
    Expect.checkableFieldInLastMdCard "Blue" "checkbox" true
    Expect.labelInLastMdCard "type"
    Expect.checkableFieldInLastMdCard "Gold" "radio" true
    Expect.checkableFieldInLastMdCard "Silver" "radio" false
    Expect.checkableFieldInLastMdCard "Bronze" "radio" false

    successMsg "Ok, succesfully provided and played markdown."

  mdScenario "Change and play markdown" [] do
    Interact.insertMdCardInLastDeck
    Interact.provideMdInLastMdCard "discipline = __"
    Interact.runQuery
    Interact.accessNextCardInLastDeck
    Interact.insertDisplayMarkdownCardInLastDeck
    Interact.accessPreviousCardInLastDeck
    Interact.provideMdInLastMdCard "sport =  __ (Bobsleigh)"
    Interact.runQuery
    Interact.accessNextCardInLastDeck

    Expect.fieldInLastMdCard "sport" "text" "Bobsleigh"
    successMsg "Ok, successfully changed and played markdown."

  mdScenario "Provide and play markdown with evaluated content" [] do
    Interact.insertMdCardInLastDeck
    Interact.provideMdInLastMdCard $ joinWith "\n\n"
      [ "discipline = __ (!``SELECT discipline FROM `/test-mount/testDb/olympics` LIMIT 1``)"
      , "year = __ (!``SELECT year FROM `/test-mount/testDb/olympics` LIMIT 1``)"
      , "country = {!``SELECT DISTINCT country FROM `/test-mount/testDb/olympics` ``} (!``SELECT country FROM `/test-mount/testDb/olympics` LIMIT 1``)"
      , "type = (!``SELECT DISTINCT type FROM `/test-mount/testDb/olympics` LIMIT 1``) !``SELECT DISTINCT type FROM `/test-mount/testDb/olympics` OFFSET 1``"
      , "gender = [!``SELECT gender FROM `/test-mount/testDb/olympics` LIMIT 1``] !``SELECT DISTINCT gender FROM `/test-mount/testDb/olympics` ``"
      ]
    Interact.runQuery
    Interact.accessNextCardInLastDeck
    Interact.insertDisplayMarkdownCardInLastDeck
    Expect.fieldInLastMdCard "discipline" "text" "Figure skating"
    Expect.fieldInLastMdCard "year" "text" "1924"
    Expect.labelInLastMdCard "country"
    Expect.dropdownInLastMdCard "AUT"
      [ "LAT"
      , "CZE"
      , "UKR"
      , "SLO"
      , "RUS"
      , "SVK"
      , "KAZ"
      , "AUS"
      , "LUX"
      , "UZB"
      , "EUN"
      , "DEN"
      , "CHN"
      , "ROU"
      , "GDR"
      , "PRK"
      , "CRO"
      , "URS"
      , "BLR"
      , "BUL"
      , "POL"
      , "EUA"
      , "KOR"
      , "NED"
      , "ITA"
      , "FRG"
      , "EST"
      , "SWE"
      , "GBR"
      , "TCH"
      , "BEL"
      , "FIN"
      , "USA"
      , "YUG"
      , "SUI"
      , "LIE"
      , "CAN"
      , "JPN"
      , "HUN"
      , "GER"
      , "NOR"
      , "NZL"
      , "FRA"
      , "AUT"
      , "ESP"
      ]
    Expect.labelInLastMdCard "gender"
    Expect.checkableFieldInLastMdCard "X" "checkbox" false
    Expect.checkableFieldInLastMdCard "W" "checkbox" true
    Expect.checkableFieldInLastMdCard "M" "checkbox" false
    Expect.labelInLastMdCard "type"
    Expect.checkableFieldInLastMdCard "Gold" "radio" false
    Expect.checkableFieldInLastMdCard "Silver" "radio" true
    Expect.checkableFieldInLastMdCard "Bronze" "radio" false
    successMsg "Ok, successfully provided and played markdown with evaluated content"

  mdScenario "Filter query results with default field values" [] do
    Interact.insertMdCardInLastDeck
    Interact.provideMdInLastMdCard $ joinWith "\n\n"
      [ "discipline = __ (!``SELECT discipline FROM `/test-mount/testDb/olympics` LIMIT 1``)"
      , "year = __ (!``SELECT year FROM `/test-mount/testDb/olympics` LIMIT 1``)"
      , "country = {!``SELECT DISTINCT country FROM `/test-mount/testDb/olympics` ``} (!``SELECT country FROM `/test-mount/testDb/olympics` LIMIT 1``)"
      , "type = (!``SELECT DISTINCT type FROM `/test-mount/testDb/olympics` LIMIT 1``) !``SELECT DISTINCT type FROM `/test-mount/testDb/olympics` OFFSET 1``"
      , "gender = [!``SELECT gender FROM `/test-mount/testDb/olympics` LIMIT 1``] !``SELECT DISTINCT gender FROM `/test-mount/testDb/olympics` ``"
      ]
    Interact.runQuery
    Interact.accessNextCardInLastDeck
    Interact.insertDisplayMarkdownCardInLastDeck
    Expect.displayMarkdownCardPresented
    Interact.accessNextCardInLastDeck
    Interact.insertQueryCardInLastDeck
    Interact.provideQueryInLastQueryCard
      "SELECT * FROM `/test-mount/testDb/olympics` WHERE discipline = :discipline AND type != :type AND gender IN :gender[_] AND year > :year AND country = :country"
    Interact.runQuery
    Interact.accessNextCardInLastDeck
    Interact.selectBuildChart
    Interact.insertPivotCard
    Interact.addColumn "discipline"
    Interact.addColumn "country"
    Interact.addColumn "gender"
    Interact.addColumn "year"
    Interact.addColumn "type"
    Interact.accessNextCardInLastDeck
    Interact.insertChartCardInLastDeck
    Expect.cardsInTableColumnInLastCardToEq 2 "discipline" "Figure skating"
    Expect.cardsInTableColumnInLastCardToEq 2 "country" "AUT"
    Expect.cardsInTableColumnInLastCardToEq 2 "gender" "W"
    Expect.cardsInTableColumnInLastCardToBeGT 2 "year" "1924"
    Expect.cardsInTableColumnInLastCardToNotEq 2 "type" "Silver"
    successMsg "Ok, Filtered query results with fields"

  mdScenario "Filter query results by changing field values" [] do
    Interact.insertMdCardInLastDeck
    Interact.provideMdInLastMdCard $ joinWith "\n\n"
      [ "discipline = __ (!``SELECT discipline FROM `/test-mount/testDb/olympics` LIMIT 1``)"
      , "year = __ (!``SELECT year FROM `/test-mount/testDb/olympics` LIMIT 1``)"
      , "country = {!``SELECT DISTINCT country FROM `/test-mount/testDb/olympics` ``} (!``SELECT country FROM `/test-mount/testDb/olympics` LIMIT 1``)"
      , "type = (!``SELECT DISTINCT type FROM `/test-mount/testDb/olympics` LIMIT 1``) !``SELECT DISTINCT type FROM `/test-mount/testDb/olympics` OFFSET 1``"
      , "gender = [!``SELECT gender FROM `/test-mount/testDb/olympics` LIMIT 1``] !``SELECT DISTINCT gender FROM `/test-mount/testDb/olympics` ``"
      ]
    Interact.runQuery
    Interact.accessNextCardInLastDeck
    Interact.insertDisplayMarkdownCardInLastDeck
    Expect.displayMarkdownCardPresented
    Interact.accessNextCardInLastDeck
    Interact.insertQueryCardInLastDeck
    Interact.provideQueryInLastQueryCard
      "SELECT * FROM `/test-mount/testDb/olympics` WHERE discipline = :discipline AND type != :type AND gender IN :gender[_] AND year > :year AND country = :country"
    Interact.runQuery
    Interact.accessNextCardInLastDeck
    Interact.selectBuildChart
    Interact.insertPivotCard

    Interact.addColumn "discipline"
    Interact.addColumn "gender"
    Interact.addColumn "year"
    Interact.addColumn "type"
    Interact.addColumn "country"
    Interact.accessNextCardInLastDeck
    Interact.insertChartCardInLastDeck
    Interact.accessPreviousCardInLastDeck
    Interact.accessPreviousCardInLastDeck
    Interact.accessPreviousCardInLastDeck
    Interact.provideFieldValueInLastDeck "discipline" "Luge"
    Interact.provideFieldValueInLastDeck "year" "1950"
    Interact.uncheckFieldInLastDeck "W"
    Interact.checkFieldInLastDeck "X"
    Interact.checkFieldInLastDeck "M"
    Interact.pushRadioButtonInLastDeck "Gold"
    Interact.selectFromDropdownInLastDeck "country" "GDR"
    Interact.accessNextCardInLastDeck
    Interact.accessNextCardInLastDeck
    Interact.accessNextCardInLastDeck
    Expect.cardsInTableColumnInLastCardToEq 8 "discipline" "Luge"
    Expect.cardsInTableColumnInLastCardToEqOneOf 8 "gender" ["M", "X"]
    Expect.cardsInTableColumnInLastCardToBeGT 8 "year" "1950"
    Expect.cardsInTableColumnInLastCardToNotEq 8 "type" "Gold"
    successMsg "Ok, Filtered query results by changing field values"

  mdScenario "Markdown chaining" [] do
    Interact.insertMdCardInLastDeck
    Interact.provideMdInLastMdCard $
      "state = {!``select distinct state from `/test-mount/testDb/zips` order by asc``}"
      <> "(!``select state from `/test-mount/testDb/zips` limit 1 ``)"
    Interact.runQuery
    Interact.accessNextCardInLastDeck
    Interact.insertDisplayMarkdownCardInLastDeck

    Interact.accessNextCardInLastDeck
    Interact.insertMdCardInLastDeck
    Interact.provideMdInLastMdCard $
      "city = ___"
      <> "(!``select city from `/test-mount/testDb/zips` where state = :state order by asc limit 1``)"
    Interact.runQuery
    Interact.accessNextCardInLastDeck
    Interact.insertDisplayMarkdownCardInLastDeck
    Expect.fieldInLastMdCard "city" "text" "AGAWAM"
    Interact.accessPreviousCardInLastDeck
    Interact.accessPreviousCardInLastDeck
    Interact.selectFromDropdownInLastDeck "state" "RI"
    Interact.accessNextCardInLastDeck
    Interact.accessNextCardInLastDeck
    Expect.fieldInLastMdCard "city" "text" "ASHAWAY"
    successMsg "Ok, variables from md card could be used in md card"


Update

Update

module Main where

import Prelude
import Math as Math
import Data.Array
import Data.Foldable
import Data.Maybe
import Control.Monad.Eff (Eff, forE)
import Control.Monad.Eff.Console (logShow, log)
import DOM
import Graphics.Canvas
import Signal
import Signal.DOM
--import Data.List
import Partial.Unsafe (unsafePartial)

oRate :: Number
oRate = 0.999

fric :: Number
fric = 0.0

vertices :: Array Point3D
vertices = [
    Point3D (-100.0) 100.0 (-100.0)
    ,Point3D 100.0 100.0 (-100.0)
    ,Point3D 100.0 (-100.0) (-100.0)
    ,Point3D (-100.0) (-100.0) (-100.0)
    ,Point3D (-100.0) 100.0 100.0
    ,Point3D 100.0 100.0 100.0
    ,Point3D 100.0 (-100.0) 100.0
    ,Point3D (-100.0) (-100.0) 100.0
]

data Point3D = Point3D Number Number Number

data Angle3D = Angle3D
    {qx :: Number
    ,qy :: Number
    ,qz :: Number
    }

angle :: Angle3D
angle = Angle3D
    {qx: Math.pi/4.0
    ,qy: Math.pi/3.0
    ,qz: Math.pi/4.0
    }

data Face = Face Point3D Point3D Point3D Point3D

faces :: Array (Array Int)
faces = [
    [0,1,2,3],
    [1,5,6,2],
    [5,4,7,6],
    [4,0,3,7],
    [0,4,5,1],
    [3,2,6,7]
]

project3Dto2D :: Point3D -> Angle3D -> Point3D
project3Dto2D (Point3D x y z) (Angle3D ang) =
    let xRotQz = x * Math.cos ang.qz + y * Math.sin ang.qz
        yRotQz = y * Math.cos ang.qz + x * Math.sin ang.qz
        zRotQz = z
        xRotQzQx = xRotQz
        yRotQzQx = yRotQz * Math.cos ang.qx + zRotQz * Math.sin ang.qx
        zRotQzQx = zRotQz * Math.cos ang.qx - yRotQz * Math.sin ang.qx
        xRotQzQxQy = xRotQzQx * Math.cos ang.qy + zRotQzQx * Math.sin ang.qy
        yRotQzQxQy = yRotQzQx
    in
        (Point3D xRotQzQxQy yRotQzQxQy zRotQz)

projectAll3Dto2D :: (Array Point3D) -> Angle3D -> (Array Point3D)
projectAll3Dto2D vert3D ang =
    let
        vert2D = map (\v -> project3Dto2D v ang ) vert3D
    in
        vert2D

defVal1 :: Maybe Number -> Number
defVal1 val = fromMaybe 0.0 val

{-
defVal :: Maybe Point3D -> Point3D
defVal (Point3D x y z) =
    let
        dx = fromMaybe 0.0 x
        dy = fromMaybe 0.0 y
        dz = fromMaybe 0.0 z
    in
        (Point3D dx dy dz)
-}

drawFace :: forall e. Context2D -> Face -> Eff (canvas :: CANVAS | e) Unit
drawFace ctx (Face v1 v2 v3 v4) = strokePath ctx do
        ctx <- setStrokeStyle "#000000" ctx
        ctx <- moveTo ctx x1 y1
        ctx <- lineTo ctx x2 y2
        ctx <- lineTo ctx x3 y3
        ctx <- lineTo ctx x4 y4
        void $ closePath ctx
    where
        Point3D x1 y1 z1 = v1
        Point3D x2 y2 z2 = v2
        Point3D x3 y3 z3 = v3
        Point3D x4 y4 z4 = v4

drawCube :: forall e. Context2D -> (Array Point3D) -> Eff (canvas :: CANVAS | e) Unit
drawCube ctx vert3D = strokePath ctx do
    for_ faces $ \face -> do
        {-
        fv <- []
        for_ face $ \v -> do
            cons (vert2D !! v) fv
        -}
        v1 <- vert2D !! (fromMaybe 0 (face !! 0))
        v2 <- vert2D !! (fromMaybe 0 (face !! 1))
        v3 <- vert2D !! (fromMaybe 0 (face !! 2))
        v4 <- vert2D !! (fromMaybe 0 (face !! 3))
        vd1 <- fromMaybe (Point3D 0.0 0.0 0.0) v1
        vd2 <- fromMaybe (Point3D 0.0 0.0 0.0) v2
        vd3 <- fromMaybe (Point3D 0.0 0.0 0.0) v3
        vd4 <- fromMaybe (Point3D 0.0 0.0 0.0) v4
        drawFace ctx (Face vd1 vd2 vd3 vd4)
    where
        vert2D = projectAll3Dto2D vert3D angle

transform :: Point3D -> Point3D
transform (Point3D x y z) =
    let nx = x + 200.0
        ny = x + 200.0
    in
        (Point3D nx ny z)

--main :: forall eff. Eff(canvas :: CANVAS, dom :: DOM, console :: CONSOLE, timer :: TIMER | eff) Unit
main = void $ unsafePartial do
    Just canvas <- getCanvasElementById "thecanvas"
    ctx <- getContext2D canvas
    animFrame <- animationFrame
    ctx <- setFillStyle "#0000FF" ctx
    --ctx <- fillRect{x: 0.0, y: 0.0, w: 500.0, h: 500.0} ctx
    drawCube ctx vertices
    --log("working")

module Main where

import Prelude
import Math as Math
import Data.Array
import Data.Foldable
import Data.Maybe
import Control.Monad.Eff (Eff, forE)
import Control.Monad.Eff.Console (logShow, log)
import DOM
import Graphics.Canvas
import Signal
import Signal.DOM
--import Data.List
import Partial.Unsafe (unsafePartial)

oRate :: Number
oRate = 0.999

fric :: Number
fric = 0.0

vertices :: Array Point3D
vertices = [
    Point3D (-100.0) 100.0 (-100.0)
    ,Point3D 100.0 100.0 (-100.0)
    ,Point3D 100.0 (-100.0) (-100.0)
    ,Point3D (-100.0) (-100.0) (-100.0)
    ,Point3D (-100.0) 100.0 100.0
    ,Point3D 100.0 100.0 100.0
    ,Point3D 100.0 (-100.0) 100.0
    ,Point3D (-100.0) (-100.0) 100.0
]

data Point3D = Point3D Number Number Number

data Angle3D = Angle3D
    {qx :: Number
    ,qy :: Number
    ,qz :: Number
    }

angle :: Angle3D
angle = Angle3D
    {qx: Math.pi/4.0
    ,qy: Math.pi/3.0
    ,qz: Math.pi/4.0
    }

data Face = Face Point3D Point3D Point3D Point3D

faces :: Array (Array Int)
faces = [
    [0,1,2,3],
    [1,5,6,2],
    [5,4,7,6],
    [4,0,3,7],
    [0,4,5,1],
    [3,2,6,7]
]

project3Dto2D :: Point3D -> Angle3D -> Point3D
project3Dto2D (Point3D x y z) (Angle3D ang) =
    let xRotQz = x * Math.cos ang.qz + y * Math.sin ang.qz
        yRotQz = y * Math.cos ang.qz + x * Math.sin ang.qz
        zRotQz = z
        xRotQzQx = xRotQz
        yRotQzQx = yRotQz * Math.cos ang.qx + zRotQz * Math.sin ang.qx
        zRotQzQx = zRotQz * Math.cos ang.qx - yRotQz * Math.sin ang.qx
        xRotQzQxQy = xRotQzQx * Math.cos ang.qy + zRotQzQx * Math.sin ang.qy
        yRotQzQxQy = yRotQzQx
    in
        (Point3D xRotQzQxQy yRotQzQxQy zRotQz)

projectAll3Dto2D :: (Array Point3D) -> Angle3D -> (Array Point3D)
projectAll3Dto2D vert3D ang =
    let
        vert2D = map (\v -> project3Dto2D v ang ) vert3D
    in
        vert2D

defVal1 :: Maybe Number -> Number
defVal1 val = fromMaybe 0.0 val

{-
defVal :: Maybe Point3D -> Point3D
defVal (Point3D x y z) =
    let
        dx = fromMaybe 0.0 x
        dy = fromMaybe 0.0 y
        dz = fromMaybe 0.0 z
    in
        (Point3D dx dy dz)
-}

drawFace :: forall e. Context2D -> Face -> Eff (canvas :: CANVAS | e) Unit
drawFace ctx (Face v1 v2 v3 v4) = strokePath ctx do
        ctx <- setStrokeStyle "#000000" ctx
        ctx <- moveTo ctx x1 y1
        ctx <- lineTo ctx x2 y2
        ctx <- lineTo ctx x3 y3
        ctx <- lineTo ctx x4 y4
        void $ closePath ctx
    where
        Point3D x1 y1 z1 = v1
        Point3D x2 y2 z2 = v2
        Point3D x3 y3 z3 = v3
        Point3D x4 y4 z4 = v4

drawCube :: forall e. Context2D -> (Array Point3D) -> Eff (canvas :: CANVAS | e) Unit
drawCube ctx vert3D = strokePath ctx do
    for_ faces $ \face -> do
        v1 <- vert2D !! (fromMaybe 0 (face !! 0))
        v2 <- vert2D !! (fromMaybe 0 (face !! 1))
        v3 <- vert2D !! (fromMaybe 0 (face !! 2))
        v4 <- vert2D !! (fromMaybe 0 (face !! 3))
        v1 <- fromMaybe (Point3D 0.0 0.0 0.0) v1
        v2 <- fromMaybe (Point3D 0.0 0.0 0.0) v2
        v3 <- fromMaybe (Point3D 0.0 0.0 0.0) v3
        v4 <- fromMaybe (Point3D 0.0 0.0 0.0) v4
        drawFace ctx (Face v1 v2 v3 v4)
    where
        vert2D = projectAll3Dto2D vert3D angle

transform :: Point3D -> Point3D
transform (Point3D x y z) =
    let nx = x + 200.0
        ny = x + 200.0
    in
        (Point3D nx ny z)

--main :: forall eff. Eff(canvas :: CANVAS, dom :: DOM, console :: CONSOLE, timer :: TIMER | eff) Unit
main = void $ unsafePartial do
    Just canvas <- getCanvasElementById "thecanvas"
    ctx <- getContext2D canvas
    animFrame <- animationFrame
    ctx <- setFillStyle "#0000FF" ctx
    --ctx <- fillRect{x: 0.0, y: 0.0, w: 500.0, h: 500.0} ctx
    drawCube ctx vertices
    --log("working")