Derive typeclasses

Derive typeclasses

Original commit c21122aaeaef1d534e921ff8d70123328ef97354

module IR where

import Control.Monad.State
import Control.Monad.State.Class
import Prelude

import Data.Either (Either(..), isLeft)
import Data.Foldable (find, all, any, for_, foldM)
import Data.List (List(..), concatMap, length, mapWithIndex, singleton, (:))
import Data.List as L
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe(..), fromJust)
import Data.Set (Set, empty, fromFoldable)
import Data.Set as S
import Data.Tuple (Tuple(..))
import Data.Tuple as T
import Partial.Unsafe (unsafePartial)

newtype IRGraph = IRGraph { classes :: List (Either IRClassData Int) }

newtype IRClassData = IRClassData { names :: Set String, properties :: Map String IRType }

data IRType
    = IRNothing
    | IRNull
    | IRInteger
    | IRDouble
    | IRBool
    | IRString
    | IRArray IRType
    | IRClass Int
    | IRUnion (Set IRType)

derive instance eqIRType :: Eq IRType
derive instance ordIRType :: Ord IRType

makeClass :: String -> Map String IRType -> IRClassData
makeClass name properties =
    IRClassData { names: S.singleton name, properties }

emptyGraph :: IRGraph
emptyGraph = IRGraph { classes: L.Nil }

addClassWithIndex :: IRClassData -> State IRGraph (Tuple Int IRType)
addClassWithIndex classData =
    do
        IRGraph { classes } <- get
        let index = L.length classes
        put (IRGraph { classes: (L.snoc classes (Left classData)) })
        pure $ Tuple index (IRClass index)

addClass :: IRClassData -> State IRGraph IRType
addClass classData =
    do
        Tuple _ t <- addClassWithIndex classData
        pure t

redirectClass :: Int -> Int -> State IRGraph Unit
redirectClass from to =
    do
        (IRGraph { classes: c1 }) <- get
        let c2 = unsafePartial $ fromJust $ L.updateAt from (Right to) c1
        put (IRGraph { classes: c2 })

getClassFromGraph :: IRGraph -> Int -> IRClassData
getClassFromGraph graph@(IRGraph { classes }) index =
    case unsafePartial $ fromJust $ L.index classes index of
    Left cd -> cd
    Right i -> getClassFromGraph graph i

getClass :: Int -> State IRGraph IRClassData
getClass index =
    do
        graph <- get
        pure $ getClassFromGraph graph index

combineClasses :: Int -> Int -> IRClassData -> State IRGraph IRType
combineClasses ia ib combined =
    do
        IRGraph { classes } <- get
        let newIndex = L.length classes
        t <- addClass combined
        redirectClass ia newIndex
        redirectClass ib newIndex
        pure t

mapClasses :: forall a. (Int -> IRClassData -> a) -> IRGraph -> List a
mapClasses f (IRGraph { classes }) =
    L.concat $ L.mapWithIndex mapper classes
    where
        mapper i e =
            case e of
            Left cd -> L.singleton $ f i cd
            Right _ -> L.Nil

classesInGraph :: IRGraph -> List IRClassData
classesInGraph  =
    mapClasses (\i cd -> cd)

lookupOrDefault :: forall k v. Ord k => v -> k -> Map k v -> v
lookupOrDefault default key m =
    case M.lookup key m of
    Nothing -> default
    Just x -> x

removeElement :: forall a. Ord a => (a -> Boolean) -> S.Set a -> { element :: Maybe a, rest :: S.Set a }
removeElement p s =
    let element = (find p s)
    in
        case element of
            Just x -> { element: element, rest: S.delete x s }
            Nothing -> { element: element, rest: s }

mapM :: forall a b. (a -> State IRGraph b) -> List a -> State IRGraph (List b)
mapM _ L.Nil = pure L.Nil
mapM f (x : xs) =
    do
        ys <- mapM f xs
        y <- f x
        pure $ y : ys

-- FIXME: this is ugly and inefficient
unionWithDefault :: forall k v. Ord k => (v -> v -> State IRGraph v) -> v -> Map k v -> Map k v -> State IRGraph (Map k v)
unionWithDefault unifier default m1 m2 =
    let allKeys = L.fromFoldable $ S.union (S.fromFoldable $ M.keys m1) (S.fromFoldable $ M.keys m2)
        valueFor k = unifier (lookupOrDefault default k m1) (lookupOrDefault default k m2)
        keyMapper k =
            do
                v <- valueFor k
                pure $ Tuple k v
    in
        do
            kvps <- mapM keyMapper allKeys
            pure $ M.fromFoldable kvps

isArray :: IRType -> Boolean
isArray (IRArray _) = true
isArray _ = false

isClass :: IRType -> Boolean
isClass (IRClass _) = true
isClass _ = false

decomposeTypeSet :: S.Set IRType -> { maybeArray :: Maybe IRType, maybeClass :: Maybe IRType, rest :: S.Set IRType }
decomposeTypeSet s =
    let { element: maybeArray, rest: rest } = removeElement isArray s
        { element: maybeClass, rest: rest } = removeElement isClass rest
    in
        { maybeArray, maybeClass, rest }

setFromType :: IRType -> S.Set IRType
setFromType IRNothing = S.empty
setFromType x = S.singleton x

zeroClass :: IRClassData
zeroClass = IRClassData { names: S.empty, properties: M.empty }

unifyClasses :: IRClassData -> IRClassData -> State IRGraph IRClassData
unifyClasses (IRClassData { names: na, properties: pa }) (IRClassData { names: nb, properties: pb }) =
    do
        properties <- unionWithDefault unifyTypesWithNull IRNothing pa pb
        pure $ IRClassData { names: (S.union na nb), properties: properties }

unifyMaybes :: Maybe IRType -> Maybe IRType -> State IRGraph IRType
unifyMaybes Nothing Nothing = pure IRNothing
unifyMaybes (Just a) Nothing = pure a
unifyMaybes Nothing (Just b) = pure b
unifyMaybes (Just a) (Just b) = unifyTypes a b

unifyUnion :: S.Set IRType -> S.Set IRType -> State IRGraph (S.Set IRType)
unifyUnion sa sb =
    do
        let { maybeArray: arrayA, maybeClass: classA, rest: sa } = decomposeTypeSet sa
        let { maybeArray: arrayB, maybeClass: classB, rest: sb } = decomposeTypeSet sb
        unifiedArray <- unifyMaybes arrayA arrayB
        unifiedClasses <- unifyMaybes classA classB
        pure $ S.unions [sa, sb, setFromType unifiedArray, setFromType unifiedClasses]

unifyTypes :: IRType -> IRType -> State IRGraph IRType
unifyTypes IRNothing x = pure x
unifyTypes x IRNothing = pure x
unifyTypes (IRArray a) (IRArray b) =
    do
        unified <- unifyTypes a b
        pure $ IRArray unified
unifyTypes (IRClass ia) (IRClass ib) =
    do
        a <- getClass ia
        b <- getClass ib
        unified <- unifyClasses a b
        combineClasses ia ib unified
unifyTypes (IRUnion a) (IRUnion b) =
    do
        unified <- unifyUnion a b
        pure $ IRUnion unified
unifyTypes (IRUnion a) b =
    do
        unified <- unifyUnion a (S.singleton b)
        pure $ IRUnion unified
unifyTypes a (IRUnion b) =
    do
        unified <- unifyUnion (S.singleton a) b
        pure $ IRUnion unified
unifyTypes a b =
    do
        pure $ if a == b then a else IRUnion (S.fromFoldable [a, b])

nullifyNothing :: IRType -> IRType
nullifyNothing IRNothing = IRNull
nullifyNothing x = x

unifyTypesWithNull :: IRType -> IRType -> State IRGraph IRType
unifyTypesWithNull IRNothing IRNothing = pure IRNothing
unifyTypesWithNull a b = unifyTypes (nullifyNothing a) (nullifyNothing b)

matchingProperties :: forall v. Eq v => Map String v -> Map String v -> Map String v
matchingProperties ma mb =
    M.fromFoldable (L.concatMap getFromB (M.toUnfoldable ma))
    where
        getFromB (Tuple k va) =
            case M.lookup k mb of
            Just vb -> if va == vb then Tuple k vb : L.Nil else L.Nil
            Nothing -> L.Nil

propertiesSimilar :: forall v. Eq v => Map String v -> Map String v -> Boolean
propertiesSimilar pa pb =
    let aInB = M.size $ matchingProperties pa pb
        bInA = M.size $ matchingProperties pb pa
    in
        (aInB * 4 >= (M.size pa) * 3) && (bInA * 4 >= (M.size pb) * 3)

isMaybeSubtypeOfMaybe :: IRGraph -> Maybe IRType -> Maybe IRType -> Boolean
isMaybeSubtypeOfMaybe _ Nothing Nothing = true
isMaybeSubtypeOfMaybe graph (Just a) (Just b) = isSubtypeOf graph a b
isMaybeSubtypeOfMaybe _ _ _ = false

isSubtypeOf :: IRGraph ->  IRType -> IRType -> Boolean
isSubtypeOf _ IRNothing _ = true
isSubtypeOf graph (IRUnion sa) (IRUnion sb) =
    all (\ta -> any (isSubtypeOf graph ta) sb) sa
isSubtypeOf graph (IRArray a) (IRArray b) =
    isSubtypeOf graph a b
isSubtypeOf graph (IRClass ia) (IRClass ib) =
    let IRClassData { names: _, properties: pa } = getClassFromGraph graph ia
        IRClassData { names: _, properties: pb } = getClassFromGraph graph ib
    in
        propertiesAreSubset graph pa pb
isSubtypeOf _ a b = a == b

propertiesAreSubset :: IRGraph -> Map String IRType -> Map String IRType -> Boolean
propertiesAreSubset graph ma mb =
    all isInB (M.toUnfoldable ma :: List _)
    where
        isInB (Tuple n ta) =
            case M.lookup n mb of
            Nothing -> false
            Just tb -> isSubtypeOf graph ta tb

classesSimilar :: IRGraph -> IRClassData -> IRClassData -> Boolean
classesSimilar graph (IRClassData { names: _, properties: pa }) (IRClassData { names: _, properties: pb }) =
    propertiesSimilar pa pb --||
    --propertiesAreSubset graph pa pb ||
    --propertiesAreSubset graph pb pa

similarClasses :: IRGraph -> Set (Set Int)
similarClasses graph@(IRGraph { classes }) =
    accumulate (mapClasses Tuple graph)
    where
        accumulate :: List (Tuple Int IRClassData) -> Set (Set Int)
        accumulate L.Nil = S.empty
        accumulate ((Tuple i thisClass) : rest) =
            let { yes: similar, no: others } = L.partition (isSimilar thisClass) rest
                recursiveResult = accumulate others
            in
                if L.length similar == 0 then
                    recursiveResult
                else
                    let similarSet = S.fromFoldable (i : (map T.fst similar))
                    in
                        S.insert similarSet recursiveResult
        isSimilar cd1 (Tuple _ cd2) =
            classesSimilar graph cd1 cd2

unifySetOfClasses :: Set Int -> (State IRGraph Unit)
unifySetOfClasses indexes =
    do
        combined <- foldM folder zeroClass indexes
        Tuple newIndex _ <- addClassWithIndex combined
        for_ indexes \i -> do
            redirectClass i newIndex
    where
        folder cd1 i2 =
            do
                cd2 <- getClass i2
                unifyClasses cd1 cd2

replaceSimilarClasses :: State IRGraph Unit
replaceSimilarClasses =
    do
        graph <- get
        let similar = similarClasses graph
        for_ similar unifySetOfClasses

combineNames :: S.Set String -> String
combineNames s =
    case L.fromFoldable s of
    L.Nil -> "NONAME"
    n : _ -> n

module IR where

import Control.Monad.State
import Control.Monad.State.Class
import Prelude

import Data.Either (Either(..), isLeft)
import Data.Foldable (find, all, any, for_, foldM)
import Data.List (List(..), concatMap, length, mapWithIndex, singleton, (:))
import Data.List as L
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe(..), fromJust)
import Data.Set (Set, empty, fromFoldable)
import Data.Set as S
import Data.Tuple (Tuple(..))
import Data.Tuple as T
import Partial.Unsafe (unsafePartial)

newtype IRGraph = IRGraph { classes :: List (Either IRClassData Int) }

newtype IRClassData = IRClassData { names :: Set String, properties :: Map String IRType }

makeClass :: String -> Map String IRType -> IRClassData
makeClass name properties =
    IRClassData { names: S.singleton name, properties }

emptyGraph :: IRGraph
emptyGraph = IRGraph { classes: L.Nil }

addClassWithIndex :: IRClassData -> State IRGraph (Tuple Int IRType)
addClassWithIndex classData =
    do
        IRGraph { classes } <- get
        let index = L.length classes
        put (IRGraph { classes: (L.snoc classes (Left classData)) })
        pure $ Tuple index (IRClass index)

addClass :: IRClassData -> State IRGraph IRType
addClass classData =
    do
        Tuple _ t <- addClassWithIndex classData
        pure t

redirectClass :: Int -> Int -> State IRGraph Unit
redirectClass from to =
    do
        (IRGraph { classes: c1 }) <- get
        let c2 = unsafePartial $ fromJust $ L.updateAt from (Right to) c1
        put (IRGraph { classes: c2 })

getClassFromGraph :: IRGraph -> Int -> IRClassData
getClassFromGraph graph@(IRGraph { classes }) index =
    case unsafePartial $ fromJust $ L.index classes index of
    Left cd -> cd
    Right i -> getClassFromGraph graph i

getClass :: Int -> State IRGraph IRClassData
getClass index =
    do
        graph <- get
        pure $ getClassFromGraph graph index

combineClasses :: Int -> Int -> IRClassData -> State IRGraph IRType
combineClasses ia ib combined =
    do
        IRGraph { classes } <- get
        let newIndex = L.length classes
        t <- addClass combined
        redirectClass ia newIndex
        redirectClass ib newIndex
        pure t

mapClasses :: forall a. (Int -> IRClassData -> a) -> IRGraph -> List a
mapClasses f (IRGraph { classes }) =
    L.concat $ L.mapWithIndex mapper classes
    where
        mapper i e =
            case e of
            Left cd -> L.singleton $ f i cd
            Right _ -> L.Nil

classesInGraph :: IRGraph -> List IRClassData
classesInGraph  =
    mapClasses (\i cd -> cd)

data IRType
    = IRNothing
    | IRNull
    | IRInteger
    | IRDouble
    | IRBool
    | IRString
    | IRArray IRType
    | IRClass Int
    | IRUnion (Set IRType)

lookupOrDefault :: forall k v. Ord k => v -> k -> Map k v -> v
lookupOrDefault default key m =
    case M.lookup key m of
    Nothing -> default
    Just x -> x

removeElement :: forall a. Ord a => (a -> Boolean) -> S.Set a -> { element :: Maybe a, rest :: S.Set a }
removeElement p s =
    let element = (find p s)
    in
        case element of
            Just x -> { element: element, rest: S.delete x s }
            Nothing -> { element: element, rest: s }

mapM :: forall a b. (a -> State IRGraph b) -> List a -> State IRGraph (List b)
mapM _ L.Nil = pure L.Nil
mapM f (x : xs) =
    do
        ys <- mapM f xs
        y <- f x
        pure $ y : ys

-- FIXME: this is ugly and inefficient
unionWithDefault :: forall k v. Ord k => (v -> v -> State IRGraph v) -> v -> Map k v -> Map k v -> State IRGraph (Map k v)
unionWithDefault unifier default m1 m2 =
    let allKeys = L.fromFoldable $ S.union (S.fromFoldable $ M.keys m1) (S.fromFoldable $ M.keys m2)
        valueFor k = unifier (lookupOrDefault default k m1) (lookupOrDefault default k m2)
        keyMapper k =
            do
                v <- valueFor k
                pure $ Tuple k v
    in
        do
            kvps <- mapM keyMapper allKeys
            pure $ M.fromFoldable kvps

isArray :: IRType -> Boolean
isArray (IRArray _) = true
isArray _ = false

isClass :: IRType -> Boolean
isClass (IRClass _) = true
isClass _ = false

decomposeTypeSet :: S.Set IRType -> { maybeArray :: Maybe IRType, maybeClass :: Maybe IRType, rest :: S.Set IRType }
decomposeTypeSet s =
    let { element: maybeArray, rest: rest } = removeElement isArray s
        { element: maybeClass, rest: rest } = removeElement isClass rest
    in
        { maybeArray, maybeClass, rest }

setFromType :: IRType -> S.Set IRType
setFromType IRNothing = S.empty
setFromType x = S.singleton x

zeroClass :: IRClassData
zeroClass = IRClassData { names: S.empty, properties: M.empty }

unifyClasses :: IRClassData -> IRClassData -> State IRGraph IRClassData
unifyClasses (IRClassData { names: na, properties: pa }) (IRClassData { names: nb, properties: pb }) =
    do
        properties <- unionWithDefault unifyTypesWithNull IRNothing pa pb
        pure $ IRClassData { names: (S.union na nb), properties: properties }

unifyMaybes :: Maybe IRType -> Maybe IRType -> State IRGraph IRType
unifyMaybes Nothing Nothing = pure IRNothing
unifyMaybes (Just a) Nothing = pure a
unifyMaybes Nothing (Just b) = pure b
unifyMaybes (Just a) (Just b) = unifyTypes a b

unifyUnion :: S.Set IRType -> S.Set IRType -> State IRGraph (S.Set IRType)
unifyUnion sa sb =
    do
        let { maybeArray: arrayA, maybeClass: classA, rest: sa } = decomposeTypeSet sa
        let { maybeArray: arrayB, maybeClass: classB, rest: sb } = decomposeTypeSet sb
        unifiedArray <- unifyMaybes arrayA arrayB
        unifiedClasses <- unifyMaybes classA classB
        pure $ S.unions [sa, sb, setFromType unifiedArray, setFromType unifiedClasses]

unifyTypes :: IRType -> IRType -> State IRGraph IRType
unifyTypes IRNothing x = pure x
unifyTypes x IRNothing = pure x
unifyTypes (IRArray a) (IRArray b) =
    do
        unified <- unifyTypes a b
        pure $ IRArray unified
unifyTypes (IRClass ia) (IRClass ib) =
    do
        a <- getClass ia
        b <- getClass ib
        unified <- unifyClasses a b
        combineClasses ia ib unified
unifyTypes (IRUnion a) (IRUnion b) =
    do
        unified <- unifyUnion a b
        pure $ IRUnion unified
unifyTypes (IRUnion a) b =
    do
        unified <- unifyUnion a (S.singleton b)
        pure $ IRUnion unified
unifyTypes a (IRUnion b) =
    do
        unified <- unifyUnion (S.singleton a) b
        pure $ IRUnion unified
unifyTypes a b =
    do
        pure $ if a == b then a else IRUnion (S.fromFoldable [a, b])

nullifyNothing :: IRType -> IRType
nullifyNothing IRNothing = IRNull
nullifyNothing x = x

unifyTypesWithNull :: IRType -> IRType -> State IRGraph IRType
unifyTypesWithNull IRNothing IRNothing = pure IRNothing
unifyTypesWithNull a b = unifyTypes (nullifyNothing a) (nullifyNothing b)

matchingProperties :: forall v. Eq v => Map String v -> Map String v -> Map String v
matchingProperties ma mb =
    M.fromFoldable (L.concatMap getFromB (M.toUnfoldable ma))
    where
        getFromB (Tuple k va) =
            case M.lookup k mb of
            Just vb -> if va == vb then Tuple k vb : L.Nil else L.Nil
            Nothing -> L.Nil

propertiesSimilar :: forall v. Eq v => Map String v -> Map String v -> Boolean
propertiesSimilar pa pb =
    let aInB = M.size $ matchingProperties pa pb
        bInA = M.size $ matchingProperties pb pa
    in
        (aInB * 4 >= (M.size pa) * 3) && (bInA * 4 >= (M.size pb) * 3)

isMaybeSubtypeOfMaybe :: IRGraph -> Maybe IRType -> Maybe IRType -> Boolean
isMaybeSubtypeOfMaybe _ Nothing Nothing = true
isMaybeSubtypeOfMaybe graph (Just a) (Just b) = isSubtypeOf graph a b
isMaybeSubtypeOfMaybe _ _ _ = false

isSubtypeOf :: IRGraph ->  IRType -> IRType -> Boolean
isSubtypeOf _ IRNothing _ = true
isSubtypeOf graph (IRUnion sa) (IRUnion sb) =
    all (\ta -> any (isSubtypeOf graph ta) sb) sa
isSubtypeOf graph (IRArray a) (IRArray b) =
    isSubtypeOf graph a b
isSubtypeOf graph (IRClass ia) (IRClass ib) =
    let IRClassData { names: _, properties: pa } = getClassFromGraph graph ia
        IRClassData { names: _, properties: pb } = getClassFromGraph graph ib
    in
        propertiesAreSubset graph pa pb
isSubtypeOf _ a b = a == b

propertiesAreSubset :: IRGraph -> Map String IRType -> Map String IRType -> Boolean
propertiesAreSubset graph ma mb =
    all isInB (M.toUnfoldable ma :: List _)
    where
        isInB (Tuple n ta) =
            case M.lookup n mb of
            Nothing -> false
            Just tb -> isSubtypeOf graph ta tb

classesSimilar :: IRGraph -> IRClassData -> IRClassData -> Boolean
classesSimilar graph (IRClassData { names: _, properties: pa }) (IRClassData { names: _, properties: pb }) =
    propertiesSimilar pa pb --||
    --propertiesAreSubset graph pa pb ||
    --propertiesAreSubset graph pb pa

similarClasses :: IRGraph -> Set (Set Int)
similarClasses graph@(IRGraph { classes }) =
    accumulate (mapClasses Tuple graph)
    where
        accumulate :: List (Tuple Int IRClassData) -> Set (Set Int)
        accumulate L.Nil = S.empty
        accumulate ((Tuple i thisClass) : rest) =
            let { yes: similar, no: others } = L.partition (isSimilar thisClass) rest
                recursiveResult = accumulate others
            in
                if L.length similar == 0 then
                    recursiveResult
                else
                    let similarSet = S.fromFoldable (i : (map T.fst similar))
                    in
                        S.insert similarSet recursiveResult
        isSimilar cd1 (Tuple _ cd2) =
            classesSimilar graph cd1 cd2

unifySetOfClasses :: Set Int -> (State IRGraph Unit)
unifySetOfClasses indexes =
    do
        combined <- foldM folder zeroClass indexes
        Tuple newIndex _ <- addClassWithIndex combined
        for_ indexes \i -> do
            redirectClass i newIndex
    where
        folder cd1 i2 =
            do
                cd2 <- getClass i2
                unifyClasses cd1 cd2

replaceSimilarClasses :: State IRGraph Unit
replaceSimilarClasses =
    do
        graph <- get
        let similar = similarClasses graph
        for_ similar unifySetOfClasses

combineNames :: S.Set String -> String
combineNames s =
    case L.fromFoldable s of
    L.Nil -> "NONAME"
    n : _ -> n

instance eqIRType :: Eq IRType where
    eq IRNothing IRNothing = true
    eq IRNull IRNull = true
    eq IRInteger IRInteger = true
    eq IRDouble IRDouble = true
    eq IRBool IRBool = true
    eq IRString IRString = true
    eq (IRArray a) (IRArray b) = a == b
    eq (IRClass a) (IRClass b) = a == b
    eq (IRUnion a) (IRUnion b) = a == b
    eq _ _ = false

instance ordIRType :: Ord IRType where
    compare IRNothing IRNothing = EQ
    compare IRNothing _ = LT
    compare _ IRNothing = GT
    compare IRNull IRNull = EQ
    compare IRNull _ = LT
    compare _ IRNull = GT
    compare IRInteger IRInteger = EQ
    compare IRInteger _ = LT
    compare _ IRInteger = GT
    compare IRDouble IRDouble = EQ
    compare IRDouble _ = LT
    compare _ IRDouble = GT
    compare IRBool IRBool = EQ
    compare IRBool _ = LT
    compare _ IRBool = GT
    compare IRString IRString = EQ
    compare IRString _ = LT
    compare _ IRString = GT
    compare (IRArray a) (IRArray b) = compare a b
    compare (IRArray _) _ = LT
    compare _ (IRArray _) = GT
    compare (IRClass a) (IRClass b) = compare a b
    compare (IRClass _) _ = LT
    compare _ (IRClass _) = GT
    compare (IRUnion a) (IRUnion b) = compare a b

instance eqIRClassData :: Eq IRClassData where
    eq (IRClassData { names: na, properties: pa }) (IRClassData { names: nb, properties: pb }) = na == nb && pa == pb

instance ordIRClassData :: Ord IRClassData where
    compare (IRClassData { names: na, properties: pa }) (IRClassData { names: nb, properties: pb }) =
        case compare na nb of
        EQ -> compare pa pb
        x -> x


Added times spoken as a column.

Added times spoken as a column.

Admins get a much better overview of how many times a speaker has
spoken in a certain speaker queue.

module Components.SpeakerQueue where

import Components.Forms as F
import Components.Forms.Field (mkField)
import Control.Monad.Aff (Aff)
import Data.Array as A
import Data.Either (Either(Right, Left))
import Data.Foreign (MultipleErrors)
import Data.HTTP.Method (Method(..))
import Data.Maybe (Maybe(Just, Nothing), fromJust, maybe)
import Data.StrMap as SM
import Debug.Trace (traceAnyA)
import Effects (LemmingPantsEffects)
import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Network.HTTP.StatusCode (StatusCode(..))
import Partial.Unsafe (unsafePartial)
import Postgrest (createURL)
import Postgrest as PG
import Prelude (type (~>), Unit, bind, id, map, pure, show, unit, ($), (*>), (<=), (<>))
import Simple.JSON (readJSON)
import Types.Attendee (Attendee(..), AttendeeDB, getAttendeeByNumber)
import Types.Speaker (Speaker(..), visualizeSpeaker)
import Types.SpeakerQueue (SpeakerQueue(..))
import Types.Token (Token)

type State =
  { agendaItemId :: Int
  , speakerQueue :: SpeakerQueue
  , token        :: Token
  , attendees    :: AttendeeDB
  , sqHeight     :: Int
  }

data Query a
  = PushSQ                a
  | PopSQ                 a
  | FormMsg     F.Message a
  | Next                  a
  | Eject                 a
  | Delete      Int       a
  | GotNewState State     a

data Message
  = Flash String

component :: forall e. H.Component HH.HTML Query State Message (Aff (LemmingPantsEffects e))
component =
  H.parentComponent
    { initialState: id
    , render
    , eval
    , receiver: HE.input GotNewState
    }

  where
    render :: State -> H.ParentHTML Query F.Query Unit (Aff (LemmingPantsEffects e))
    render state =
      HH.div_
        [ HH.div_
          [ HH.button [ HE.onClick (HE.input_ PushSQ) ] [ HH.text "Push speakerqueue" ]
          , HH.button
            [ HE.onClick (HE.input_ PopSQ)
            , if state.sqHeight <= 1
                then HP.disabled true
                else HP.disabled false
            ]
            [ HH.text "Pop speakerqueue" ]
          ]
        , HH.div_
            [ HH.p_
              [ HH.strong_ [ HH.text "Speaking: " ]
              , HH.text (maybe "–" (visualizeSpeaker state.attendees) sq.speaking)
              ]
            , HH.table_
                ([ HH.tr_
                  [ HH.th_ [ HH.text "ID"]
                  , HH.th_ [ HH.text "Name"]
                  , HH.th_ [ HH.text "#Spoken"]
                  , HH.th_ [ HH.text " "]
                  ]
                ] <>
                (map
                  (\s@(Speaker s') ->
                    HH.tr_
                      [ HH.td_ [ HH.text (show s'.attendeeId) ]
                      , HH.td_ [ HH.text (visualizeSpeaker state.attendees s) ]
                      , HH.td_ [ HH.text (show s'.timesSpoken) ]
                      , HH.td_ [ HH.button [ HE.onClick (HE.input_ (Delete s'.id)) ] [ HH.text "X" ] ]
                      ])
                  sq.speakers))
            , HH.slot
              unit
              (F.component "Add speaker"
                [ mkField "id" "ID" [HP.type_ HP.InputNumber, HP.required true] ]
              )
              unit
              (HE.input FormMsg)
            , HH.ul_
                [ HH.li_ [ HH.button [ HE.onClick (HE.input_ Eject) ] [HH.text "Eject current speaker"] ]
                , HH.li_ [ HH.button [ HE.onClick (HE.input_ Next)  ] [HH.text "Next speaker"] ]
                ]
            ]
        ]
      where
        (SpeakerQueue sq) = state.speakerQueue

    eval :: Query ~> H.ParentDSL State Query F.Query Unit Message (Aff (LemmingPantsEffects e))
    eval =
      case _ of
        PushSQ next -> do
          state <- H.get
          r <- H.liftAff $ PG.emptyResponse
             (createURL "/speaker_queue")
            state.token
            POST
            { agenda_item_id: state.agendaItemId
            , state:          "active" }
          case r.status of
            StatusCode 201 -> -- The `Created` HTTP status code.
              pure unit
            _ ->
              H.raise (Flash "PushSQ -- ERROR! Got a HTTP response we didn't expect! See the console for more information.")
          *> pure next
        PopSQ next -> do
          state <- H.get
          let (SpeakerQueue sq) = state.speakerQueue
          r <- H.liftAff $ PG.emptyResponse
             (createURL $ "/speaker_queue?id=eq." <> show sq.id)
             state.token
             PATCH
             { state: "done" }
          case r.status of
            StatusCode 204 -> -- No Content
              pure unit
            _ ->
              H.raise (Flash "PopSQ -- ERROR! Got a HTTP response we didn't expect! See the console for more information.")
          *> pure next
        FormMsg m next -> do
          state <- H.get
          let (SpeakerQueue sq) = state.speakerQueue
          case m of
            F.FormSubmitted m' ->
              case readJSON (unsafePartial (fromJust (SM.lookup "id" m'))) :: Either MultipleErrors Int of
                Left es -> traceAnyA es
                Right n -> do
                  case getAttendeeByNumber n state.attendees of
                    Nothing           ->
                      H.raise (Flash ("Couldn't find attendee with number: " <> show n))
                    Just (Attendee a) -> do
                      r <- H.liftAff $ PG.emptyResponse
                        (createURL "/speaker")
                        state.token
                        POST
                        { speaker_queue_id: sq.id
                        , attendee_id:      a.id
                        }
                      case r.status of
                        StatusCode 201 -> -- The `Created` HTTP status code.
                          pure unit
                        _ ->
                          H.raise (Flash "SpeakerQueue.FormMsg -- ERROR! Got a HTTP response we didn't expect! See the console for more information.")
          *> pure next
        Next next -> do
          state <- H.get
          let (SpeakerQueue sq) = state.speakerQueue
          case A.head sq.speakers of
            Nothing          -> pure unit
            Just (Speaker s) -> do
              r <- H.liftAff $ PG.emptyResponse
                      (createURL "/rpc/set_current_speaker")
                      state.token
                      POST
                      {id: s.id}
              case r.status of
                StatusCode 200 ->
                  pure unit
                _ ->
                  H.raise (Flash "SpeakerQueue.Next -- ERROR! Got a HTTP response we didn't expect! See the console for more information.")
          *> pure next
        Eject next -> do
          state <- H.get
          let (SpeakerQueue sq) = state.speakerQueue
          case sq.speaking of
            Nothing          -> pure unit
            Just (Speaker s) -> do
              r <- H.liftAff $ PG.emptyResponse
                      (createURL $ "/speaker?id=eq." <> show s.id)
                      state.token
                      PATCH
                      { state: "done" }
              case r.status of
                StatusCode 204 -> -- The `Created` HTTP status code.
                  pure unit
                _ ->
                  H.raise (Flash "SpeakerQueue.Eject -- ERROR! Got a HTTP response we didn't expect! See the console for more information.")
          *> pure next
        Delete id_ next -> do
          state <- H.get
          r <- H.liftAff $ PG.emptyResponse
                  (createURL $ "/speaker?id=eq." <> show id_)
                  state.token
                  PATCH
                  { state: "deleted" }
          case r.status of
            StatusCode 204 -> -- The `Created` HTTP status code.
              pure unit
            _ ->
              H.raise (Flash "SpeakerQueue.Delete -- ERROR! Got a HTTP response we didn't expect! See the console for more information.")
          *> pure next
        GotNewState s next -> H.put s *> pure next

module Components.SpeakerQueue where

import Components.Forms as F
import Components.Forms.Field (mkField)
import Control.Monad.Aff (Aff)
import Data.Array as A
import Data.Either (Either(Right, Left))
import Data.Foreign (MultipleErrors)
import Data.HTTP.Method (Method(..))
import Data.Maybe (Maybe(Just, Nothing), fromJust, maybe)
import Data.StrMap as SM
import Debug.Trace (traceAnyA)
import Effects (LemmingPantsEffects)
import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Network.HTTP.StatusCode (StatusCode(..))
import Partial.Unsafe (unsafePartial)
import Postgrest (createURL)
import Postgrest as PG
import Prelude (type (~>), Unit, bind, id, map, pure, show, unit, ($), (*>), (<=), (<>))
import Simple.JSON (readJSON)
import Types.Attendee (Attendee(..), AttendeeDB, getAttendeeByNumber)
import Types.Speaker (Speaker(..), visualizeSpeaker)
import Types.SpeakerQueue (SpeakerQueue(..))
import Types.Token (Token)

type State =
  { agendaItemId :: Int
  , speakerQueue :: SpeakerQueue
  , token        :: Token
  , attendees    :: AttendeeDB
  , sqHeight     :: Int
  }

data Query a
  = PushSQ                a
  | PopSQ                 a
  | FormMsg     F.Message a
  | Next                  a
  | Eject                 a
  | Delete      Int       a
  | GotNewState State     a

data Message
  = Flash String

component :: forall e. H.Component HH.HTML Query State Message (Aff (LemmingPantsEffects e))
component =
  H.parentComponent
    { initialState: id
    , render
    , eval
    , receiver: HE.input GotNewState
    }

  where
    render :: State -> H.ParentHTML Query F.Query Unit (Aff (LemmingPantsEffects e))
    render state =
      HH.div_
        [ HH.div_
          [ HH.button [ HE.onClick (HE.input_ PushSQ) ] [ HH.text "Push speakerqueue" ]
          , HH.button
            [ HE.onClick (HE.input_ PopSQ)
            , if state.sqHeight <= 1
                then HP.disabled true
                else HP.disabled false
            ]
            [ HH.text "Pop speakerqueue" ]
          ]
        , HH.div_
            [ HH.p_
              [ HH.strong_ [ HH.text "Speaking: " ]
              , HH.text (maybe "–" (visualizeSpeaker state.attendees) sq.speaking)
              ]
            , HH.table_
                ([ HH.tr_
                  [ HH.th_ [ HH.text "ID"]
                  , HH.th_ [ HH.text "Namn"]
                  , HH.th_ [ HH.text " "]
                  ]
                ] <>
                (map
                  (\s@(Speaker s') ->
                    HH.tr_
                      [ HH.td_ [ HH.text (show s'.attendeeId) ]
                      , HH.td_ [ HH.text (visualizeSpeaker state.attendees s) ]
                      , HH.td_ [ HH.button [ HE.onClick (HE.input_ (Delete s'.id)) ] [ HH.text "X" ] ]
                      ])
                  sq.speakers))
            , HH.slot
              unit
              (F.component "Add speaker"
                [ mkField "id" "ID" [HP.type_ HP.InputNumber, HP.required true] ]
              )
              unit
              (HE.input FormMsg)
            , HH.ul_
                [ HH.li_ [ HH.button [ HE.onClick (HE.input_ Eject) ] [HH.text "Eject current speaker"] ]
                , HH.li_ [ HH.button [ HE.onClick (HE.input_ Next)  ] [HH.text "Next speaker"] ]
                ]
            ]
        ]
      where
        (SpeakerQueue sq) = state.speakerQueue

    eval :: Query ~> H.ParentDSL State Query F.Query Unit Message (Aff (LemmingPantsEffects e))
    eval =
      case _ of
        PushSQ next -> do
          state <- H.get
          r <- H.liftAff $ PG.emptyResponse
             (createURL "/speaker_queue")
            state.token
            POST
            { agenda_item_id: state.agendaItemId
            , state:          "active" }
          case r.status of
            StatusCode 201 -> -- The `Created` HTTP status code.
              pure unit
            _ ->
              H.raise (Flash "PushSQ -- ERROR! Got a HTTP response we didn't expect! See the console for more information.")
          *> pure next
        PopSQ next -> do
          state <- H.get
          let (SpeakerQueue sq) = state.speakerQueue
          r <- H.liftAff $ PG.emptyResponse
             (createURL $ "/speaker_queue?id=eq." <> show sq.id)
             state.token
             PATCH
             { state: "done" }
          case r.status of
            StatusCode 204 -> -- No Content
              pure unit
            _ ->
              H.raise (Flash "PopSQ -- ERROR! Got a HTTP response we didn't expect! See the console for more information.")
          *> pure next
        FormMsg m next -> do
          state <- H.get
          let (SpeakerQueue sq) = state.speakerQueue
          case m of
            F.FormSubmitted m' ->
              case readJSON (unsafePartial (fromJust (SM.lookup "id" m'))) :: Either MultipleErrors Int of
                Left es -> traceAnyA es
                Right n -> do
                  case getAttendeeByNumber n state.attendees of
                    Nothing           ->
                      H.raise (Flash ("Couldn't find attendee with number: " <> show n))
                    Just (Attendee a) -> do
                      r <- H.liftAff $ PG.emptyResponse
                        (createURL "/speaker")
                        state.token
                        POST
                        { speaker_queue_id: sq.id
                        , attendee_id:      a.id
                        }
                      case r.status of
                        StatusCode 201 -> -- The `Created` HTTP status code.
                          pure unit
                        _ ->
                          H.raise (Flash "SpeakerQueue.FormMsg -- ERROR! Got a HTTP response we didn't expect! See the console for more information.")
          *> pure next
        Next next -> do
          state <- H.get
          let (SpeakerQueue sq) = state.speakerQueue
          case A.head sq.speakers of
            Nothing          -> pure unit
            Just (Speaker s) -> do
              r <- H.liftAff $ PG.emptyResponse
                      (createURL "/rpc/set_current_speaker")
                      state.token
                      POST
                      {id: s.id}
              case r.status of
                StatusCode 200 ->
                  pure unit
                _ ->
                  H.raise (Flash "SpeakerQueue.Next -- ERROR! Got a HTTP response we didn't expect! See the console for more information.")
          *> pure next
        Eject next -> do
          state <- H.get
          let (SpeakerQueue sq) = state.speakerQueue
          case sq.speaking of
            Nothing          -> pure unit
            Just (Speaker s) -> do
              r <- H.liftAff $ PG.emptyResponse
                      (createURL $ "/speaker?id=eq." <> show s.id)
                      state.token
                      PATCH
                      { state: "done" }
              case r.status of
                StatusCode 204 -> -- The `Created` HTTP status code.
                  pure unit
                _ ->
                  H.raise (Flash "SpeakerQueue.Eject -- ERROR! Got a HTTP response we didn't expect! See the console for more information.")
          *> pure next
        Delete id_ next -> do
          state <- H.get
          r <- H.liftAff $ PG.emptyResponse
                  (createURL $ "/speaker?id=eq." <> show id_)
                  state.token
                  PATCH
                  { state: "deleted" }
          case r.status of
            StatusCode 204 -> -- The `Created` HTTP status code.
              pure unit
            _ ->
              H.raise (Flash "SpeakerQueue.Delete -- ERROR! Got a HTTP response we didn't expect! See the console for more information.")
          *> pure next
        GotNewState s next -> H.put s *> pure next


Clarify `Unit` representation in FFI code (#223)

module Data.Unit where

import Data.Show (class Show)

-- | The `Unit` type has a single inhabitant, called `unit`. It represents
-- | values with no computational content.
-- |
-- | `Unit` is often used, wrapped in a monadic type constructor, as the
-- | return type of a computation where only the _effects_ are important.
-- |
-- | When returning a value of type `Unit` from an FFI function, it is
-- | recommended to use `undefined`, or not return a value at all.
foreign import data Unit :: Type

-- | `unit` is the sole inhabitant of the `Unit` type.
foreign import unit :: Unit

instance showUnit :: Show Unit where
  show _ = "unit"

module Data.Unit where

import Data.Show (class Show)

-- | The `Unit` type has a single inhabitant, called `unit`. It represents
-- | values with no computational content.
-- |
-- | `Unit` is often used, wrapped in a monadic type constructor, as the
-- | return type of a computation where only the _effects_ are important.
foreign import data Unit :: Type

-- | `unit` is the sole inhabitant of the `Unit` type.
foreign import unit :: Unit

instance showUnit :: Show Unit where
  show _ = "unit"


clean up GMaps.Map a bit

clean up GMaps.Map a bit

module GMaps.Map (Map (), gMap, panTo) where

import Control.Monad.Eff
import DomHelpers
import GMaps.LatLng
import GMaps.MapOptions

foreign import data Map :: *

foreign import gMapFFI
  "function gMapFFI(ele) {\
  \  return function(opts) {\
  \    return function() {\
  \      return (new google.maps.Map(ele, opts));\
  \    };\
  \  };\
  \}" :: forall eff. Element -> { zoom :: Number, center :: LatLng, mapTypeId :: String } -> Eff eff Map

gMap :: forall eff. Element -> MapOptions -> Eff eff Map
gMap e m = gMapFFI e (runMapOptions m)

foreign import panTo
  "function panTo(map) {\
  \  return function(x) {\
  \    return function() {\
  \      map.panTo(x);\
  \      return;\
  \    };\
  \  };\
  \}" :: forall eff. Map -> LatLng -> Eff eff Unit

module GMaps.Map where

import Control.Monad.Eff
import DomHelpers
import GMaps.LatLng
import GMaps.MapOptions

foreign import data Map :: *

foreign import gMap
  "function gMap(ele) {\
  \  return function(opts) {\
  \    return function() {\
  \      return (new google.maps.Map(ele, opts.values[0]));\
  \    };\
  \  };\
  \}" :: forall eff. Element -> MapOptions -> Eff eff Map

foreign import panTo
  "function panTo(map) {\
  \  return function(x) {\
  \    return function() {\
  \      map.panTo(x);\
  \      return;\
  \    };\
  \  };\
  \}" :: forall eff. Map -> LatLng -> Eff eff Unit


Fix Open File interaction

Fix Open File interaction

module Test.SlamData.Feature.Interactions where

import SlamData.Prelude

import Data.Argonaut (encodeJson)
import Data.Array as Arr
import Data.Map as Map
import Data.String as S
import Data.StrMap as SM

import Global (encodeURIComponent)

import Selenium.Monad (get, refresh, getCurrentUrl, tryRepeatedlyTo)

import Test.Feature as Feature
import Test.SlamData.Feature.Monad (SlamFeature, getConfig, waitTime)
import Test.SlamData.Feature.XPaths as XPaths
import Test.Utils (appendToCwd)

import XPath as XPath

import Utils (prettyJson)
import Utils.Array (enumerate)

followingLastPreviousCardGripper :: String -> String
followingLastPreviousCardGripper = XPath.following lastPreviousCardGripperXPath
  where
  lastPreviousCardGripperXPath = XPath.last $ XPath.anywhere XPaths.previousCardGripper

launchSlamData ∷ SlamFeature Unit
launchSlamData = get ∘ _.slamdataUrl =<< getConfig

accessWorkspaceWithModifiedURL ∷ (String → String) → SlamFeature Unit
accessWorkspaceWithModifiedURL modifier =
  getCurrentUrl >>= modifier >>> get

mountTestDatabase ∷ SlamFeature Unit
mountTestDatabase = do
  -- If we don't wait for "Configure database" to appear in the toolbar the
  -- wrong item will be clicked for "Mount database" due to a timing issue. Yay.
  Feature.expectPresented (XPath.anywhere XPaths.accessConfigureMount)
  Feature.click (XPath.anywhere XPaths.accessMountDatabase)
  Feature.provideFieldValue (XPath.anywhere XPaths.mountName) "test-mount"
  Feature.selectFromDropdown (XPath.anywhere XPaths.mountType) "MongoDB"
  Feature.click (XPath.anywhere $ XPaths.mountName)
  Feature.provideFieldValue (XPath.index (XPath.anywhere XPaths.mountPort) 1) "63174"
  Feature.provideFieldValue (XPath.index (XPath.anywhere XPaths.mountHost) 1) "localhost"
  Feature.provideFieldValue (XPath.anywhere XPaths.mountDatabase) "testDb"
  Feature.click (XPath.anywhere XPaths.mountButton)

skipGuide ∷ SlamFeature Unit
skipGuide =
  Feature.click $ XPath.anywhere $ XPath.anyWithText "Skip"

dismissHint ∷ SlamFeature Unit
dismissHint =
  Feature.click $ XPath.anywhere $ XPath.anyWithExactAriaLabel "Dismiss"

accessFile ∷ String → SlamFeature Unit
accessFile =
  Feature.click ∘ XPath.anywhere ∘ XPaths.accessFile

exploreFile ∷ String → SlamFeature Unit
exploreFile name = do
  Feature.provideFieldValue (XPath.anywhere $ XPath.anyWithExactAriaLabel "New workspace name") name
  Feature.click $ XPath.anywhere $ XPath.anyWithExactAriaLabel "Explore file"

accessBreadcrumb ∷ String → SlamFeature Unit
accessBreadcrumb = Feature.click ∘ XPath.anywhere ∘ XPaths.accessBreadcrumb

browseRootFolder ∷ SlamFeature Unit
browseRootFolder = do
  Feature.click $ XPath.anywhere XPaths.headerGripper
  Feature.click $ XPath.index (XPath.anywhere XPaths.browseRootFolder) 1

browseTestFolder ∷ SlamFeature Unit
browseTestFolder =
  browseRootFolder *> accessFile "test-mount" *> accessFile "testDb"

createWorkspace ∷ SlamFeature Unit
createWorkspace = Feature.click $ XPath.anywhere XPaths.createWorkspace

nameDeck ∷ String → SlamFeature Unit
nameDeck name = do
  flipDeck
  Feature.click $ XPath.anywhere XPaths.renameDeck
  Feature.provideFieldValue (XPath.anywhere $ XPath.nodeWithExactAriaLabel "input" "Deck name") name
  Feature.click $ XPath.anywhere $ XPath.anyWithExactText "Save"

deleteFile ∷ String → SlamFeature Unit
deleteFile name =
  Feature.click (XPath.anywhere $ XPaths.selectFile name)
    *> Feature.click (XPath.anywhere $ XPaths.removeFile name)
    *> Feature.expectNotPresented (XPath.anywhere $ XPath.nodeWithExactText XPath.any name)

shareFile ∷ String → SlamFeature Unit
shareFile name = do
  Feature.click (XPath.anywhere $ XPaths.selectFile name)
  tryRepeatedlyTo $ clickShareFile <|> clickShareWorkspace
  where
  clickShareFile =
    Feature.clickNotRepeatedly (XPath.anywhere $ XPaths.shareFile name)
  clickShareWorkspace =
    Feature.clickNotRepeatedly (XPath.anywhere $ XPaths.shareFile $ name <> ".slam")

renameFile ∷ String → String → SlamFeature Unit
renameFile oldName newName = do
  selectFile oldName
  clickMove oldName
  Feature.provideFieldValueWithProperties
    (Map.singleton "value" $ Just oldName)
    (XPath.anywhere "input")
    newName
  Feature.click $ XPath.anywhere XPaths.renameButton
  where
  oldWorkspaceName = oldName <> ".slam"

moveFile ∷ String → String → String → SlamFeature Unit
moveFile fileName oldLocation newLocation = do
  selectFile fileName
  clickMove fileName
  Feature.click $ XPath.anywhere XPaths.selectADestinationFolder
  Feature.click $ XPath.anywhere $ XPath.anyWithExactText newLocation
  Feature.click $ XPath.anywhere XPaths.renameButton

clickMove ∷ String → SlamFeature Unit
clickMove name =
  tryRepeatedlyTo $ clickMoveFile <|> clickMoveWorkspace
  where
  clickMoveFile =
    Feature.clickNotRepeatedly $ XPath.anywhere $ XPaths.moveFile name
  clickMoveWorkspace =
    Feature.clickNotRepeatedly $ XPath.anywhere $ XPaths.moveFile $ name <> ".slam"

uploadFile ∷ String → SlamFeature Unit
uploadFile =
  Feature.provideFileInputValue (XPath.anywhere $ XPaths.uploadFile)
    <=< appendToCwd

provideFileSearchString ∷ String → SlamFeature Unit
provideFileSearchString value =
  Feature.provideFieldValue (XPath.anywhere XPaths.fileSearchInput) value

selectFile ∷ String → SlamFeature Unit
selectFile name =
  tryRepeatedlyTo (selectFile' <|> selectWorkspace)
  where
  selectFile' =
    Feature.clickNotRepeatedly $ XPath.anywhere $ XPaths.selectFile name
  selectWorkspace =
    Feature.clickNotRepeatedly $ XPath.anywhere $ XPaths.selectFile $ name <> ".slam"

createWorkspaceInTestFolder ∷ String → SlamFeature Unit
createWorkspaceInTestFolder name = do
  browseTestFolder
  createWorkspace
  nameDeck name
  browseTestFolder
  renameFile "Untitled Workspace" name
  accessFile $ name <> ".slam"

createFolder ∷ SlamFeature Unit
createFolder = Feature.click $ XPath.anywhere XPaths.createFolder

deleteFileInTestFolder ∷ String → SlamFeature Unit
deleteFileInTestFolder name = browseTestFolder *> deleteFile name

reopenCurrentWorkspace ∷ SlamFeature Unit
reopenCurrentWorkspace = waitTime 2000 *> refresh

expandNewCardMenu ∷ SlamFeature Unit
expandNewCardMenu = Feature.click (XPath.anywhere XPaths.insertCard)

accessNextCardInLastDeck ∷ SlamFeature Unit
accessNextCardInLastDeck =
  Feature.dragAndDrop
    (XPath.last $ XPath.anywhere $ XPaths.enabledNextCardGripper)
    (XPath.last $ XPath.anywhere $ XPaths.previousCardGripper)

accessPreviousCardInLastDeck ∷ SlamFeature Unit
accessPreviousCardInLastDeck =
  Feature.dragAndDrop
    (XPath.last $ XPath.anywhere $ XPaths.enabledPreviousCardGripper)
    (XPath.last $ XPath.anywhere $ XPaths.nextCardGripper)

insertSearchCardInLastDeck ∷ SlamFeature Unit
insertSearchCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertSearchCard

insertQueryCardInLastDeck ∷ SlamFeature Unit
insertQueryCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertQueryCard

insertMdCardInLastDeck ∷ SlamFeature Unit
insertMdCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertMdCard

insertOpenCardInLastDeck ∷ SlamFeature Unit
insertOpenCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertOpenCard

insertChartOptionsCardInLastDeck ∷ SlamFeature Unit
insertChartOptionsCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertChartOptionsCard

insertDisplayMarkdownCardInLastDeck ∷ SlamFeature Unit
insertDisplayMarkdownCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertDisplayMarkdownCard

insertTableCardInLastDeck ∷ SlamFeature Unit
insertTableCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertTableCard

insertChartCardInLastDeck ∷ SlamFeature Unit
insertChartCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertChartCard

insertCacheCardInLastDeck ∷ SlamFeature Unit
insertCacheCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertCacheCard

insertVariablesCardInLastDeck ∷ SlamFeature Unit
insertVariablesCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertVariablesCard

insertTroubleshootCardInLastDeck ∷ SlamFeature Unit
insertTroubleshootCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertTroubleshootCard

selectBuildChart ∷ SlamFeature Unit
selectBuildChart =
  Feature.click $ followingLastPreviousCardGripper XPaths.selectBuildChart

insertPivotCard ∷ SlamFeature Unit
insertPivotCard =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertPivotCard

insertBuildBarChartCard ∷ SlamFeature Unit
insertBuildBarChartCard =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertBuildBarChartCard

addColumn ∷ String → SlamFeature Unit
addColumn str = do
  Feature.click $ XPath.last $ XPath.anywhere $ XPath.anyWithExactAriaLabel "Add column"
  Feature.click $ XPath.last $ XPath.anywhere $ XPath.anyWithExactAriaLabel $ "Select " ⊕ str
  Feature.click $ XPath.last $ XPath.anywhere $ XPath.anyWithExactText "Confirm"

selectInMillerColumns ∷ Array String → SlamFeature Unit
selectInMillerColumns ps = do
  for_ (enumerate $ Arr.filter (\s → S.length s > 0) ps) \(ix × path) →
    Feature.click $ resourceXPath (ix + one) path
  where
  ariaLabel ∷ String → String
  ariaLabel rPath = "Select " ⊕ rPath

  resourceXPath ∷ Int → String → String
  resourceXPath ix rPath =
    XPath.last
      $ XPath.anywhere
      $ (XPath.nodeAtPosition ix $ XPath.anyWithExactAriaLabel "Column")
      ⊕ XPath.descendantString
      ⊕ (XPath.anyWithExactAriaLabel $ ariaLabel rPath)

selectFileForLastOpenCard ∷ String → SlamFeature Unit
selectFileForLastOpenCard s =
  selectInMillerColumns $ pure "Filesystem" <> S.split (S.Pattern "/") s

selectInChartBuilder ∷ Array String → SlamFeature Unit
selectInChartBuilder ps = do
  selectInMillerColumns ps
  Feature.click $ XPath.last $ XPath.anywhere $ XPath.anyWithExactText "Confirm"

provideSearchStringInLastSearchCard ∷ String → SlamFeature Unit
provideSearchStringInLastSearchCard =
  Feature.provideFieldValue $ XPath.last $ XPath.anywhere XPaths.searchStringInput

provideMdInLastMdCard ∷ String → SlamFeature Unit
provideMdInLastMdCard =
  Feature.provideFieldValue
    $ XPath.last $ XPath.anywhere XPaths.aceEditor

provideQueryInLastQueryCard ∷ String → SlamFeature Unit
provideQueryInLastQueryCard =
  Feature.provideFieldValue
    $ XPath.last $ XPath.anywhere XPaths.aceEditor

provideSaveDestinationInLastCacheCard ∷ String → SlamFeature Unit
provideSaveDestinationInLastCacheCard =
  Feature.provideFieldValue (XPath.last $ XPath.anywhere XPaths.saveDestinationInput)

doSaveInLastCacheCard ∷ SlamFeature Unit
doSaveInLastCacheCard =
  Feature.click (XPath.last $ XPath.anywhere XPaths.saveSubmitButton)

provideFieldValueInLastDeck ∷ String → String → SlamFeature Unit
provideFieldValueInLastDeck labelText =
  Feature.provideFieldValue
    $ followingLastPreviousCardGripper
    $ "input" `XPath.withLabelWithExactText` labelText

checkFieldInLastDeck ∷ String → SlamFeature Unit
checkFieldInLastDeck labelText =
  Feature.check
    $ followingLastPreviousCardGripper
    $ "input" `XPath.withLabelWithExactText` labelText

uncheckFieldInLastDeck ∷ String → SlamFeature Unit
uncheckFieldInLastDeck labelText =
  Feature.uncheck
    $ followingLastPreviousCardGripper
    $ "input" `XPath.withLabelWithExactText` labelText

pushRadioButtonInLastDeck ∷ String → SlamFeature Unit
pushRadioButtonInLastDeck labelText =
  Feature.pushRadioButton
    $ followingLastPreviousCardGripper
    $ "input" `XPath.withLabelWithExactText` labelText

selectFromDropdownInLastDeck ∷ String → String → SlamFeature Unit
selectFromDropdownInLastDeck labelText =
  Feature.selectFromDropdown
    $ followingLastPreviousCardGripper
    $ "select" `XPath.withLabelWithExactText` labelText

accessSharingUrl ∷ SlamFeature Unit
accessSharingUrl = Feature.accessUrlFromFieldValue $ XPath.anywhere XPaths.sharingUrl

accessPublishingUrl ∷ SlamFeature Unit
accessPublishingUrl = Feature.accessUrlFromFieldValue $ XPath.anywhere XPaths.publishingUrl

downloadFileAsCSV ∷ String → SlamFeature Unit
downloadFileAsCSV fileName = do
  selectFile fileName
  Feature.click $ XPath.anywhere $ XPaths.downloadFile fileName
  Feature.click $ XPath.anywhere $ XPaths.downloadButton
  Feature.click $ XPath.anywhere $ XPaths.cancelButton

downloadFileAsJSON ∷ String → SlamFeature Unit
downloadFileAsJSON fileName = do
  selectFile fileName
  Feature.click $ XPath.anywhere $ XPaths.downloadFile fileName
  Feature.click $ XPath.anywhere $ XPath.anyWithText "JSON"
  Feature.click $ XPath.anywhere $ XPaths.downloadButton
  Feature.click $ XPath.anywhere $ XPaths.cancelButton

showHiddenFiles ∷ SlamFeature Unit
showHiddenFiles =
  Feature.click $ XPath.anywhere $ XPaths.showHiddenFiles

hideHiddenFiles ∷ SlamFeature Unit
hideHiddenFiles =
  Feature.click $ XPath.anywhere $ XPaths.hideHiddenFiles

type ApiVarName = String
type ApiVarType = String
type ApiVarValue = String

provideApiVariableBindingsForVariablesCard
  ∷ ApiVarName
  → ApiVarType
  → ApiVarValue
  → SlamFeature Unit
provideApiVariableBindingsForVariablesCard name ty val = do
  provideValueForVariablesCard
  provideTypeForVariablesCard
  provideDefaultValueForVariablesCard
  where
  provideValueForVariablesCard ∷ SlamFeature Unit
  provideValueForVariablesCard = do
    Feature.provideFieldValue
      (XPath.first $ XPath.anywhere $ XPaths.variablesCardVariableName)
      name
    Feature.pressEnter
  provideTypeForVariablesCard ∷ SlamFeature Unit
  provideTypeForVariablesCard = do
    Feature.selectFromDropdown
      (XPath.first $ XPath.anywhere $ XPaths.variablesCardVariableTypeFor name)
      ty
    Feature.pressEnter

  provideDefaultValueForVariablesCard ∷ SlamFeature Unit
  provideDefaultValueForVariablesCard = do
    Feature.provideFieldValue
      (XPath.first $ XPath.anywhere $ XPaths.variablesCardDefaultValueFor name)
      val
    Feature.pressEnter

activateCategoryForChartBuilder ∷ SlamFeature Unit
activateCategoryForChartBuilder =
  Feature.click $ XPath.last $ XPath.anywhere $ XPaths.chartCategorySelector

activateStackForChartBuilder ∷ SlamFeature Unit
activateStackForChartBuilder =
  Feature.click $ XPath.last $ XPath.anywhere $ XPaths.chartStackSelector

flipDeck ∷ SlamFeature Unit
flipDeck =
  Feature.click $ XPath.anywhere $ XPath.anyWithExactAriaLabel "Flip deck"

trashActiveOrLastCard ∷ SlamFeature Unit
trashActiveOrLastCard =
  Feature.click $ XPath.anywhere $ XPath.anyWithExactAriaLabel "Delete card"

shareDeck ∷ SlamFeature Unit
shareDeck =
  Feature.click $ XPath.anywhere $ XPath.anyWithExactAriaLabel "Share deck"

publishDeck ∷ SlamFeature Unit
publishDeck =
  Feature.click $ XPath.anywhere $ XPath.anyWithExactAriaLabel "Publish deck"

filterDeckAndCardActions ∷ String → SlamFeature Unit
filterDeckAndCardActions =
  Feature.provideFieldValue (XPath.anywhere $ XPath.anyWithExactAriaLabel "Filter deck and card actions")

filterNextActions ∷ String → SlamFeature Unit
filterNextActions =
  Feature.provideFieldValue (XPath.anywhere $ XPath.anyWithExactAriaLabel "Filter next actions")

confirmDeckAction ∷ SlamFeature Unit
confirmDeckAction =
  Feature.click $ XPath.anywhere $ XPath.anyWithExactText "Confirm"

runQuery ∷ SlamFeature Unit
runQuery =
  Feature.click $ XPath.last $ XPath.anywhere $ XPath.anyWithExactAriaLabel "Run query"

setVarMapForDeck ∷ String → SM.StrMap String → SlamFeature Unit
setVarMapForDeck deckName vm = accessWorkspaceWithModifiedURL \urlStr →
  let
    varsValue =
      encodeURIComponent
      $ prettyJson
      $ encodeJson
      $ SM.singleton deckName vm
  in
   urlStr ⊕ "/?vars=" ⊕ varsValue

module Test.SlamData.Feature.Interactions where

import SlamData.Prelude

import Data.Argonaut (encodeJson)
import Data.Array as Arr
import Data.Map as Map
import Data.String as S
import Data.StrMap as SM

import Global (encodeURIComponent)

import Selenium.Monad (get, refresh, getCurrentUrl, tryRepeatedlyTo)

import Test.Feature as Feature
import Test.SlamData.Feature.Monad (SlamFeature, getConfig, waitTime)
import Test.SlamData.Feature.XPaths as XPaths
import Test.Utils (appendToCwd)

import XPath as XPath

import Utils (prettyJson)
import Utils.Array (enumerate)

followingLastPreviousCardGripper :: String -> String
followingLastPreviousCardGripper = XPath.following lastPreviousCardGripperXPath
  where
  lastPreviousCardGripperXPath = XPath.last $ XPath.anywhere XPaths.previousCardGripper

launchSlamData ∷ SlamFeature Unit
launchSlamData = get ∘ _.slamdataUrl =<< getConfig

accessWorkspaceWithModifiedURL ∷ (String → String) → SlamFeature Unit
accessWorkspaceWithModifiedURL modifier =
  getCurrentUrl >>= modifier >>> get

mountTestDatabase ∷ SlamFeature Unit
mountTestDatabase = do
  -- If we don't wait for "Configure database" to appear in the toolbar the
  -- wrong item will be clicked for "Mount database" due to a timing issue. Yay.
  Feature.expectPresented (XPath.anywhere XPaths.accessConfigureMount)
  Feature.click (XPath.anywhere XPaths.accessMountDatabase)
  Feature.provideFieldValue (XPath.anywhere XPaths.mountName) "test-mount"
  Feature.selectFromDropdown (XPath.anywhere XPaths.mountType) "MongoDB"
  Feature.click (XPath.anywhere $ XPaths.mountName)
  Feature.provideFieldValue (XPath.index (XPath.anywhere XPaths.mountPort) 1) "63174"
  Feature.provideFieldValue (XPath.index (XPath.anywhere XPaths.mountHost) 1) "localhost"
  Feature.provideFieldValue (XPath.anywhere XPaths.mountDatabase) "testDb"
  Feature.click (XPath.anywhere XPaths.mountButton)

skipGuide ∷ SlamFeature Unit
skipGuide =
  Feature.click $ XPath.anywhere $ XPath.anyWithText "Skip"

dismissHint ∷ SlamFeature Unit
dismissHint =
  Feature.click $ XPath.anywhere $ XPath.anyWithExactAriaLabel "Dismiss"

accessFile ∷ String → SlamFeature Unit
accessFile =
  Feature.click ∘ XPath.anywhere ∘ XPaths.accessFile

exploreFile ∷ String → SlamFeature Unit
exploreFile name = do
  Feature.provideFieldValue (XPath.anywhere $ XPath.anyWithExactAriaLabel "New workspace name") name
  Feature.click $ XPath.anywhere $ XPath.anyWithExactAriaLabel "Explore file"

accessBreadcrumb ∷ String → SlamFeature Unit
accessBreadcrumb = Feature.click ∘ XPath.anywhere ∘ XPaths.accessBreadcrumb

browseRootFolder ∷ SlamFeature Unit
browseRootFolder = do
  Feature.click $ XPath.anywhere XPaths.headerGripper
  Feature.click $ XPath.index (XPath.anywhere XPaths.browseRootFolder) 1

browseTestFolder ∷ SlamFeature Unit
browseTestFolder =
  browseRootFolder *> accessFile "test-mount" *> accessFile "testDb"

createWorkspace ∷ SlamFeature Unit
createWorkspace = Feature.click $ XPath.anywhere XPaths.createWorkspace

nameDeck ∷ String → SlamFeature Unit
nameDeck name = do
  flipDeck
  Feature.click $ XPath.anywhere XPaths.renameDeck
  Feature.provideFieldValue (XPath.anywhere $ XPath.nodeWithExactAriaLabel "input" "Deck name") name
  Feature.click $ XPath.anywhere $ XPath.anyWithExactText "Save"

deleteFile ∷ String → SlamFeature Unit
deleteFile name =
  Feature.click (XPath.anywhere $ XPaths.selectFile name)
    *> Feature.click (XPath.anywhere $ XPaths.removeFile name)
    *> Feature.expectNotPresented (XPath.anywhere $ XPath.nodeWithExactText XPath.any name)

shareFile ∷ String → SlamFeature Unit
shareFile name = do
  Feature.click (XPath.anywhere $ XPaths.selectFile name)
  tryRepeatedlyTo $ clickShareFile <|> clickShareWorkspace
  where
  clickShareFile =
    Feature.clickNotRepeatedly (XPath.anywhere $ XPaths.shareFile name)
  clickShareWorkspace =
    Feature.clickNotRepeatedly (XPath.anywhere $ XPaths.shareFile $ name <> ".slam")

renameFile ∷ String → String → SlamFeature Unit
renameFile oldName newName = do
  selectFile oldName
  clickMove oldName
  Feature.provideFieldValueWithProperties
    (Map.singleton "value" $ Just oldName)
    (XPath.anywhere "input")
    newName
  Feature.click $ XPath.anywhere XPaths.renameButton
  where
  oldWorkspaceName = oldName <> ".slam"

moveFile ∷ String → String → String → SlamFeature Unit
moveFile fileName oldLocation newLocation = do
  selectFile fileName
  clickMove fileName
  Feature.click $ XPath.anywhere XPaths.selectADestinationFolder
  Feature.click $ XPath.anywhere $ XPath.anyWithExactText newLocation
  Feature.click $ XPath.anywhere XPaths.renameButton

clickMove ∷ String → SlamFeature Unit
clickMove name =
  tryRepeatedlyTo $ clickMoveFile <|> clickMoveWorkspace
  where
  clickMoveFile =
    Feature.clickNotRepeatedly $ XPath.anywhere $ XPaths.moveFile name
  clickMoveWorkspace =
    Feature.clickNotRepeatedly $ XPath.anywhere $ XPaths.moveFile $ name <> ".slam"

uploadFile ∷ String → SlamFeature Unit
uploadFile =
  Feature.provideFileInputValue (XPath.anywhere $ XPaths.uploadFile)
    <=< appendToCwd

provideFileSearchString ∷ String → SlamFeature Unit
provideFileSearchString value =
  Feature.provideFieldValue (XPath.anywhere XPaths.fileSearchInput) value

selectFile ∷ String → SlamFeature Unit
selectFile name =
  tryRepeatedlyTo (selectFile' <|> selectWorkspace)
  where
  selectFile' =
    Feature.clickNotRepeatedly $ XPath.anywhere $ XPaths.selectFile name
  selectWorkspace =
    Feature.clickNotRepeatedly $ XPath.anywhere $ XPaths.selectFile $ name <> ".slam"

createWorkspaceInTestFolder ∷ String → SlamFeature Unit
createWorkspaceInTestFolder name = do
  browseTestFolder
  createWorkspace
  nameDeck name
  browseTestFolder
  renameFile "Untitled Workspace" name
  accessFile $ name <> ".slam"

createFolder ∷ SlamFeature Unit
createFolder = Feature.click $ XPath.anywhere XPaths.createFolder

deleteFileInTestFolder ∷ String → SlamFeature Unit
deleteFileInTestFolder name = browseTestFolder *> deleteFile name

reopenCurrentWorkspace ∷ SlamFeature Unit
reopenCurrentWorkspace = waitTime 2000 *> refresh

expandNewCardMenu ∷ SlamFeature Unit
expandNewCardMenu = Feature.click (XPath.anywhere XPaths.insertCard)

accessNextCardInLastDeck ∷ SlamFeature Unit
accessNextCardInLastDeck =
  Feature.dragAndDrop
    (XPath.last $ XPath.anywhere $ XPaths.enabledNextCardGripper)
    (XPath.last $ XPath.anywhere $ XPaths.previousCardGripper)

accessPreviousCardInLastDeck ∷ SlamFeature Unit
accessPreviousCardInLastDeck =
  Feature.dragAndDrop
    (XPath.last $ XPath.anywhere $ XPaths.enabledPreviousCardGripper)
    (XPath.last $ XPath.anywhere $ XPaths.nextCardGripper)

insertSearchCardInLastDeck ∷ SlamFeature Unit
insertSearchCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertSearchCard

insertQueryCardInLastDeck ∷ SlamFeature Unit
insertQueryCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertQueryCard

insertMdCardInLastDeck ∷ SlamFeature Unit
insertMdCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertMdCard

insertOpenCardInLastDeck ∷ SlamFeature Unit
insertOpenCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertOpenCard

insertChartOptionsCardInLastDeck ∷ SlamFeature Unit
insertChartOptionsCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertChartOptionsCard

insertDisplayMarkdownCardInLastDeck ∷ SlamFeature Unit
insertDisplayMarkdownCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertDisplayMarkdownCard

insertTableCardInLastDeck ∷ SlamFeature Unit
insertTableCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertTableCard

insertChartCardInLastDeck ∷ SlamFeature Unit
insertChartCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertChartCard

insertCacheCardInLastDeck ∷ SlamFeature Unit
insertCacheCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertCacheCard

insertVariablesCardInLastDeck ∷ SlamFeature Unit
insertVariablesCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertVariablesCard

insertTroubleshootCardInLastDeck ∷ SlamFeature Unit
insertTroubleshootCardInLastDeck =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertTroubleshootCard

selectBuildChart ∷ SlamFeature Unit
selectBuildChart =
  Feature.click $ followingLastPreviousCardGripper XPaths.selectBuildChart

insertPivotCard ∷ SlamFeature Unit
insertPivotCard =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertPivotCard

insertBuildBarChartCard ∷ SlamFeature Unit
insertBuildBarChartCard =
  Feature.click $ followingLastPreviousCardGripper XPaths.insertBuildBarChartCard

addColumn ∷ String → SlamFeature Unit
addColumn str = do
  Feature.click $ XPath.last $ XPath.anywhere $ XPath.anyWithExactAriaLabel "Add column"
  Feature.click $ XPath.last $ XPath.anywhere $ XPath.anyWithExactAriaLabel $ "Select " ⊕ str
  Feature.click $ XPath.last $ XPath.anywhere $ XPath.anyWithExactText "Confirm"

selectInMillerColumns ∷ Array String → SlamFeature Unit
selectInMillerColumns ps = do
  for_ (enumerate $ Arr.filter (\s → S.length s > 0) ps) \(ix × path) →
    Feature.click $ resourceXPath (ix + one) path
  where
  ariaLabel ∷ String → String
  ariaLabel rPath = "Select " ⊕ rPath

  resourceXPath ∷ Int → String → String
  resourceXPath ix rPath =
    XPath.last
      $ XPath.anywhere
      $ (XPath.nodeAtPosition ix $ XPath.anyWithExactAriaLabel "Column")
      ⊕ XPath.descendantString
      ⊕ (XPath.anyWithExactAriaLabel $ ariaLabel rPath)

selectFileForLastOpenCard ∷ String → SlamFeature Unit
selectFileForLastOpenCard s =
  selectInMillerColumns $ S.split (S.Pattern "/") s

selectInChartBuilder ∷ Array String → SlamFeature Unit
selectInChartBuilder ps = do
  selectInMillerColumns ps
  Feature.click $ XPath.last $ XPath.anywhere $ XPath.anyWithExactText "Confirm"

provideSearchStringInLastSearchCard ∷ String → SlamFeature Unit
provideSearchStringInLastSearchCard =
  Feature.provideFieldValue $ XPath.last $ XPath.anywhere XPaths.searchStringInput

provideMdInLastMdCard ∷ String → SlamFeature Unit
provideMdInLastMdCard =
  Feature.provideFieldValue
    $ XPath.last $ XPath.anywhere XPaths.aceEditor

provideQueryInLastQueryCard ∷ String → SlamFeature Unit
provideQueryInLastQueryCard =
  Feature.provideFieldValue
    $ XPath.last $ XPath.anywhere XPaths.aceEditor

provideSaveDestinationInLastCacheCard ∷ String → SlamFeature Unit
provideSaveDestinationInLastCacheCard =
  Feature.provideFieldValue (XPath.last $ XPath.anywhere XPaths.saveDestinationInput)

doSaveInLastCacheCard ∷ SlamFeature Unit
doSaveInLastCacheCard =
  Feature.click (XPath.last $ XPath.anywhere XPaths.saveSubmitButton)

provideFieldValueInLastDeck ∷ String → String → SlamFeature Unit
provideFieldValueInLastDeck labelText =
  Feature.provideFieldValue
    $ followingLastPreviousCardGripper
    $ "input" `XPath.withLabelWithExactText` labelText

checkFieldInLastDeck ∷ String → SlamFeature Unit
checkFieldInLastDeck labelText =
  Feature.check
    $ followingLastPreviousCardGripper
    $ "input" `XPath.withLabelWithExactText` labelText

uncheckFieldInLastDeck ∷ String → SlamFeature Unit
uncheckFieldInLastDeck labelText =
  Feature.uncheck
    $ followingLastPreviousCardGripper
    $ "input" `XPath.withLabelWithExactText` labelText

pushRadioButtonInLastDeck ∷ String → SlamFeature Unit
pushRadioButtonInLastDeck labelText =
  Feature.pushRadioButton
    $ followingLastPreviousCardGripper
    $ "input" `XPath.withLabelWithExactText` labelText

selectFromDropdownInLastDeck ∷ String → String → SlamFeature Unit
selectFromDropdownInLastDeck labelText =
  Feature.selectFromDropdown
    $ followingLastPreviousCardGripper
    $ "select" `XPath.withLabelWithExactText` labelText

accessSharingUrl ∷ SlamFeature Unit
accessSharingUrl = Feature.accessUrlFromFieldValue $ XPath.anywhere XPaths.sharingUrl

accessPublishingUrl ∷ SlamFeature Unit
accessPublishingUrl = Feature.accessUrlFromFieldValue $ XPath.anywhere XPaths.publishingUrl

downloadFileAsCSV ∷ String → SlamFeature Unit
downloadFileAsCSV fileName = do
  selectFile fileName
  Feature.click $ XPath.anywhere $ XPaths.downloadFile fileName
  Feature.click $ XPath.anywhere $ XPaths.downloadButton
  Feature.click $ XPath.anywhere $ XPaths.cancelButton

downloadFileAsJSON ∷ String → SlamFeature Unit
downloadFileAsJSON fileName = do
  selectFile fileName
  Feature.click $ XPath.anywhere $ XPaths.downloadFile fileName
  Feature.click $ XPath.anywhere $ XPath.anyWithText "JSON"
  Feature.click $ XPath.anywhere $ XPaths.downloadButton
  Feature.click $ XPath.anywhere $ XPaths.cancelButton

showHiddenFiles ∷ SlamFeature Unit
showHiddenFiles =
  Feature.click $ XPath.anywhere $ XPaths.showHiddenFiles

hideHiddenFiles ∷ SlamFeature Unit
hideHiddenFiles =
  Feature.click $ XPath.anywhere $ XPaths.hideHiddenFiles

type ApiVarName = String
type ApiVarType = String
type ApiVarValue = String

provideApiVariableBindingsForVariablesCard
  ∷ ApiVarName
  → ApiVarType
  → ApiVarValue
  → SlamFeature Unit
provideApiVariableBindingsForVariablesCard name ty val = do
  provideValueForVariablesCard
  provideTypeForVariablesCard
  provideDefaultValueForVariablesCard
  where
  provideValueForVariablesCard ∷ SlamFeature Unit
  provideValueForVariablesCard = do
    Feature.provideFieldValue
      (XPath.first $ XPath.anywhere $ XPaths.variablesCardVariableName)
      name
    Feature.pressEnter
  provideTypeForVariablesCard ∷ SlamFeature Unit
  provideTypeForVariablesCard = do
    Feature.selectFromDropdown
      (XPath.first $ XPath.anywhere $ XPaths.variablesCardVariableTypeFor name)
      ty
    Feature.pressEnter

  provideDefaultValueForVariablesCard ∷ SlamFeature Unit
  provideDefaultValueForVariablesCard = do
    Feature.provideFieldValue
      (XPath.first $ XPath.anywhere $ XPaths.variablesCardDefaultValueFor name)
      val
    Feature.pressEnter

activateCategoryForChartBuilder ∷ SlamFeature Unit
activateCategoryForChartBuilder =
  Feature.click $ XPath.last $ XPath.anywhere $ XPaths.chartCategorySelector

activateStackForChartBuilder ∷ SlamFeature Unit
activateStackForChartBuilder =
  Feature.click $ XPath.last $ XPath.anywhere $ XPaths.chartStackSelector

flipDeck ∷ SlamFeature Unit
flipDeck =
  Feature.click $ XPath.anywhere $ XPath.anyWithExactAriaLabel "Flip deck"

trashActiveOrLastCard ∷ SlamFeature Unit
trashActiveOrLastCard =
  Feature.click $ XPath.anywhere $ XPath.anyWithExactAriaLabel "Delete card"

shareDeck ∷ SlamFeature Unit
shareDeck =
  Feature.click $ XPath.anywhere $ XPath.anyWithExactAriaLabel "Share deck"

publishDeck ∷ SlamFeature Unit
publishDeck =
  Feature.click $ XPath.anywhere $ XPath.anyWithExactAriaLabel "Publish deck"

filterDeckAndCardActions ∷ String → SlamFeature Unit
filterDeckAndCardActions =
  Feature.provideFieldValue (XPath.anywhere $ XPath.anyWithExactAriaLabel "Filter deck and card actions")

filterNextActions ∷ String → SlamFeature Unit
filterNextActions =
  Feature.provideFieldValue (XPath.anywhere $ XPath.anyWithExactAriaLabel "Filter next actions")

confirmDeckAction ∷ SlamFeature Unit
confirmDeckAction =
  Feature.click $ XPath.anywhere $ XPath.anyWithExactText "Confirm"

runQuery ∷ SlamFeature Unit
runQuery =
  Feature.click $ XPath.last $ XPath.anywhere $ XPath.anyWithExactAriaLabel "Run query"

setVarMapForDeck ∷ String → SM.StrMap String → SlamFeature Unit
setVarMapForDeck deckName vm = accessWorkspaceWithModifiedURL \urlStr →
  let
    varsValue =
      encodeURIComponent
      $ prettyJson
      $ encodeJson
      $ SM.singleton deckName vm
  in
   urlStr ⊕ "/?vars=" ⊕ varsValue


Add some comments for `EvalSpec` stuff

Add some comments for `EvalSpec` stuff

module Halogen.Component
  ( Component
  , ComponentSpec
  , mkComponent
  , unComponent
  , hoist
  , EvalSpec
  , mkEval
  , defaultEval
  , ComponentSlotBox
  , ComponentSlot(..)
  , componentSlot
  , ComponentSlotSpec
  , mkComponentSlot
  , unComponentSlot
  , hoistSlot
  ) where

import Prelude

import Data.Bifunctor (class Bifunctor, lmap)
import Data.Coyoneda (unCoyoneda)
import Data.Foldable (traverse_)
import Data.Maybe (Maybe(..), maybe)
import Data.Symbol (class IsSymbol, SProxy)
import Data.Tuple (Tuple)
import Halogen.Data.Slot (Slot, SlotStorage)
import Halogen.Data.Slot as Slot
import Halogen.Query.HalogenM (HalogenM)
import Halogen.Query.HalogenM as HM
import Halogen.Query.HalogenQ (HalogenQ(..))
import Halogen.VDom.Thunk (Thunk)
import Halogen.VDom.Thunk as Thunk
import Prim.Row as Row
import Unsafe.Coerce (unsafeCoerce)

-- | The "public" type for a component, with details of the component internals
-- | existentially hidden.
-- |
-- | - `surface` is the type that will be rendered by the component, usually
-- |   `HTML`
-- | - `query` is the query algebra; the requests that can be made of the
-- |   component
-- | - `input` is the input value that will be received when the parent of
-- |   this component renders
-- | - `output` is the type of messages the component can raise
-- | - `m` is the effect monad used during evaluation
data Component
  (surface :: Type -> Type -> Type)
  (query :: Type -> Type)
  (input :: Type)
  (output :: Type)
  (m :: Type -> Type)

-- | The spec for a component.
-- |
-- | The type variables involved:
-- | - `surface` is the type that will be rendered by the component, usually
-- |   `HTML`
-- | - `state` is the component's state
-- | - `query` is the query algebra; the requests that can be made of the
-- |   component
-- | - `action` is the type of actions; messages internal to the component that
-- |   can be evaluated
-- | - `slots` is the set of slots for addressing child components
-- | - `input` is the input value that will be received when the parent of
-- |   this component renders
-- | - `output` is the type of messages the component can raise
-- | - `m` is the effect monad used during evaluation
-- |
-- | The values in the record:
-- | - `initialState` is a function that accepts an input value and produces the
-- |   state the component will start with. If the input value is unused
-- |   (`Unit`), or irrelevant to the state construction, this will often be
-- |   `const ?someInitialStateValue`.
-- | - `render` is a function that accepts the component's current state and
-- |   produces a value to render (`HTML` usually). The rendered output can
-- |   raise actions that will be handled in `eval`.
-- | - `eval` is a function that handles the `HalogenQ` algebra that deals with
-- |   component lifecycle, handling actions, and responding to requests.
type ComponentSpec surface state query action slots input output m =
  { initialState :: input -> state
  , render :: state -> surface (ComponentSlot surface slots m action) action
  , eval :: HalogenQ query action input ~> HalogenM state action slots output m
  }

-- | Constructs a [`Component`](#t:Component) from a [`ComponentSpec`](#t:ComponentSpec).
mkComponent
  :: forall surface state query action slots input output m
   . ComponentSpec surface state query action slots input output m
  -> Component surface query input output m
mkComponent = unsafeCoerce

-- | Exposes the inner details of a [`Component`](#t:Component) to a function
-- | to produce a new result.
-- |
-- | The hidden details will not be allowed to be revealed in the result
-- | of the function - if any of the hidden types (state, action, set of slots)
-- | appear in the result, the compiler will complain about an escaped skolem.
unComponent
  :: forall surface query input output m a
   . (forall state action slots. ComponentSpec surface state query action slots input output m -> a)
  -> Component surface query input output m
  -> a
unComponent = unsafeCoerce

-- | Changes the [`Component`](#t:Component)'s `m` type. A use case for this
-- | might be to interpret some `Free` monad as `Aff` so the component can be
-- | used with `runUI`.
hoist
  :: forall surface query input output m m'
   . Bifunctor surface
  => Functor m'
  => (m ~> m')
  -> Component surface query input output m
  -> Component surface query input output m'
hoist nat = unComponent \c ->
  mkComponent
    { initialState: c.initialState
    , render: lmap (hoistSlot nat) <<< c.render
    , eval: HM.hoist nat <<< c.eval
    }

-- | The spec record that `mkEval` accepts to construct a component `eval`
-- | function.
-- |
-- | It's not a requirement to use `mkEval`, and sometimes it's preferrable
-- | to write a component `eval` function from scratch, but often `mkEval` is
-- | more convenient for common cases.
-- |
-- | See below for more details about `mkEval` and `defaultEval`.
type EvalSpec state query action slots input output m =
  { handleAction :: action -> HalogenM state action slots output m Unit
  , handleQuery :: forall a. query a -> HalogenM state action slots output m (Maybe a)
  , receive :: input -> Maybe action
  , initialize :: Maybe action
  , finalize :: Maybe action
  }

-- | A default value for `mkEval` that will result in an `eval` that nothing at
-- | all - all incoming actions and queries will be ignored, and no receiver,
-- | initializer, or finalizer will be specified.
-- |
-- | Usually this will be used with record update syntax to override fields to
-- | specify things as needed. If a component only needs to handle actions,
-- | for instance, a usage might be something like this:
-- |
-- | ``` purescript
-- | H.mkComponent
-- |   { initialState
-- |   , render
-- |   , eval: H.mkEval (H.defaultEval { handleAction = ?handleAction })
-- |   }
-- | ```
defaultEval :: forall state query action slots input output m. EvalSpec state query action slots input output m
defaultEval =
  { handleAction: const (pure unit)
  , handleQuery: const (pure Nothing)
  , receive: const Nothing
  , initialize: Nothing
  , finalize: Nothing
  }

-- | Accepts an `EvalSpec` to produce an `eval` function for a component.
mkEval
  :: forall state query action slots input output m
   . EvalSpec state query action slots input output m
  -> HalogenQ query action input
  ~> HalogenM state action slots output m
mkEval args = case _ of
  Initialize a ->
    traverse_ args.handleAction args.initialize $> a
  Finalize a ->
    traverse_ args.handleAction args.finalize $> a
  Receive i a ->
    traverse_ args.handleAction (args.receive i) $> a
  Action action a ->
    args.handleAction action $> a
  Query req f ->
    unCoyoneda (\g → map (maybe (f unit) g) <<< args.handleQuery) req

-- | A slot for a child component in a component's rendered content.
data ComponentSlotBox
  (surface :: Type -> Type -> Type)
  (slots :: # Type)
  (m :: Type -> Type)
  (action :: Type)

instance functorComponentSlot :: Functor (ComponentSlotBox surface slots m) where
  map f = unComponentSlot \slot ->
    mkComponentSlot $ slot { output = map f <$> slot.output }

data ComponentSlot surface slots m action
  = ComponentSlot (ComponentSlotBox surface slots m action)
  | ThunkSlot (Thunk (surface (ComponentSlot surface slots m action)) action)

-- | Constructs a [`ComponentSlot`](#t:ComponentSlot).
-- |
-- | Takes:
-- | - the slot address label
-- | - the slot address index
-- | - the component for the slot
-- | - the input value to pass to the component
-- | - a function mapping outputs from the component to a query in the parent
componentSlot
  :: forall surface query input output slots m action label slot _1
   . Row.Cons label (Slot query output slot) _1 slots
  => IsSymbol label
  => Ord slot
  => SProxy label
  -> slot
  -> Component surface query input output m
  -> input
  -> (output -> Maybe action)
  -> ComponentSlotBox surface slots m action
componentSlot label p comp input output =
  mkComponentSlot
    { get: Slot.lookup label p
    , pop: Slot.pop label p
    , set: Slot.insert label p
    , component: comp
    , input: Receive input unit
    , output
    }

-- | The internal representation used for a [`ComponentSlot`](#t:ComponentSlot).
type ComponentSlotSpec surface query input output slots m action =
  { get :: forall slot. SlotStorage slots slot -> Maybe (slot query output)
  , pop :: forall slot. SlotStorage slots slot -> Maybe (Tuple (slot query output) (SlotStorage slots slot))
  , set :: forall slot. slot query output -> SlotStorage slots slot -> SlotStorage slots slot
  , component :: Component surface query input output m
  , input :: forall a. HalogenQ query a input Unit
  , output :: output -> Maybe action
  }

-- | Constructs [`ComponentSlotBox`](#t:ComponentSlot) from a [`ComponentSlotSpec`](#t:ComponentSlotSpec).
mkComponentSlot
  :: forall surface query input output slots m action
   . ComponentSlotSpec surface query input output slots m action
  -> ComponentSlotBox surface slots m action
mkComponentSlot = unsafeCoerce

-- | Exposes the inner details of a [`ComponentSlot`](#t:ComponentSlot) to a
-- | function to produce a new result.
-- |
-- |  The hidden details will not be allowed to be revealed in the result
-- | of the function - if any of the hidden types (state, action, set of slots)
-- | appear in the result, the compiler will complain about an escaped skolem.
unComponentSlot
  :: forall surface slots m action a
   . (forall query input output. ComponentSlotSpec surface query input output slots m action -> a)
  -> ComponentSlotBox surface slots m action
  -> a
unComponentSlot = unsafeCoerce

-- | Changes the [`ComponentSlot`](#t:ComponentSlot)'s `m` type.
hoistSlot
  :: forall surface slots m m' action
   . Bifunctor surface
  => Functor m'
  => (m ~> m')
  -> ComponentSlot surface slots m action
  -> ComponentSlot surface slots m' action
hoistSlot nat = case _ of
  ComponentSlot cs ->
    cs # unComponentSlot \slot ->
      ComponentSlot $ mkComponentSlot $ slot { component = hoist nat slot.component }
  ThunkSlot t ->
    ThunkSlot $ Thunk.hoist (lmap (hoistSlot nat)) t

module Halogen.Component
  ( Component
  , ComponentSpec
  , EvalSpec
  , mkEval
  , defaultEval
  , mkComponent
  , unComponent
  , hoist
  , ComponentSlotBox
  , ComponentSlot(..)
  , componentSlot
  , ComponentSlotSpec
  , mkComponentSlot
  , unComponentSlot
  , hoistSlot
  ) where

import Prelude

import Data.Bifunctor (class Bifunctor, lmap)
import Data.Coyoneda (unCoyoneda)
import Data.Foldable (traverse_)
import Data.Maybe (Maybe(..), maybe)
import Data.Symbol (class IsSymbol, SProxy)
import Data.Tuple (Tuple)
import Halogen.Data.Slot (Slot, SlotStorage)
import Halogen.Data.Slot as Slot
import Halogen.Query.HalogenM (HalogenM)
import Halogen.Query.HalogenM as HM
import Halogen.Query.HalogenQ (HalogenQ(..))
import Halogen.VDom.Thunk (Thunk)
import Halogen.VDom.Thunk as Thunk
import Prim.Row as Row
import Unsafe.Coerce (unsafeCoerce)

-- | The "public" type for a component, with details of the component internals
-- | existentially hidden.
-- |
-- | - `surface` is the type that will be rendered by the component, usually
-- |   `HTML`
-- | - `query` is the query algebra; the requests that can be made of the
-- |   component
-- | - `input` is the input value that will be received when the parent of
-- |   this component renders
-- | - `output` is the type of messages the component can raise
-- | - `m` is the effect monad used during evaluation
data Component
  (surface :: Type -> Type -> Type)
  (query :: Type -> Type)
  (input :: Type)
  (output :: Type)
  (m :: Type -> Type)

-- | The spec for a component.
-- |
-- | The type variables involved:
-- | - `surface` is the type that will be rendered by the component, usually
-- |   `HTML`
-- | - `state` is the component's state
-- | - `query` is the query algebra; the requests that can be made of the
-- |   component
-- | - `action` is the type of actions; messages internal to the component that
-- |   can be evaluated
-- | - `slots` is the set of slots for addressing child components
-- | - `input` is the input value that will be received when the parent of
-- |   this component renders
-- | - `output` is the type of messages the component can raise
-- | - `m` is the effect monad used during evaluation
-- |
-- | The values in the record:
-- | - `initialState` is a function that accepts an input value and produces the
-- |   state the component will start with. If the input value is unused
-- |   (`Unit`), or irrelevant to the state construction, this will often be
-- |   `const ?someInitialStateValue`.
-- | - `render` is a function that accepts the component's current state and
-- |   produces a value to render (`HTML` usually). The rendered output can
-- |   raise actions that will be handled in `eval`.
-- | - `eval` is a function that handles the `HalogenQ` algebra that deals with
-- |   component lifecycle, handling actions, and responding to requests.
type ComponentSpec surface state query action slots input output m =
  { initialState :: input -> state
  , render :: state -> surface (ComponentSlot surface slots m action) action
  , eval :: HalogenQ query action input ~> HalogenM state action slots output m
  }

type EvalSpec state query action slots input output m =
  { handleAction :: action -> HalogenM state action slots output m Unit
  , handleQuery :: forall a. query a -> HalogenM state action slots output m (Maybe a)
  , receive :: input -> Maybe action
  , initialize :: Maybe action
  , finalize :: Maybe action
  }

mkEval
  :: forall state query action slots input output m
   . EvalSpec state query action slots input output m
  -> HalogenQ query action input
  ~> HalogenM state action slots output m
mkEval args = case _ of
  Initialize a ->
    traverse_ args.handleAction args.initialize $> a
  Finalize a ->
    traverse_ args.handleAction args.finalize $> a
  Receive i a ->
    traverse_ args.handleAction (args.receive i) $> a
  Action action a ->
    args.handleAction action $> a
  Query req f ->
    unCoyoneda (\g → map (maybe (f unit) g) <<< args.handleQuery) req

defaultEval
  :: forall state query action slots input output m
   . EvalSpec state query action slots input output m
defaultEval =
  { handleAction: const (pure unit)
  , handleQuery: const (pure Nothing)
  , receive: const Nothing
  , initialize: Nothing
  , finalize: Nothing
  }

-- | Constructs a [`Component`](#t:Component) from a [`ComponentSpec`](#t:ComponentSpec).
mkComponent
  :: forall surface state query action slots input output m
   . ComponentSpec surface state query action slots input output m
  -> Component surface query input output m
mkComponent = unsafeCoerce

-- | Exposes the inner details of a [`Component`](#t:Component) to a function
-- | to produce a new result.
-- |
-- | The hidden details will not be allowed to be revealed in the result
-- | of the function - if any of the hidden types (state, action, set of slots)
-- | appear in the result, the compiler will complain about an escaped skolem.
unComponent
  :: forall surface query input output m a
   . (forall state action slots. ComponentSpec surface state query action slots input output m -> a)
  -> Component surface query input output m
  -> a
unComponent = unsafeCoerce

-- | Changes the [`Component`](#t:Component)'s `m` type. A use case for this
-- | might be to interpret some `Free` monad as `Aff` so the component can be
-- | used with `runUI`.
hoist
  :: forall surface query input output m m'
   . Bifunctor surface
  => Functor m'
  => (m ~> m')
  -> Component surface query input output m
  -> Component surface query input output m'
hoist nat = unComponent \c ->
  mkComponent
    { initialState: c.initialState
    , render: lmap (hoistSlot nat) <<< c.render
    , eval: HM.hoist nat <<< c.eval
    }

-- | A slot for a child component in a component's rendered content.
data ComponentSlotBox
  (surface :: Type -> Type -> Type)
  (slots :: # Type)
  (m :: Type -> Type)
  (action :: Type)

instance functorComponentSlot :: Functor (ComponentSlotBox surface slots m) where
  map f = unComponentSlot \slot ->
    mkComponentSlot $ slot { output = map f <$> slot.output }

data ComponentSlot surface slots m action
  = ComponentSlot (ComponentSlotBox surface slots m action)
  | ThunkSlot (Thunk (surface (ComponentSlot surface slots m action)) action)

-- | Constructs a [`ComponentSlot`](#t:ComponentSlot).
-- |
-- | Takes:
-- | - the slot address label
-- | - the slot address index
-- | - the component for the slot
-- | - the input value to pass to the component
-- | - a function mapping outputs from the component to a query in the parent
componentSlot
  :: forall surface query input output slots m action label slot _1
   . Row.Cons label (Slot query output slot) _1 slots
  => IsSymbol label
  => Ord slot
  => SProxy label
  -> slot
  -> Component surface query input output m
  -> input
  -> (output -> Maybe action)
  -> ComponentSlotBox surface slots m action
componentSlot label p comp input output =
  mkComponentSlot
    { get: Slot.lookup label p
    , pop: Slot.pop label p
    , set: Slot.insert label p
    , component: comp
    , input: Receive input unit
    , output
    }

-- | The internal representation used for a [`ComponentSlot`](#t:ComponentSlot).
type ComponentSlotSpec surface query input output slots m action =
  { get :: forall slot. SlotStorage slots slot -> Maybe (slot query output)
  , pop :: forall slot. SlotStorage slots slot -> Maybe (Tuple (slot query output) (SlotStorage slots slot))
  , set :: forall slot. slot query output -> SlotStorage slots slot -> SlotStorage slots slot
  , component :: Component surface query input output m
  , input :: forall a. HalogenQ query a input Unit
  , output :: output -> Maybe action
  }

-- | Constructs [`ComponentSlotBox`](#t:ComponentSlot) from a [`ComponentSlotSpec`](#t:ComponentSlotSpec).
mkComponentSlot
  :: forall surface query input output slots m action
   . ComponentSlotSpec surface query input output slots m action
  -> ComponentSlotBox surface slots m action
mkComponentSlot = unsafeCoerce

-- | Exposes the inner details of a [`ComponentSlot`](#t:ComponentSlot) to a
-- | function to produce a new result.
-- |
-- |  The hidden details will not be allowed to be revealed in the result
-- | of the function - if any of the hidden types (state, action, set of slots)
-- | appear in the result, the compiler will complain about an escaped skolem.
unComponentSlot
  :: forall surface slots m action a
   . (forall query input output. ComponentSlotSpec surface query input output slots m action -> a)
  -> ComponentSlotBox surface slots m action
  -> a
unComponentSlot = unsafeCoerce

-- | Changes the [`ComponentSlot`](#t:ComponentSlot)'s `m` type.
hoistSlot
  :: forall surface slots m m' action
   . Bifunctor surface
  => Functor m'
  => (m ~> m')
  -> ComponentSlot surface slots m action
  -> ComponentSlot surface slots m' action
hoistSlot nat = case _ of
  ComponentSlot cs ->
    cs # unComponentSlot \slot ->
      ComponentSlot $ mkComponentSlot $ slot { component = hoist nat slot.component }
  ThunkSlot t ->
    ThunkSlot $ Thunk.hoist (lmap (hoistSlot nat)) t