Nicer names for the Elm encoding helpers

Original commit 3f226e67b37076ba94e27df11666beb4bee209e4

module Elm
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude

import Data.Array as A
import Data.Char.Unicode (isLetter)
import Data.Foldable (for_, intercalate)
import Data.List (List, (:))
import Data.List as L
import Data.Map as Map
import Data.Maybe (Maybe(..), maybe)
import Data.Set (Set)
import Data.Set as S
import Data.String as Str
import Data.String.Util (capitalize, decapitalize, camelCase, stringEscape)
import Data.Tuple (Tuple(..), fst)
import Utils (forEnumerated_, removeElement, sortByKey, sortByKeyM)

forbiddenNames :: Array String
forbiddenNames =
    [ "if", "then", "else"
    , "case", "of"
    , "let", "in"
    , "type"
    , "module", "where"
    , "import", "exposing"
    , "as"
    , "port"
    , "int", "float", "bool", "string"
    , "Jenc", "Jdec", "Jpipe"
    , "always", "identity"
    , "Array", "Dict", "Maybe", "map", "toList"
    , "makeArrayEncoder", "makeDictEncoder", "makeNullableEncoder"
    ]

forbiddenPropertyNames :: Set String
forbiddenPropertyNames = S.fromFoldable forbiddenNames

renderer :: Renderer
renderer =
    { name: "Elm"
    , aceMode: "elm"
    , extension: "elm"
    , doc: elmDoc
    , transforms:
        { nameForClass: elmNamer nameForClass
        , unionName: Just $ elmNamer unionName
        , unionPredicate: Just unionPredicate
        , nextName: \s -> "Other" <> s
        , forbiddenNames
        , topLevelNameFromGiven: const "Root"
        , forbiddenFromTopLevelNameGiven
        }
    }

decoderNameFromTypeName :: String -> String
decoderNameFromTypeName = decapitalize

encoderNameFromTypeName :: String -> String
encoderNameFromTypeName className = "encode" <> className

alsoForbiddenForTypeName :: String -> Array String
alsoForbiddenForTypeName n = [decoderNameFromTypeName n, encoderNameFromTypeName n]

elmNamer :: forall a. Ord a => (a -> String) -> a -> Maybe String -> NamingResult
elmNamer namer thing = case _ of
    Just name -> result name
    Nothing -> result $ namer thing
    where
        result name = { name, forbidAlso: alsoForbiddenForTypeName name }

nameForClass :: IRClassData -> String
nameForClass (IRClassData { names }) = upperNameStyle $ combineNames names

unionName :: L.List String -> String
unionName s =
    L.sort s
    <#> upperNameStyle
    # intercalate "Or"

unionPredicate :: IRType -> Maybe (Set IRType)
unionPredicate = case _ of
    IRUnion ur ->
        let s = unionToSet ur
        in case nullableFromSet s of
            Nothing -> Just s
            _ -> Nothing
    _ -> Nothing

typeNameForTopLevelNameGiven :: String -> String
typeNameForTopLevelNameGiven = upperNameStyle

forbiddenFromTopLevelNameGiven :: String -> Array String
forbiddenFromTopLevelNameGiven given =
    let name = typeNameForTopLevelNameGiven given
    in A.cons name $ alsoForbiddenForTypeName name

isLetterCharacter :: Char -> Boolean
isLetterCharacter c =
    isLetter c || c == '_'

legalizeIdentifier :: Boolean -> String -> String
legalizeIdentifier upper str =
    case Str.charAt 0 str of
    Nothing -> "Empty"
    Just s ->
        if isLetter s then
            Str.fromCharArray $ map (\c -> if isLetterCharacter c then c else '_') $ Str.toCharArray str
        else
            legalizeIdentifier upper ((if upper then "F_" else "f_") <> str)

lowerNameStyle :: String -> String
lowerNameStyle = camelCase >>> decapitalize >>> (legalizeIdentifier false)

upperNameStyle :: String -> String
upperNameStyle = camelCase >>> capitalize >>> (legalizeIdentifier true)

renderComment :: Maybe String -> String
renderComment (Just s) = " -- " <> s
renderComment Nothing = ""

elmDoc :: Doc Unit
elmDoc = do
    givenTopLevel <- upperNameStyle <$> getTopLevelNameGiven
    let topLevelDecoder = decoderNameFromTypeName givenTopLevel
    let topLevelEncoder = encoderNameFromTypeName givenTopLevel
    line """-- To decode the JSON data, add this file to your project, run
--
--     elm-package install NoRedInk/elm-decode-pipeline
--
-- add these imports
--
--    import Json.Decode exposing (decodeString)"""
    line $ "--    import " <> givenTopLevel <> " exposing (" <> topLevelDecoder <> ")"
    line """--
-- and you're off to the races with
--"""
    line $ "--     decodeString " <> topLevelDecoder <> " myJsonString"
    blank
    line $ "module " <> givenTopLevel <> " exposing (" <> givenTopLevel <> ", " <> topLevelDecoder <> ", " <> topLevelEncoder <> ")"
    blank
    line """import Json.Decode as Jdec
import Json.Decode.Pipeline as Jpipe
import Json.Encode as Jenc
import Array exposing (Array, map)
import Dict exposing (Dict, map, toList)

-- top level type
"""
    topLevel <- getTopLevel
    { rendered: topLevelRendered } <- typeStringForType topLevel
    line $ "type alias " <> givenTopLevel <> " = " <> topLevelRendered
    blank
    { rendered: rootDecoder } <- decoderNameForType topLevel
    line $ topLevelDecoder <> " : Jdec.Decoder " <> givenTopLevel
    line $ topLevelDecoder <> " = " <> rootDecoder
    blank
    { rendered: rootEncoder } <- encoderNameForType topLevel
    line $ topLevelEncoder <> " : " <> givenTopLevel <> " -> String"
    line $ topLevelEncoder <> " r = Jenc.encode 0 (" <> rootEncoder <> " r)"
    blank
    line "-- JSON types"
    classes <- getClasses
    unions <- getUnions
    for_ classes \(Tuple i cls) -> do
        blank
        typeRenderer renderTypeDefinition i cls
    for_ unions \types -> do
        blank
        renderUnionDefinition types
    blank
    line "-- decoders and encoders"
    for_ classes \(Tuple i cls) -> do
        blank
        typeRenderer renderTypeFunctions i cls
    for_ unions \types -> do
        blank
        renderUnionFunctions types
    blank
    line """--- encoder helpers

makeArrayEncoder : (a -> Jenc.Value) -> Array a -> Jenc.Value
makeArrayEncoder f arr =
    Jenc.array (Array.map f arr)

makeDictEncoder : (a -> Jenc.Value) -> Dict String a -> Jenc.Value
makeDictEncoder f dict =
    Jenc.object (toList (Dict.map (\k -> f) dict))

makeNullableEncoder : (a -> Jenc.Value) -> Maybe a -> Jenc.Value
makeNullableEncoder f m =
    case m of
    Just x -> f x
    Nothing -> Jenc.null"""

singleWord :: String -> Doc { rendered :: String, multiWord :: Boolean }
singleWord w = pure { rendered: w, multiWord: false }

multiWord :: String -> String -> Doc { rendered :: String, multiWord :: Boolean }
multiWord s1 s2 = pure { rendered: s1 <> " " <> s2, multiWord: true }

parenIfNeeded :: { rendered :: String, multiWord :: Boolean } -> String
parenIfNeeded { rendered, multiWord: false } = rendered
parenIfNeeded { rendered, multiWord: true } = "(" <> rendered <> ")"

typeStringForType :: IRType -> Doc { rendered :: String, multiWord :: Boolean }
typeStringForType = case _ of
    IRNothing -> singleWord "Jdec.Value"
    IRNull -> singleWord "()"
    IRInteger -> singleWord "Int"
    IRDouble -> singleWord "Float"
    IRBool -> singleWord "Bool"
    IRString -> singleWord "String"
    IRArray a -> do
        ts <- typeStringForType a
        multiWord "Array" $ parenIfNeeded ts
    IRClass i -> singleWord =<< lookupClassName i
    IRMap t -> do
        ts <- typeStringForType t
        multiWord "Dict String" $ parenIfNeeded ts
    IRUnion u ->
        let s = unionToSet u
        in case nullableFromSet s of
        Just x -> do
            ts <- typeStringForType x
            multiWord "Maybe" $ parenIfNeeded ts
        Nothing -> do
            singleWord =<< lookupUnionName s

unionConstructorName :: Set IRType -> IRType -> Doc String
unionConstructorName s t = do
    typeName <- upperNameStyle <$> getTypeNameForUnion t
    unionName <- lookupUnionName s
    pure $ typeName <> "In" <> unionName

decoderNameForType :: IRType -> Doc { rendered :: String, multiWord :: Boolean }
decoderNameForType = case _ of
    IRNothing -> singleWord "Jdec.value"
    IRNull -> multiWord "Jdec.null" "()"
    IRInteger -> singleWord "Jdec.int"
    IRDouble -> singleWord "Jdec.float"
    IRBool -> singleWord "Jdec.bool"
    IRString -> singleWord "Jdec.string"
    IRArray a -> do
        dn <- decoderNameForType a
        multiWord "Jdec.array" $ parenIfNeeded dn
    IRClass i -> singleWord =<< decoderNameFromTypeName <$> lookupClassName i
    IRMap t -> do
        dn <- decoderNameForType t
        multiWord "Jdec.dict" $ parenIfNeeded dn
    IRUnion u ->
        let s = unionToSet u
        in case nullableFromSet s of
        Just t -> do
            dn <- decoderNameForType t
            multiWord "Jdec.nullable" $ parenIfNeeded dn
        Nothing -> do
            singleWord =<< decoderNameFromTypeName <$> lookupUnionName s

encoderNameForType :: IRType -> Doc { rendered :: String, multiWord :: Boolean }
encoderNameForType = case _ of
    IRNothing -> singleWord "identity"
    IRNull -> multiWord "always" "Jenc.null"
    IRInteger -> singleWord "Jenc.int"
    IRDouble -> singleWord "Jenc.float"
    IRBool -> singleWord "Jenc.bool"
    IRString -> singleWord "Jenc.string"
    IRArray a -> do
        rendered <- encoderNameForType a
        multiWord "makeArrayEncoder" $ parenIfNeeded rendered
    IRClass i -> singleWord =<< encoderNameFromTypeName <$> lookupClassName i
    IRMap t -> do
        rendered <- encoderNameForType t
        multiWord "makeDictEncoder" $ parenIfNeeded rendered
    IRUnion u ->
        let s = unionToSet u
        in case nullableFromSet s of
        Just t -> do
            rendered <- encoderNameForType t
            multiWord "makeNullableEncoder" $ parenIfNeeded rendered
        Nothing ->
            singleWord =<< encoderNameFromTypeName <$> lookupUnionName s

forWithPrefix_ :: forall a b p m. Applicative m => List a -> p -> p -> (p -> a -> m b) -> m Unit
forWithPrefix_ l firstPrefix restPrefix f =
    forEnumerated_ l (\i -> f $ if i == 0 then firstPrefix else restPrefix)

isOptional :: IRType -> Boolean
isOptional = case _ of
    IRUnion u ->
        case nullableFromSet $ unionToSet u of
        Just t -> true
        Nothing -> false
    -- IRNull -> true
    -- IRUnion u -> S.member IRNull $ unionToSet u
    _ -> false

renderTypeDefinition :: Int -> String -> Map.Map String String -> List (Tuple String IRType) -> Doc Unit
renderTypeDefinition classIndex className propertyNames propsList = do
    line $ "type alias " <> className <> " ="
    indent do
        forWithPrefix_ propsList "{ " ", " \braceOrComma (Tuple pname ptype) -> do
            let propName = lookupName pname propertyNames
            { rendered } <- typeStringForType ptype
            line $ braceOrComma <> propName <> " : " <> rendered
        when (propsList == L.Nil) do
            line "{"
        line "}"

renderTypeFunctions :: Int -> String -> Map.Map String String -> List (Tuple String IRType) -> Doc Unit
renderTypeFunctions classIndex className propertyNames propsList = do
    let decoderName = decoderNameFromTypeName className
    line $ decoderName <> " : Jdec.Decoder " <> className
    line $ decoderName <> " ="
    indent do
        line $ "Jpipe.decode " <> className
        for_ propsList \(Tuple pname ptype) -> do
            indent do
                propDecoder <- decoderNameForType ptype
                let { reqOrOpt, fallback } = if isOptional ptype then { reqOrOpt: "Jpipe.optional", fallback: " Nothing" } else { reqOrOpt: "Jpipe.required", fallback: "" }
                line $ "|> " <> reqOrOpt <> " \"" <> stringEscape pname <> "\" " <> (parenIfNeeded propDecoder) <> fallback
    blank
    let encoderName = encoderNameFromTypeName className
    line $ encoderName <> " : " <> className <> " -> Jenc.Value"
    line $ encoderName <> " x ="
    indent do
        line "Jenc.object"
        indent do
            forWithPrefix_ propsList "[ " ", " \bracketOrComma (Tuple pname ptype) -> do
                let propName = lookupName pname propertyNames
                { rendered: propEncoder } <- encoderNameForType ptype
                line $ bracketOrComma <> "(\"" <> stringEscape pname <> "\", " <> propEncoder <> " x." <> propName <> ")"
        when (propsList == L.Nil) do
            line "["
        line "]"

typeRenderer :: (Int -> String -> Map.Map String String -> List (Tuple String IRType) -> Doc Unit) -> Int -> IRClassData -> Doc Unit
typeRenderer renderer classIndex (IRClassData { properties }) = do
    className <- lookupClassName classIndex
    let propertyNames = transformNames (simpleNamer lowerNameStyle) (\n -> "other" <> capitalize n) forbiddenPropertyNames $ map (\n -> Tuple n n) $ Map.keys properties
    let propsList = Map.toUnfoldable properties # sortByKey (\t -> lookupName (fst t) propertyNames)
    renderer classIndex className propertyNames propsList

renderUnionDefinition :: Set IRType -> Doc Unit
renderUnionDefinition allTypes = do
    unionName <- lookupUnionName allTypes
    fields <- L.fromFoldable allTypes # sortByKeyM (unionConstructorName allTypes)
    line $ "type " <> unionName
    forWithPrefix_ fields "=" "|" \equalsOrPipe t -> do
        indent do
            constructor <- unionConstructorName allTypes t
            when (t == IRNull) do
                line $ equalsOrPipe <> " " <> constructor
            unless (t == IRNull) do
                ts <- typeStringForType t
                line $ equalsOrPipe <> " " <> constructor <> " " <> (parenIfNeeded ts)

renderUnionFunctions :: Set IRType -> Doc Unit
renderUnionFunctions allTypes = do
    unionName <- lookupUnionName allTypes
    let decoderName = decoderNameFromTypeName unionName
    line $ decoderName <> " : Jdec.Decoder " <> unionName
    line $ decoderName <> " ="
    indent do
        let { element: maybeArray, rest: nonArrayFields } = removeElement isArray allTypes
        nonArrayDecFields <- L.fromFoldable nonArrayFields # sortByKeyM (unionConstructorName allTypes)
        let decFields = maybe nonArrayDecFields (\f -> f : nonArrayDecFields) maybeArray
        line "Jdec.oneOf"
        indent do
            forWithPrefix_ decFields "[" "," \bracketOrComma t -> do
                constructor <- unionConstructorName allTypes t
                when (t == IRNull) do
                    line $ bracketOrComma <> " Jdec.null " <> constructor
                unless (t == IRNull) do
                    decoder <- decoderNameForType t
                    line $ bracketOrComma <> " Jdec.map " <> constructor <> " " <> parenIfNeeded decoder
            line "]"
    blank
    let encoderName = encoderNameFromTypeName unionName
    line $ encoderName <> " : " <> unionName <> " -> Jenc.Value"
    line $ encoderName <> " x = case x of"
    indent do
        fields <- L.fromFoldable allTypes # sortByKeyM (unionConstructorName allTypes)
        for_ fields \t -> do
            constructor <- unionConstructorName allTypes t
            when (t == IRNull) do
                line $ constructor <> " -> Jenc.null"
            unless (t == IRNull) do
                { rendered: encoder } <- encoderNameForType t
                line $ constructor <> " y -> " <> encoder <> " y"

module Elm
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude

import Data.Array as A
import Data.Char.Unicode (isLetter)
import Data.Foldable (for_, intercalate)
import Data.List (List, (:))
import Data.List as L
import Data.Map as Map
import Data.Maybe (Maybe(..), maybe)
import Data.Set (Set)
import Data.Set as S
import Data.String as Str
import Data.String.Util (capitalize, decapitalize, camelCase, stringEscape)
import Data.Tuple (Tuple(..), fst)
import Utils (forEnumerated_, removeElement, sortByKey, sortByKeyM)

forbiddenNames :: Array String
forbiddenNames =
    [ "if", "then", "else"
    , "case", "of"
    , "let", "in"
    , "type"
    , "module", "where"
    , "import", "exposing"
    , "as"
    , "port"
    , "int", "float", "bool", "string"
    , "Jenc", "Jdec", "Jpipe"
    , "always", "identity"
    , "Array", "Dict", "Maybe", "map", "toList"
    ]

forbiddenPropertyNames :: Set String
forbiddenPropertyNames = S.fromFoldable forbiddenNames

renderer :: Renderer
renderer =
    { name: "Elm"
    , aceMode: "elm"
    , extension: "elm"
    , doc: elmDoc
    , transforms:
        { nameForClass: elmNamer nameForClass
        , unionName: Just $ elmNamer unionName
        , unionPredicate: Just unionPredicate
        , nextName: \s -> "Other" <> s
        , forbiddenNames
        , topLevelNameFromGiven: const "Root"
        , forbiddenFromTopLevelNameGiven
        }
    }

decoderNameFromTypeName :: String -> String
decoderNameFromTypeName = decapitalize

encoderNameFromTypeName :: String -> String
encoderNameFromTypeName className = "encode" <> className

alsoForbiddenForTypeName :: String -> Array String
alsoForbiddenForTypeName n = [decoderNameFromTypeName n, encoderNameFromTypeName n]

elmNamer :: forall a. Ord a => (a -> String) -> a -> Maybe String -> NamingResult
elmNamer namer thing = case _ of
    Just name -> result name
    Nothing -> result $ namer thing
    where
        result name = { name, forbidAlso: alsoForbiddenForTypeName name }

nameForClass :: IRClassData -> String
nameForClass (IRClassData { names }) = upperNameStyle $ combineNames names

unionName :: L.List String -> String
unionName s =
    L.sort s
    <#> upperNameStyle
    # intercalate "Or"

unionPredicate :: IRType -> Maybe (Set IRType)
unionPredicate = case _ of
    IRUnion ur ->
        let s = unionToSet ur
        in case nullableFromSet s of
            Nothing -> Just s
            _ -> Nothing
    _ -> Nothing

typeNameForTopLevelNameGiven :: String -> String
typeNameForTopLevelNameGiven = upperNameStyle

forbiddenFromTopLevelNameGiven :: String -> Array String
forbiddenFromTopLevelNameGiven given =
    let name = typeNameForTopLevelNameGiven given
    in A.cons name $ alsoForbiddenForTypeName name

isLetterCharacter :: Char -> Boolean
isLetterCharacter c =
    isLetter c || c == '_'

legalizeIdentifier :: Boolean -> String -> String
legalizeIdentifier upper str =
    case Str.charAt 0 str of
    Nothing -> "Empty"
    Just s ->
        if isLetter s then
            Str.fromCharArray $ map (\c -> if isLetterCharacter c then c else '_') $ Str.toCharArray str
        else
            legalizeIdentifier upper ((if upper then "F_" else "f_") <> str)

lowerNameStyle :: String -> String
lowerNameStyle = camelCase >>> decapitalize >>> (legalizeIdentifier false)

upperNameStyle :: String -> String
upperNameStyle = camelCase >>> capitalize >>> (legalizeIdentifier true)

renderComment :: Maybe String -> String
renderComment (Just s) = " -- " <> s
renderComment Nothing = ""

elmDoc :: Doc Unit
elmDoc = do
    givenTopLevel <- upperNameStyle <$> getTopLevelNameGiven
    let topLevelDecoder = decoderNameFromTypeName givenTopLevel
    let topLevelEncoder = encoderNameFromTypeName givenTopLevel
    line """-- To decode the JSON data, add this file to your project, run
--
--     elm-package install NoRedInk/elm-decode-pipeline
--
-- add these imports
--
--    import Json.Decode exposing (decodeString)"""
    line $ "--    import " <> givenTopLevel <> " exposing (" <> topLevelDecoder <> ")"
    line """--
-- and you're off to the races with
--"""
    line $ "--     decodeString " <> topLevelDecoder <> " myJsonString"
    blank
    line $ "module " <> givenTopLevel <> " exposing (" <> givenTopLevel <> ", " <> topLevelDecoder <> ", " <> topLevelEncoder <> ")"
    blank
    line """import Json.Decode as Jdec
import Json.Decode.Pipeline as Jpipe
import Json.Encode as Jenc
import Array exposing (Array, map)
import Dict exposing (Dict, map, toList)

-- top level type
"""
    topLevel <- getTopLevel
    { rendered: topLevelRendered } <- typeStringForType topLevel
    line $ "type alias " <> givenTopLevel <> " = " <> topLevelRendered
    blank
    { rendered: rootDecoder } <- decoderNameForType topLevel
    line $ topLevelDecoder <> " : Jdec.Decoder " <> givenTopLevel
    line $ topLevelDecoder <> " = " <> rootDecoder
    blank
    { rendered: rootEncoder } <- encoderNameForType topLevel
    line $ topLevelEncoder <> " : " <> givenTopLevel <> " -> String"
    line $ topLevelEncoder <> " r = Jenc.encode 0 (" <> rootEncoder <> " r)"
    blank
    line "-- JSON types"
    classes <- getClasses
    unions <- getUnions
    for_ classes \(Tuple i cls) -> do
        blank
        typeRenderer renderTypeDefinition i cls
    for_ unions \types -> do
        blank
        renderUnionDefinition types
    blank
    line "-- decoders and encoders"
    for_ classes \(Tuple i cls) -> do
        blank
        typeRenderer renderTypeFunctions i cls
    for_ unions \types -> do
        blank
        renderUnionFunctions types
    blank
    line """--- encoder helpers

array__enc : (a -> Jenc.Value) -> Array a -> Jenc.Value
array__enc f arr =
    Jenc.array (Array.map f arr)

dict__enc : (a -> Jenc.Value) -> Dict String a -> Jenc.Value
dict__enc f dict =
    Jenc.object (toList (Dict.map (\k -> f) dict))

nullable__enc : (a -> Jenc.Value) -> Maybe a -> Jenc.Value
nullable__enc f m =
    case m of
    Just x -> f x
    Nothing -> Jenc.null"""

singleWord :: String -> Doc { rendered :: String, multiWord :: Boolean }
singleWord w = pure { rendered: w, multiWord: false }

multiWord :: String -> String -> Doc { rendered :: String, multiWord :: Boolean }
multiWord s1 s2 = pure { rendered: s1 <> " " <> s2, multiWord: true }

parenIfNeeded :: { rendered :: String, multiWord :: Boolean } -> String
parenIfNeeded { rendered, multiWord: false } = rendered
parenIfNeeded { rendered, multiWord: true } = "(" <> rendered <> ")"

typeStringForType :: IRType -> Doc { rendered :: String, multiWord :: Boolean }
typeStringForType = case _ of
    IRNothing -> singleWord "Jdec.Value"
    IRNull -> singleWord "()"
    IRInteger -> singleWord "Int"
    IRDouble -> singleWord "Float"
    IRBool -> singleWord "Bool"
    IRString -> singleWord "String"
    IRArray a -> do
        ts <- typeStringForType a
        multiWord "Array" $ parenIfNeeded ts
    IRClass i -> singleWord =<< lookupClassName i
    IRMap t -> do
        ts <- typeStringForType t
        multiWord "Dict String" $ parenIfNeeded ts
    IRUnion u ->
        let s = unionToSet u
        in case nullableFromSet s of
        Just x -> do
            ts <- typeStringForType x
            multiWord "Maybe" $ parenIfNeeded ts
        Nothing -> do
            singleWord =<< lookupUnionName s

unionConstructorName :: Set IRType -> IRType -> Doc String
unionConstructorName s t = do
    typeName <- upperNameStyle <$> getTypeNameForUnion t
    unionName <- lookupUnionName s
    pure $ typeName <> "In" <> unionName

decoderNameForType :: IRType -> Doc { rendered :: String, multiWord :: Boolean }
decoderNameForType = case _ of
    IRNothing -> singleWord "Jdec.value"
    IRNull -> multiWord "Jdec.null" "()"
    IRInteger -> singleWord "Jdec.int"
    IRDouble -> singleWord "Jdec.float"
    IRBool -> singleWord "Jdec.bool"
    IRString -> singleWord "Jdec.string"
    IRArray a -> do
        dn <- decoderNameForType a
        multiWord "Jdec.array" $ parenIfNeeded dn
    IRClass i -> singleWord =<< decoderNameFromTypeName <$> lookupClassName i
    IRMap t -> do
        dn <- decoderNameForType t
        multiWord "Jdec.dict" $ parenIfNeeded dn
    IRUnion u ->
        let s = unionToSet u
        in case nullableFromSet s of
        Just t -> do
            dn <- decoderNameForType t
            multiWord "Jdec.nullable" $ parenIfNeeded dn
        Nothing -> do
            singleWord =<< decoderNameFromTypeName <$> lookupUnionName s

encoderNameForType :: IRType -> Doc { rendered :: String, multiWord :: Boolean }
encoderNameForType = case _ of
    IRNothing -> singleWord "identity"
    IRNull -> multiWord "always" "Jenc.null"
    IRInteger -> singleWord "Jenc.int"
    IRDouble -> singleWord "Jenc.float"
    IRBool -> singleWord "Jenc.bool"
    IRString -> singleWord "Jenc.string"
    IRArray a -> do
        rendered <- encoderNameForType a
        multiWord "array__enc" $ parenIfNeeded rendered
    IRClass i -> singleWord =<< encoderNameFromTypeName <$> lookupClassName i
    IRMap t -> do
        rendered <- encoderNameForType t
        multiWord "dict__enc" $ parenIfNeeded rendered
    IRUnion u ->
        let s = unionToSet u
        in case nullableFromSet s of
        Just t -> do
            rendered <- encoderNameForType t
            multiWord "nullable__enc" $ parenIfNeeded rendered
        Nothing ->
            singleWord =<< encoderNameFromTypeName <$> lookupUnionName s

forWithPrefix_ :: forall a b p m. Applicative m => List a -> p -> p -> (p -> a -> m b) -> m Unit
forWithPrefix_ l firstPrefix restPrefix f =
    forEnumerated_ l (\i -> f $ if i == 0 then firstPrefix else restPrefix)

isOptional :: IRType -> Boolean
isOptional = case _ of
    IRUnion u ->
        case nullableFromSet $ unionToSet u of
        Just t -> true
        Nothing -> false
    -- IRNull -> true
    -- IRUnion u -> S.member IRNull $ unionToSet u
    _ -> false

renderTypeDefinition :: Int -> String -> Map.Map String String -> List (Tuple String IRType) -> Doc Unit
renderTypeDefinition classIndex className propertyNames propsList = do
    line $ "type alias " <> className <> " ="
    indent do
        forWithPrefix_ propsList "{ " ", " \braceOrComma (Tuple pname ptype) -> do
            let propName = lookupName pname propertyNames
            { rendered } <- typeStringForType ptype
            line $ braceOrComma <> propName <> " : " <> rendered
        when (propsList == L.Nil) do
            line "{"
        line "}"

renderTypeFunctions :: Int -> String -> Map.Map String String -> List (Tuple String IRType) -> Doc Unit
renderTypeFunctions classIndex className propertyNames propsList = do
    let decoderName = decoderNameFromTypeName className
    line $ decoderName <> " : Jdec.Decoder " <> className
    line $ decoderName <> " ="
    indent do
        line $ "Jpipe.decode " <> className
        for_ propsList \(Tuple pname ptype) -> do
            indent do
                propDecoder <- decoderNameForType ptype
                let { reqOrOpt, fallback } = if isOptional ptype then { reqOrOpt: "Jpipe.optional", fallback: " Nothing" } else { reqOrOpt: "Jpipe.required", fallback: "" }
                line $ "|> " <> reqOrOpt <> " \"" <> stringEscape pname <> "\" " <> (parenIfNeeded propDecoder) <> fallback
    blank
    let encoderName = encoderNameFromTypeName className
    line $ encoderName <> " : " <> className <> " -> Jenc.Value"
    line $ encoderName <> " x ="
    indent do
        line "Jenc.object"
        indent do
            forWithPrefix_ propsList "[ " ", " \bracketOrComma (Tuple pname ptype) -> do
                let propName = lookupName pname propertyNames
                { rendered: propEncoder } <- encoderNameForType ptype
                line $ bracketOrComma <> "(\"" <> stringEscape pname <> "\", " <> propEncoder <> " x." <> propName <> ")"
        when (propsList == L.Nil) do
            line "["
        line "]"

typeRenderer :: (Int -> String -> Map.Map String String -> List (Tuple String IRType) -> Doc Unit) -> Int -> IRClassData -> Doc Unit
typeRenderer renderer classIndex (IRClassData { properties }) = do
    className <- lookupClassName classIndex
    let propertyNames = transformNames (simpleNamer lowerNameStyle) (\n -> "other" <> capitalize n) forbiddenPropertyNames $ map (\n -> Tuple n n) $ Map.keys properties
    let propsList = Map.toUnfoldable properties # sortByKey (\t -> lookupName (fst t) propertyNames)
    renderer classIndex className propertyNames propsList

renderUnionDefinition :: Set IRType -> Doc Unit
renderUnionDefinition allTypes = do
    unionName <- lookupUnionName allTypes
    fields <- L.fromFoldable allTypes # sortByKeyM (unionConstructorName allTypes)
    line $ "type " <> unionName
    forWithPrefix_ fields "=" "|" \equalsOrPipe t -> do
        indent do
            constructor <- unionConstructorName allTypes t
            when (t == IRNull) do
                line $ equalsOrPipe <> " " <> constructor
            unless (t == IRNull) do
                ts <- typeStringForType t
                line $ equalsOrPipe <> " " <> constructor <> " " <> (parenIfNeeded ts)

renderUnionFunctions :: Set IRType -> Doc Unit
renderUnionFunctions allTypes = do
    unionName <- lookupUnionName allTypes
    let decoderName = decoderNameFromTypeName unionName
    line $ decoderName <> " : Jdec.Decoder " <> unionName
    line $ decoderName <> " ="
    indent do
        let { element: maybeArray, rest: nonArrayFields } = removeElement isArray allTypes
        nonArrayDecFields <- L.fromFoldable nonArrayFields # sortByKeyM (unionConstructorName allTypes)
        let decFields = maybe nonArrayDecFields (\f -> f : nonArrayDecFields) maybeArray
        line "Jdec.oneOf"
        indent do
            forWithPrefix_ decFields "[" "," \bracketOrComma t -> do
                constructor <- unionConstructorName allTypes t
                when (t == IRNull) do
                    line $ bracketOrComma <> " Jdec.null " <> constructor
                unless (t == IRNull) do
                    decoder <- decoderNameForType t
                    line $ bracketOrComma <> " Jdec.map " <> constructor <> " " <> parenIfNeeded decoder
            line "]"
    blank
    let encoderName = encoderNameFromTypeName unionName
    line $ encoderName <> " : " <> unionName <> " -> Jenc.Value"
    line $ encoderName <> " x = case x of"
    indent do
        fields <- L.fromFoldable allTypes # sortByKeyM (unionConstructorName allTypes)
        for_ fields \t -> do
            constructor <- unionConstructorName allTypes t
            when (t == IRNull) do
                line $ constructor <> " -> Jenc.null"
            unless (t == IRNull) do
                { rendered: encoder } <- encoderNameForType t
                line $ constructor <> " y -> " <> encoder <> " y"


Removed unnecessary 'pure'

Removed unnecessary 'pure'

module Flag.App (Event, Country(..), shuffle, init, foldp, view) where

import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Random (RANDOM, random)
import Data.Argonaut (class DecodeJson, decodeJson, Json, (.?))
import Data.Array (drop, filter, head, length, replicate, sortBy, take, uncons, zip)
import Data.Either (Either, either)
import Data.Int (round, toNumber)
import Data.Maybe (Maybe(..), maybe)
import Data.Monoid (mempty)
import Data.Newtype (class Newtype, unwrap)
import Data.Traversable (for_, sequence)
import Data.Tuple (Tuple(..), snd)
import Network.HTTP.Affjax (AJAX, get)
import Pux (EffModel, noEffects)
import Pux.DOM.Events (onClick)
import Pux.DOM.HTML (HTML)
import Pux.DOM.HTML.Attributes (key)
import Text.Smolder.HTML (div, header, nav, section, a, img, ul, li)
import Text.Smolder.HTML.Attributes (className, src)
import Text.Smolder.Markup (text, (!), (#!))
import Prelude hiding (div)

type State = { all :: Countries, remaining :: Countries, answers :: Countries, correct :: Int, incorrect :: Int }
type Countries = Array Country

data Event = RequestCountries | ReceiveCountries (Tuple Countries Countries) | ReceiveAnswer String | ReceiveAnswers Countries

newtype Country = Country { name :: String, flag :: String }

derive instance newtypeCountry :: Newtype Country _
derive instance eqCountry :: Eq Country

instance showCountry :: Show Country where
  show (Country { name, flag }) = "(Country { name: " <> name <> ", flag: " <> flag <> " })"

instance decodeJsonCountry :: DecodeJson Country where
  decodeJson json = do
    model <- decodeJson json
    name <- model .? "name"
    flag <- model .? "flag"
    pure $ Country { name, flag }

answerCount :: Int
answerCount = 4

init :: State
init = { all: [], remaining: [], answers: [], correct: 0, incorrect: 0 }

decode :: forall r. { response :: Json | r } -> Either String (Array Country)
decode request = decodeJson request.response :: Either String Countries

fetch :: forall e. Aff (ajax :: AJAX, random :: RANDOM | e) (Tuple Countries Countries)
fetch = get "/countries.json"
  >>= pure <<< decode
  >>= liftEff <<< shuffle <<< either (const []) id
  >>= \countries -> pure <<< Tuple countries <=< liftEff $ pick countries countries

shuffle :: forall e a. Array a -> Eff (random :: RANDOM | e) (Array a)
shuffle xs = do
  randoms <- sequence $ replicate (length xs) random
  pure $ map snd $ sortBy compareFst $ zip randoms xs
  where compareFst (Tuple a _) (Tuple b _) = compare a b

pick :: forall e. Countries -> Countries -> Eff (random :: RANDOM | e) Countries
pick all answers = shuffle <<< (_ <> [answer]) <<< take (answerCount - 1) <<< filter (_ /= answer) <=< shuffle $ all
  where answer = maybe (Country { name: "_", flag: "_" }) id $ head answers

foldp :: Event -> State -> EffModel State Event (ajax :: AJAX, random :: RANDOM)
foldp (ReceiveAnswer name) state = {
  state: case (_ == name) <<< maybe mempty (_.name <<< unwrap) $ head state.remaining of
           true -> state { remaining = drop 1 state.remaining, correct = state.correct + 1 }
           _    -> state { remaining = drop 1 state.remaining, incorrect = state.incorrect + 1 },
  effects: [pure <<< Just <<< ReceiveAnswers <=< liftEff $ pick state.all (drop 1 state.remaining)]
}
foldp (ReceiveAnswers answers) state = noEffects state { answers = answers }
foldp (ReceiveCountries (Tuple all answers)) state = noEffects state { all = all, remaining = all, answers = answers }
foldp (RequestCountries) state = {
  state: state { correct = 0, incorrect = 0 },
  effects: [Just <<< ReceiveCountries <$> fetch]
}

view :: State -> HTML Event
view state = do
  nav do
    header $ text "Flagship"
    div ! className "total" $ text $ show (length state.remaining) <> "/" <> show (length state.all)
    div ! className "correct" $ text $ show state.correct
    div ! className "incorrect" $ text $ show state.incorrect
    a #! onClick (const RequestCountries) $ text $ case (length state.all) of
      0 -> "Start"
      _ -> "Restart"
  section $ case (uncons state.remaining), (state.correct + state.incorrect) of
    Just { head }, _ -> do
      img ! (src <<< ("/images/flags/" <> _) <<< _.flag <<< unwrap $ head)
      ul $ for_ (_.name <<< unwrap <$> state.answers) $ \name ->
        li ! key name #! onClick (const $ ReceiveAnswer name) $ text name
    Nothing, 0 -> div $ text mempty
    Nothing, _ -> do
      section ! className "results" $ do
        div ! className "percentage" $ text $ (show percentage) <> "%"
        div ! className "score" $ text $ "You scored " <> (show state.correct) <> " out of " <> (show total) <> "."
        a #! onClick (const RequestCountries) $ text "Play Again"
      where total = state.correct + state.incorrect
            percentage = round $ toNumber state.correct / (toNumber $ state.correct + state.incorrect) * 100.0

module Flag.App (Event, Country(..), shuffle, init, foldp, view) where

import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Random (RANDOM, random)
import Data.Argonaut (class DecodeJson, decodeJson, Json, (.?))
import Data.Array (drop, filter, head, length, replicate, sortBy, take, uncons, zip)
import Data.Either (Either, either)
import Data.Int (round, toNumber)
import Data.Maybe (Maybe(..), maybe)
import Data.Monoid (mempty)
import Data.Newtype (class Newtype, unwrap)
import Data.Traversable (for_, sequence)
import Data.Tuple (Tuple(..), snd)
import Network.HTTP.Affjax (AJAX, get)
import Pux (EffModel, noEffects)
import Pux.DOM.Events (onClick)
import Pux.DOM.HTML (HTML)
import Pux.DOM.HTML.Attributes (key)
import Text.Smolder.HTML (div, header, nav, section, a, img, ul, li)
import Text.Smolder.HTML.Attributes (className, src)
import Text.Smolder.Markup (text, (!), (#!))
import Prelude hiding (div)

type State = { all :: Countries, next :: Countries, current :: Countries, correct :: Int, incorrect :: Int }
type Countries = Array Country

data Event = RequestCountries | ReceiveCountries (Tuple Countries Countries) | ReceiveAnswer String | ReceiveAnswers Countries

newtype Country = Country { name :: String, flag :: String }

derive instance newtypeCountry :: Newtype Country _
derive instance eqCountry :: Eq Country

instance showCountry :: Show Country where
  show (Country { name, flag }) = "(Country { name: " <> name <> ", flag: " <> flag <> " })"

instance decodeJsonCountry :: DecodeJson Country where
  decodeJson json = do
    model <- decodeJson json
    name <- model .? "name"
    flag <- model .? "flag"
    pure $ Country { name, flag }

answerCount :: Int
answerCount = 4

init :: State
init = { all: [], next: [], current: [], correct: 0, incorrect: 0 }

decode :: forall r. { response :: Json | r } -> Either String (Array Country)
decode request = decodeJson request.response :: Either String Countries

fetch :: forall e. Aff (ajax :: AJAX, random :: RANDOM | e) (Tuple Countries Countries)
fetch = get "/countries.json"
  >>= pure <<< decode
  >>= liftEff <<< shuffle <<< either (const []) id
  >>= \countries -> pure <<< Tuple countries <=< liftEff $ pick countries countries

shuffle :: forall e a. Array a -> Eff (random :: RANDOM | e) (Array a)
shuffle xs = do
  randoms <- sequence $ replicate (length xs) random
  pure $ map snd $ sortBy compareFst $ zip randoms xs
  where compareFst (Tuple a _) (Tuple b _) = compare a b

pick :: forall e. Countries -> Countries -> Eff (random :: RANDOM | e) Countries
pick all current = pure <=< shuffle <<< (_ <> [next]) <<< take (answerCount - 1) <<<
                   filter (_ /= next) <=< shuffle $ all
  where next = maybe (Country { name: "_", flag: "_" }) id $ head current

foldp :: Event -> State -> EffModel State Event (ajax :: AJAX, random :: RANDOM)
foldp (ReceiveAnswer name) state = {
  state: case (_ == name) <<< maybe mempty (_.name <<< unwrap) $ head state.next of
           true -> state { next = drop 1 state.next, correct = state.correct + 1 }
           _    -> state { next = drop 1 state.next, incorrect = state.incorrect + 1 },
  effects: [pure <<< Just <<< ReceiveAnswers <=< liftEff $ pick state.all (drop 1 state.next)]
}
foldp (ReceiveAnswers current) state = noEffects state { current = current }
foldp (ReceiveCountries (Tuple all current)) state = noEffects state { all = all, next = all, current = current }
foldp (RequestCountries) state = {
  state: state { correct = 0, incorrect = 0 },
  effects: [Just <<< ReceiveCountries <$> fetch]
}

view :: State -> HTML Event
view state = do
  nav do
    header $ text "Flagship"
    div ! className "total" $ text $ show (length state.next) <> "/" <> show (length state.all)
    div ! className "correct" $ text $ show state.correct
    div ! className "incorrect" $ text $ show state.incorrect
    a #! onClick (const RequestCountries) $ text $ case (length state.all) of
      0 -> "Start"
      _ -> "Restart"
  section $ case (uncons state.next), (state.correct + state.incorrect) of
    Just { head }, _ -> do
      img ! (src <<< ("/images/flags/" <> _) <<< _.flag <<< unwrap $ head)
      ul $ for_ (_.name <<< unwrap <$> state.current) $ \name ->
        li ! key name #! onClick (const $ ReceiveAnswer name) $ text name
    Nothing, 0 -> div $ text mempty
    Nothing, _ -> do
      section ! className "results" $ do
        div ! className "percentage" $ text $ (show percentage) <> "%"
        div ! className "score" $ text $ "You scored " <> (show state.correct) <> " out of " <> (show total) <> "."
        a #! onClick (const RequestCountries) $ text "Play Again"
      where total = state.correct + state.incorrect
            percentage = round $ toNumber state.correct / (toNumber $ state.correct + state.incorrect) * 100.0


Improve representation of lists in web frontend

module Web
  ( exprToJQuery
  , Handler ()
  ) where

import Control.Monad.Eff
import qualified Control.Monad.JQuery as J
import DOM

import Data.Traversable (for, zipWithA)
import Data.Maybe
import Data.Array ((..), length)
import Control.Apply ((*>))

import AST
import Evaluator

type Handler = forall eff. Expr -> Path -> Eff (dom :: DOM | eff) Unit

exprToJQuery :: forall eff. Expr -> Handler -> Eff (dom :: DOM | eff) J.JQuery
exprToJQuery expr handler = go Start expr
  where
  addHandler :: Path -> J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
  addHandler p j = J.on "click" (\je _ -> J.stopImmediatePropagation je *> handler expr p) j
  go :: (Path -> Path) -> Expr -> Eff (dom :: DOM | eff) J.JQuery
  go p expr = case expr of
    Atom a          -> atom a
    Binary op e1 e2 -> do
      j1 <- go (p <<< Fst) e1
      j2 <- go (p <<< Snd) e2
      binary op j1 j2 >>= addHandler (p End)
    List es -> do
      js <- zipWithA (\i e -> go (p <<< Nth i) e) (0 .. (length es - 1)) es
      list js >>= addHandler (p End)
    App func args -> do
      jFunc <- go (p <<< Fst) func
      jArgs <- zipWithA (\i e -> go (p <<< Nth i) e) (0 .. (length args - 1)) args
      app jFunc jArgs >>= addHandler (p End)

atom :: forall eff. Atom -> Eff (dom :: DOM | eff) J.JQuery
atom (Num n)  = makeDiv (show n) ["atom", "num"]
atom (Bool b) = makeDiv (show b) ["atom", "bool"]
atom (Name s) = makeDiv s        ["atom", "name"]

binary :: forall eff. Op -> J.JQuery -> J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
binary op j1 j2 = do
  dBin <- makeDiv "" ["binary"]
  J.append j1 dBin
  dOp <- makeDiv (show op) ["op"]
  J.append dOp dBin
  J.append j2 dBin
  return dBin

list :: forall eff. [J.JQuery] -> Eff (dom :: DOM | eff) J.JQuery
list js = do
  dls <- makeDiv "" ["list"]
  open <- makeDiv "[" ["openBrace"]
  J.append open dls
  sep js dls
  close <- makeDiv "]" ["closeBrace"]
  J.append close dls
  return dls
  where
  sep []     dls = return unit
  sep (j:js) dls = do
    J.append j dls
    comma <- makeDiv "," ["listComma"]
    J.append comma dls
    sep js dls

app :: forall eff. J.JQuery -> [J.JQuery] -> Eff (dom :: DOM | eff) J.JQuery
app jFunc jArgs = do
  dApp <- makeDiv "" ["app"]
  J.addClass "func" jFunc
  J.append jFunc dApp
  for jArgs (flip J.append dApp)
  return dApp

type Class = String

makeDiv :: forall eff. String -> [Class] -> Eff (dom :: DOM | eff) J.JQuery
makeDiv text classes = do
  d <- J.create "

"
  J.setText text d
  for classes (flip J.addClass d)
  return d

module Web
  ( exprToJQuery
  , Handler ()
  ) where

import Control.Monad.Eff
import qualified Control.Monad.JQuery as J
import DOM

import Data.Traversable (for, zipWithA)
import Data.Maybe
import Data.Array ((..), length)
import Control.Apply ((*>))

import AST
import Evaluator

type Handler = forall eff. Expr -> Path -> Eff (dom :: DOM | eff) Unit

exprToJQuery :: forall eff. Expr -> Handler -> Eff (dom :: DOM | eff) J.JQuery
exprToJQuery expr handler = go Start expr
  where
  addHandler :: Path -> J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
  addHandler p j = J.on "click" (\je _ -> J.stopImmediatePropagation je *> handler expr p) j
  go :: (Path -> Path) -> Expr -> Eff (dom :: DOM | eff) J.JQuery
  go p expr = case expr of
    Atom a          -> atom a
    Binary op e1 e2 -> do
      j1 <- go (p <<< Fst) e1
      j2 <- go (p <<< Snd) e2
      binary op j1 j2 >>= addHandler (p End)
    List es -> do
      js <- zipWithA (\i e -> go (p <<< Nth i) e) (0 .. (length es - 1)) es
      list js >>= addHandler (p End)
    App func args -> do
      jFunc <- go (p <<< Fst) func
      jArgs <- zipWithA (\i e -> go (p <<< Nth i) e) (0 .. (length args - 1)) args
      app jFunc jArgs >>= addHandler (p End)

atom :: forall eff. Atom -> Eff (dom :: DOM | eff) J.JQuery
atom (Num n)  = makeDiv (show n) ["atom", "num"]
atom (Bool b) = makeDiv (show b) ["atom", "bool"]
atom (Name s) = makeDiv s        ["atom", "name"]

binary :: forall eff. Op -> J.JQuery -> J.JQuery -> Eff (dom :: DOM | eff) J.JQuery
binary op j1 j2 = do
  dBin <- makeDiv "" ["binary"]
  J.append j1 dBin
  dOp <- makeDiv (show op) ["op"]
  J.append dOp dBin
  J.append j2 dBin
  return dBin

list :: forall eff. [J.JQuery] -> Eff (dom :: DOM | eff) J.JQuery
list js = do
  dls <- makeDiv "List" ["list"]
  for js (flip J.append dls)
  return dls

app :: forall eff. J.JQuery -> [J.JQuery] -> Eff (dom :: DOM | eff) J.JQuery
app jFunc jArgs = do
  dApp <- makeDiv "" ["app"]
  J.addClass "func" jFunc
  J.append jFunc dApp
  for jArgs (flip J.append dApp)
  return dApp

type Class = String

makeDiv :: forall eff. String -> [Class] -> Eff (dom :: DOM | eff) J.JQuery
makeDiv text classes = do
  d <- J.create "

"
  J.setText text d
  for classes (flip J.addClass d)
  return d


Hacky fix for wanted card appearing in card path

module SlamData.Workspace.Card.InsertableCardType where

import Data.Array as Array
import Data.String as String
import Data.Foldable as Foldable
import SlamData.Prelude
import SlamData.Workspace.Card.CardType as CardType
import SlamData.Workspace.Card.CardType (CardType)
import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.Card.Port (Port)
import Utils (singletonValue)

data InsertableCardType
  = CacheCard
  | DraftboardCard
  | OpenCard
  | QueryCard
  | SearchCard
  | SetupChartCard
  | SetupDownloadCard
  | SetupMarkdownCard
  | SetupVariablesCard
  | ShowChartCard
  | ShowDownloadCard
  | ShowMarkdownCard
  | TableCard
  | TroubleshootCard

data InsertableCardIOType
  = Chart
  | Data
  | Download
  | Draftboard
  | Markdown
  | None
  | Variables

derive instance eqInsertableCardType ∷ Eq InsertableCardType
derive instance eqInsertableCardIOType ∷ Eq InsertableCardIOType

inputs ∷ Array (InsertableCardType × (Array InsertableCardIOType))
inputs =
  [ CacheCard × [ Data ]
  , DraftboardCard × [ None ]
  , OpenCard × [ None ]
  , QueryCard × [ None, Data, Variables ]
  , SearchCard × [ Data ]
  , SetupChartCard × [ Data ]
  , SetupDownloadCard × [ Data ]
  , SetupMarkdownCard × [ None ]
  , SetupVariablesCard × [ None ]
  , ShowChartCard × [ Chart ]
  , ShowDownloadCard × [ Download ]
  , ShowMarkdownCard × [ Markdown ]
  , TableCard × [ Data ]
  , TroubleshootCard × [ Variables, Data ]
  ]

outputs ∷ Array (InsertableCardType × InsertableCardIOType)
outputs =
  [ CacheCard × Data
  , DraftboardCard × Draftboard
  , OpenCard × Data
  , QueryCard × Data
  , SearchCard × Data
  , SetupChartCard × Chart
  , SetupDownloadCard × Download
  , SetupMarkdownCard × Markdown
  , SetupVariablesCard × Variables
  , ShowChartCard × Chart
  , ShowDownloadCard × Download
  , ShowMarkdownCard × Variables
  , TableCard × Data
  , TroubleshootCard × Variables
  ]

contains ∷ ∀ a. (Eq a) ⇒ a → Array a → Boolean
contains x =
  isJust ∘ Array.elemIndex x

takesInput ∷ InsertableCardIOType -> InsertableCardType -> Boolean
takesInput io card = Foldable.elem card $ cardsThatTakeInput io

inputsFor ∷ InsertableCardType → Array InsertableCardIOType
inputsFor card =
  Array.concat $ map snd $ Array.filter (eq card ∘ fst) inputs

outputFor ∷ InsertableCardType → Maybe InsertableCardIOType
outputFor card =
  singletonValue Nothing (const Nothing) (map snd $ Array.filter (eq card ∘ fst) outputs)

cardsThatOutput ∷ InsertableCardIOType → Array InsertableCardType
cardsThatOutput io =
  map fst $ Array.filter (eq io ∘ snd) outputs

cardsThatTakeInput ∷ InsertableCardIOType → Array InsertableCardType
cardsThatTakeInput io =
  map fst $ Array.filter (contains io ∘ snd) inputs

type Path =
  { c ∷ Array InsertableCardType, io ∷ Array InsertableCardIOType, f ∷ Boolean }

purePath ∷ InsertableCardIOType → Path
purePath io =
  { c: [], io: [io], f: false }

cardPathsFromPaths ∷ Array Path → Array (Array InsertableCardType)
cardPathsFromPaths = map _.c

allPathsFinished ∷ Array Path → Boolean
allPathsFinished = Foldable.all _.f

cardPathsBetween ∷ InsertableCardIOType → InsertableCardType -> Array (Array InsertableCardType)
cardPathsBetween fromIO toCard =
  Array.filter (not ∘ Foldable.elem toCard) $ cardPathsFromPaths $ pathsBetween fromIO toCard

pathsBetween ∷ InsertableCardIOType → InsertableCardType → Array Path
pathsBetween fromIO toCard =
  Array.concat $ pathsBetweenIO fromIO <$> inputsFor toCard

cardPathNeeded ∷ Array (Array InsertableCardType) → Boolean
cardPathNeeded cardPaths =
  not $ Array.null cardPaths || [] `Foldable.elem` cardPaths

possibleToGetTo ∷ InsertableCardIOType -> InsertableCardType -> Boolean
possibleToGetTo io card =
  not $ Array.null $ Array.concat $ pathsBetweenIO io <$> inputsFor card

pathsBetweenIO ∷ InsertableCardIOType → InsertableCardIOType → Array Path
pathsBetweenIO fromIO toIO =
  go $ [ purePath toIO ]
  where
  go ∷ Array Path → Array Path
  go paths | allPathsFinished paths = paths
  go paths | otherwise =
    go $ Array.concat $ expandPath fromIO <$> paths

expandPath ∷ InsertableCardIOType → Path → Array Path
expandPath fromIO initialPath | initialPath.f =
  [ initialPath ]
expandPath fromIO initialPath | maybe true (eq fromIO) (Array.head initialPath.io) =
  [ initialPath { f = true } ]
expandPath fromIO initialPath | otherwise =
  maybe [] f $ Array.head initialPath.io
  where
  f ∷ InsertableCardIOType → Array Path
  f initialIO = Array.concat $ g <$> (cardsThatOutput initialIO)

  g ∷ InsertableCardType → Array Path
  g card = h card `Array.mapMaybe` (inputsFor card)

  h ∷ InsertableCardType → InsertableCardIOType → Maybe Path
  h card io | io `Foldable.elem` initialPath.io = Nothing
  h card io =
    Just { c: pathCards, io: pathIO, f: pathFinished }
    where
    pathFinished = fromIO `Foldable.elem` pathIO
    pathIO = Array.cons io initialPath.io
    pathCards = Array.cons card initialPath.c

fromMaybePort ∷ Maybe Port → InsertableCardIOType
fromMaybePort input = maybe None fromPort input

printIOType :: InsertableCardIOType -> String
printIOType =
  case _ of
    Chart → "a chart"
    Data → "data"
    Download → "a download"
    Draftboard → "a draftboard"
    Markdown → "markdown"
    None → "to be the first card in a deck"
    Variables → "variables"

eitherOr :: Array String -> String
eitherOr strings =
  case Array.length strings of
    1 -> String.joinWith "" strings
    n ->
      "either "
        ++ String.joinWith ", " (Array.take (n - 1) strings)
        ++ " or "
        ++ String.joinWith "" (Array.drop (n - 1) strings)

fromPort ∷ Port → InsertableCardIOType
fromPort =
  case _ of
    Port.Chart _ → Chart
    Port.DownloadOptions _ → Download
    Port.Draftboard → Draftboard
    Port.SlamDown _ → Markdown
    Port.TaggedResource _ → Data
    Port.VarMap _ → Variables
    _ → None

toCardType ∷ InsertableCardType → CardType
toCardType =
  case _ of
    CacheCard → CardType.Cache
    DraftboardCard → CardType.Draftboard
    OpenCard → CardType.Open
    QueryCard → CardType.Ace CardType.SQLMode
    SearchCard → CardType.Search
    SetupChartCard → CardType.ChartOptions
    SetupDownloadCard → CardType.DownloadOptions
    SetupMarkdownCard → CardType.Ace CardType.MarkdownMode
    SetupVariablesCard → CardType.Variables
    ShowChartCard → CardType.Chart
    ShowDownloadCard → CardType.Download
    ShowMarkdownCard → CardType.Markdown
    TableCard → CardType.Table
    TroubleshootCard → CardType.Troubleshoot

print ∷ InsertableCardType -> String
print =
  CardType.cardName ∘ toCardType

aAn ∷ String -> String
aAn s =
  if String.toLower (String.take 1 s) `Foldable.elem` vowels
    then "An"
    else "A"
  where
  vowels = [ "a", "e", "i", "o", "u" ]

reason :: InsertableCardIOType -> InsertableCardType -> String
reason io card =
  aAn (print card) ++ " " ++ show (print card) ++ " card can't " ++ actual
    ++ " because it needs " ++ expected ++ action ++ "."
  where
  actual =
    case io of
      None -> "be the first card in a deck"
      _ -> "follow a card which outputs " ++ printIOType io
  expected =
    eitherOr $ printIOType <$> inputsFor card
  action =
    maybe "" (" to " ++ _) (printAction card)

printAction ∷ InsertableCardType -> Maybe String
printAction =
  case _ of
    CacheCard → Just "cache"
    DraftboardCard → Nothing
    OpenCard → Nothing
    QueryCard → Nothing
    SearchCard → Just "search"
    SetupChartCard → Just "set up a chart for"
    SetupDownloadCard → Just "setup a download for"
    SetupMarkdownCard → Nothing
    SetupVariablesCard → Nothing
    ShowChartCard → Just "show"
    ShowDownloadCard → Just "show"
    ShowMarkdownCard → Just "show"
    TableCard → Just "tabulate"
    TroubleshootCard → Just "troubleshoot"

fromCardType ∷ CardType → Maybe InsertableCardType
fromCardType =
  case _ of
    CardType.Cache → Just CacheCard
    CardType.Draftboard → Just DraftboardCard
    CardType.Open → Just OpenCard
    CardType.Ace CardType.SQLMode → Just QueryCard
    CardType.Search → Just SearchCard
    CardType.ChartOptions → Just SetupChartCard
    CardType.DownloadOptions → Just SetupDownloadCard
    CardType.Ace CardType.MarkdownMode → Just SetupMarkdownCard
    CardType.Variables → Just SetupVariablesCard
    CardType.Chart → Just ShowChartCard
    CardType.Download → Just ShowDownloadCard
    CardType.Markdown → Just ShowMarkdownCard
    CardType.Table → Just TableCard
    CardType.Troubleshoot → Just TroubleshootCard
    _ -> Nothing

module SlamData.Workspace.Card.InsertableCardType where

import Data.Array as Array
import Data.String as String
import Data.Foldable as Foldable
import SlamData.Prelude
import SlamData.Workspace.Card.CardType as CardType
import SlamData.Workspace.Card.CardType (CardType)
import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.Card.Port (Port)
import Utils (singletonValue)

data InsertableCardType
  = CacheCard
  | DraftboardCard
  | OpenCard
  | QueryCard
  | SearchCard
  | SetupChartCard
  | SetupDownloadCard
  | SetupMarkdownCard
  | SetupVariablesCard
  | ShowChartCard
  | ShowDownloadCard
  | ShowMarkdownCard
  | TableCard
  | TroubleshootCard

data InsertableCardIOType
  = Chart
  | Data
  | Download
  | Draftboard
  | Markdown
  | None
  | Variables

derive instance eqInsertableCardType ∷ Eq InsertableCardType
derive instance eqInsertableCardIOType ∷ Eq InsertableCardIOType

inputs ∷ Array (InsertableCardType × (Array InsertableCardIOType))
inputs =
  [ CacheCard × [ Data ]
  , DraftboardCard × [ None ]
  , OpenCard × [ None ]
  , QueryCard × [ None, Data, Variables ]
  , SearchCard × [ Data ]
  , SetupChartCard × [ Data ]
  , SetupDownloadCard × [ Data ]
  , SetupMarkdownCard × [ None ]
  , SetupVariablesCard × [ None ]
  , ShowChartCard × [ Chart ]
  , ShowDownloadCard × [ Download ]
  , ShowMarkdownCard × [ Markdown ]
  , TableCard × [ Data ]
  , TroubleshootCard × [ Variables, Data ]
  ]

outputs ∷ Array (InsertableCardType × InsertableCardIOType)
outputs =
  [ CacheCard × Data
  , DraftboardCard × Draftboard
  , OpenCard × Data
  , QueryCard × Data
  , SearchCard × Data
  , SetupChartCard × Chart
  , SetupDownloadCard × Download
  , SetupMarkdownCard × Markdown
  , SetupVariablesCard × Variables
  , ShowChartCard × Chart
  , ShowDownloadCard × Download
  , ShowMarkdownCard × Variables
  , TableCard × Data
  , TroubleshootCard × Variables
  ]

contains ∷ ∀ a. (Eq a) ⇒ a → Array a → Boolean
contains x =
  isJust ∘ Array.elemIndex x

takesInput ∷ InsertableCardIOType -> InsertableCardType -> Boolean
takesInput io card = Foldable.elem card $ cardsThatTakeInput io

inputsFor ∷ InsertableCardType → Array InsertableCardIOType
inputsFor card =
  Array.concat $ map snd $ Array.filter (eq card ∘ fst) inputs

outputFor ∷ InsertableCardType → Maybe InsertableCardIOType
outputFor card =
  singletonValue Nothing (const Nothing) (map snd $ Array.filter (eq card ∘ fst) outputs)

cardsThatOutput ∷ InsertableCardIOType → Array InsertableCardType
cardsThatOutput io =
  map fst $ Array.filter (eq io ∘ snd) outputs

cardsThatTakeInput ∷ InsertableCardIOType → Array InsertableCardType
cardsThatTakeInput io =
  map fst $ Array.filter (contains io ∘ snd) inputs

type Path =
  { c ∷ Array InsertableCardType, io ∷ Array InsertableCardIOType, f ∷ Boolean }

purePath ∷ InsertableCardIOType → Path
purePath io =
  { c: [], io: [io], f: false }

cardPathsFromPaths ∷ Array Path → Array (Array InsertableCardType)
cardPathsFromPaths = map _.c

allPathsFinished ∷ Array Path → Boolean
allPathsFinished = Foldable.all _.f

cardPathsBetween ∷ InsertableCardIOType → InsertableCardType -> Array (Array InsertableCardType)
cardPathsBetween fromIO = cardPathsFromPaths ∘ pathsBetween fromIO

pathsBetween ∷ InsertableCardIOType → InsertableCardType → Array Path
pathsBetween fromIO toCard =
  Array.concat $ pathsBetweenIO fromIO <$> inputsFor toCard

cardPathNeeded ∷ Array (Array InsertableCardType) → Boolean
cardPathNeeded cardPaths =
  not $ Array.null cardPaths || [] `Foldable.elem` cardPaths

possibleToGetTo ∷ InsertableCardIOType -> InsertableCardType -> Boolean
possibleToGetTo io card =
  not $ Array.null $ Array.concat $ pathsBetweenIO io <$> inputsFor card

pathsBetweenIO ∷ InsertableCardIOType → InsertableCardIOType → Array Path
pathsBetweenIO fromIO toIO =
  go $ [ purePath toIO ]
  where
  go ∷ Array Path → Array Path
  go paths | allPathsFinished paths = paths
  go paths | otherwise =
    go $ Array.concat $ expandPath fromIO <$> paths

expandPath ∷ InsertableCardIOType → Path → Array Path
expandPath fromIO initialPath | initialPath.f =
  [ initialPath ]
expandPath fromIO initialPath | maybe true (eq fromIO) (Array.head initialPath.io) =
  [ initialPath { f = true } ]
expandPath fromIO initialPath | otherwise =
  maybe [] f $ Array.head initialPath.io
  where
  f ∷ InsertableCardIOType → Array Path
  f initialIO = Array.concat $ g <$> (cardsThatOutput initialIO)

  g ∷ InsertableCardType → Array Path
  g card = h card `Array.mapMaybe` (inputsFor card)

  h ∷ InsertableCardType → InsertableCardIOType → Maybe Path
  h card io | io `Foldable.elem` initialPath.io = Nothing
  h card io =
    Just { c: pathCards, io: pathIO, f: pathFinished }
    where
    pathFinished = fromIO `Foldable.elem` pathIO
    pathIO = Array.cons io initialPath.io
    pathCards = Array.cons card initialPath.c

fromMaybePort ∷ Maybe Port → InsertableCardIOType
fromMaybePort input = maybe None fromPort input

printIOType :: InsertableCardIOType -> String
printIOType =
  case _ of
    Chart → "a chart"
    Data → "data"
    Download → "a download"
    Draftboard → "a draftboard"
    Markdown → "markdown"
    None → "to be the first card in a deck"
    Variables → "variables"

eitherOr :: Array String -> String
eitherOr strings =
  case Array.length strings of
    1 -> String.joinWith "" strings
    n ->
      "either "
        ++ String.joinWith ", " (Array.take (n - 1) strings)
        ++ " or "
        ++ String.joinWith "" (Array.drop (n - 1) strings)

fromPort ∷ Port → InsertableCardIOType
fromPort =
  case _ of
    Port.Chart _ → Chart
    Port.DownloadOptions _ → Download
    Port.Draftboard → Draftboard
    Port.SlamDown _ → Markdown
    Port.TaggedResource _ → Data
    Port.VarMap _ → Variables
    _ → None

toCardType ∷ InsertableCardType → CardType
toCardType =
  case _ of
    CacheCard → CardType.Cache
    DraftboardCard → CardType.Draftboard
    OpenCard → CardType.Open
    QueryCard → CardType.Ace CardType.SQLMode
    SearchCard → CardType.Search
    SetupChartCard → CardType.ChartOptions
    SetupDownloadCard → CardType.DownloadOptions
    SetupMarkdownCard → CardType.Ace CardType.MarkdownMode
    SetupVariablesCard → CardType.Variables
    ShowChartCard → CardType.Chart
    ShowDownloadCard → CardType.Download
    ShowMarkdownCard → CardType.Markdown
    TableCard → CardType.Table
    TroubleshootCard → CardType.Troubleshoot

print ∷ InsertableCardType -> String
print =
  CardType.cardName ∘ toCardType

aAn ∷ String -> String
aAn s =
  if String.toLower (String.take 1 s) `Foldable.elem` vowels
    then "An"
    else "A"
  where
  vowels = [ "a", "e", "i", "o", "u" ]

reason :: InsertableCardIOType -> InsertableCardType -> String
reason io card =
  aAn (print card) ++ " " ++ show (print card) ++ " card can't " ++ actual
    ++ " because it needs " ++ expected ++ action ++ "."
  where
  actual =
    case io of
      None -> "be the first card in a deck"
      _ -> "follow a card which outputs " ++ printIOType io
  expected =
    eitherOr $ printIOType <$> inputsFor card
  action =
    maybe "" (" to " ++ _) (printAction card)

printAction ∷ InsertableCardType -> Maybe String
printAction =
  case _ of
    CacheCard → Just "cache"
    DraftboardCard → Nothing
    OpenCard → Nothing
    QueryCard → Nothing
    SearchCard → Just "search"
    SetupChartCard → Just "set up a chart for"
    SetupDownloadCard → Just "setup a download for"
    SetupMarkdownCard → Nothing
    SetupVariablesCard → Nothing
    ShowChartCard → Just "show"
    ShowDownloadCard → Just "show"
    ShowMarkdownCard → Just "show"
    TableCard → Just "tabulate"
    TroubleshootCard → Just "troubleshoot"

fromCardType ∷ CardType → Maybe InsertableCardType
fromCardType =
  case _ of
    CardType.Cache → Just CacheCard
    CardType.Draftboard → Just DraftboardCard
    CardType.Open → Just OpenCard
    CardType.Ace CardType.SQLMode → Just QueryCard
    CardType.Search → Just SearchCard
    CardType.ChartOptions → Just SetupChartCard
    CardType.DownloadOptions → Just SetupDownloadCard
    CardType.Ace CardType.MarkdownMode → Just SetupMarkdownCard
    CardType.Variables → Just SetupVariablesCard
    CardType.Chart → Just ShowChartCard
    CardType.Download → Just ShowDownloadCard
    CardType.Markdown → Just ShowMarkdownCard
    CardType.Table → Just TableCard
    CardType.Troubleshoot → Just TroubleshootCard
    _ -> Nothing


slightly refactor ...

slightly refactor ...

module KanColle.DamageAnalysis where

import Prelude
import Data.Maybe
import Data.Maybe.Unsafe
import KanColle.KCAPI.Battle
import Data.Array
import Data.Foreign
import Data.Int
import Data.Monoid
import Data.Monoid.Endo
import Data.Nullable
import Data.Foldable
import Data.String (joinWith)
import Math
import qualified Data.Array.Unsafe as AU
import KanColle.DamageAnalysis.DamageVector
import KanColle.DamageAnalysis.Stages

-- information about damage took by a ship
type DamageTookInfo = {currentHp :: Int}

type DamageTookInfoNight = DamageTookInfo

pprDamageTookInfo :: DamageTookInfo -> String
pprDamageTookInfo dti
  = "DamageInfo {"
 <> "currentHp=" <> show dti.currentHp
 <> "}"

pprDamageTookInfoNight :: DamageTookInfoNight -> String
pprDamageTookInfoNight dti
  = "DamageInfoNight {"
 <> "currentHp=" <> show dti.currentHp
 <> "}"

pprFleetDamageTookInfo :: AllFleetInfo DamageTookInfo -> String
pprFleetDamageTookInfo = joinWith " | " <<< map (maybe "<N/A>" pprDamageTookInfo)

pprFleetDamageTookInfoNight :: AllFleetInfo DamageTookInfoNight -> String
pprFleetDamageTookInfoNight = joinWith " | " <<< map (maybe "<N/A>" pprDamageTookInfoNight)

-- invariant: the length is always 1+12,
-- index 0 is never used
-- index 1-6 for frient units
-- index 7-12 for enemies
type AllFleetInfo a = Array (Maybe a)

type DamageAnalyzer = Battle
                   -> AllFleetInfo DamageTookInfo
                   -> AllFleetInfo DamageTookInfo

-- initialize a battle, does nothing but setup currentHp
battleStart :: Battle -> AllFleetInfo DamageTookInfo
battleStart b = hpList
  where
    noDamage hp = {currentHp: hp}
    hpList = map fromRawHp b.api_nowhps
    fromRawHp -1 = Nothing
    fromRawHp v = Just (noDamage v)

analyzeBattle :: Battle -> AllFleetInfo DamageTookInfo
analyzeBattle = applyDamageVector <$> battleDV <*> battleStart

analyzeNightBattle :: NightBattle -> AllFleetInfo DamageTookInfoNight
analyzeNightBattle = applyDamageVector <$> nightBattleDV <*> battleStart

analyzeRawBattle :: Foreign -> AllFleetInfo DamageTookInfo
analyzeRawBattle = analyzeBattle <<< unsafeFromForeign

analyzeRawNightBattle :: Foreign -> AllFleetInfo DamageTookInfoNight
analyzeRawNightBattle = analyzeNightBattle <<< unsafeFromForeign

analyzeRawBattleJS :: Foreign -> Array (Nullable DamageTookInfo)
analyzeRawBattleJS = map toNullable <<< analyzeRawBattle

analyzeRawNightBattleJS :: Foreign -> Array (Nullable DamageTookInfoNight)
analyzeRawNightBattleJS = map toNullable <<< analyzeRawNightBattle

applyDamageVector :: DamageVector
                  -> AllFleetInfo DamageTookInfo
                  -> AllFleetInfo DamageTookInfo
applyDamageVector (DV dv) = zipWith combine dv
  where
    combine dmg = map (\x -> x {currentHp = x.currentHp - dmg})

module KanColle.DamageAnalysis where

import Prelude
import Data.Maybe
import Data.Maybe.Unsafe
import KanColle.KCAPI.Battle
import Data.Array
import Data.Foreign
import Data.Int
import Data.Monoid
import Data.Monoid.Endo
import Data.Nullable
import Data.Foldable
import Data.String (joinWith)
import Math
import qualified Data.Array.Unsafe as AU
import KanColle.DamageAnalysis.DamageVector
import KanColle.DamageAnalysis.Stages

-- information about damage took by a ship
type DamageTookInfo =
  { currentHp :: Int
  }

type DamageTookInfoNight =
  { currentHp :: Int
  }

pprDamageTookInfo :: DamageTookInfo -> String
pprDamageTookInfo dti
  = "DamageInfo {"
 <> "currentHp=" <> show dti.currentHp
 <> "}"

pprDamageTookInfoNight :: DamageTookInfoNight -> String
pprDamageTookInfoNight dti
  = "DamageInfoNight {"
 <> "currentHp=" <> show dti.currentHp
 <> "}"

pprFleetDamageTookInfo :: AllFleetInfo DamageTookInfo -> String
pprFleetDamageTookInfo xs = joinWith " | " $ map (maybe "<N/A>" pprDamageTookInfo) xs

pprFleetDamageTookInfoNight :: AllFleetInfo DamageTookInfoNight -> String
pprFleetDamageTookInfoNight xs = joinWith " | " $ map (maybe "<N/A>" pprDamageTookInfoNight) xs

-- invariant: the length is always 1+12,
-- index 0 is never used
-- index 1-6 for frient units
-- index 7-12 for enemies
type AllFleetInfo a = Array (Maybe a)

type DamageAnalyzer = Battle
                   -> AllFleetInfo DamageTookInfo
                   -> AllFleetInfo DamageTookInfo

noDamage :: Int -> DamageTookInfo
noDamage hp =
  { currentHp: hp
  }

-- initialize a battle, does nothing but setup currentHp
battleStart :: Battle -> AllFleetInfo DamageTookInfo
battleStart b = hpList
  where
    hpList = map fromRawHp b.api_nowhps
    fromRawHp -1 = Nothing
    fromRawHp v = Just (noDamage v)

analyzeBattle :: Battle -> AllFleetInfo DamageTookInfo
analyzeBattle = analyzeBattleAlt

analyzeNightBattle :: NightBattle -> AllFleetInfo DamageTookInfoNight
analyzeNightBattle = analyzeNightBattleAlt

analyzeRawBattle :: Foreign -> AllFleetInfo DamageTookInfo
analyzeRawBattle = analyzeBattle <<< unsafeFromForeign

analyzeRawNightBattle :: Foreign -> AllFleetInfo DamageTookInfoNight
analyzeRawNightBattle = analyzeNightBattle <<< unsafeFromForeign

analyzeRawBattleJS :: Foreign -> Array (Nullable DamageTookInfo)
analyzeRawBattleJS = map toNullable <<< analyzeRawBattle

analyzeRawNightBattleJS :: Foreign -> Array (Nullable DamageTookInfoNight)
analyzeRawNightBattleJS = map toNullable <<< analyzeRawNightBattle

applyDamageVector :: DamageVector
                  -> AllFleetInfo DamageTookInfo
                  -> AllFleetInfo DamageTookInfo
applyDamageVector (DV dv) = zipWith combine dv
  where
    combine dmg = map (\x -> x {currentHp = x.currentHp - dmg})

analyzeBattleAlt :: Battle -> AllFleetInfo DamageTookInfo
analyzeBattleAlt = applyDamageVector <$> battleDV <*> battleStart

analyzeNightBattleAlt :: NightBattle -> AllFleetInfo DamageTookInfoNight
analyzeNightBattleAlt = applyDamageVector <$> nightBattleDV <*> battleStart


Fixed incorrect uri variables in queries bug (#1295)

{-
Copyright 2016 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 SlamData.Workspace.Card.Eval where

import SlamData.Prelude

import Control.Monad.Eff as Eff
import Control.Monad.Aff.Free (class Affable, fromEff)

import Data.Lens ((^?))
import Data.Path.Pathy as Path
import Data.StrMap as SM
import Data.Set as Set

import Quasar.Types (SQL, FilePath)

import SlamData.Effects (SlamDataEffects)
import SlamData.FileSystem.Resource as R
import SlamData.GlobalError as GE
import SlamData.Quasar.Class (class QuasarDSL)
import SlamData.Quasar.Error as QE
import SlamData.Quasar.FS as QFS
import SlamData.Quasar.Query as QQ
import SlamData.Workspace.Card.BuildChart.Area.Eval as BuildArea
import SlamData.Workspace.Card.BuildChart.Bar.Eval as BuildBar
import SlamData.Workspace.Card.BuildChart.Boxplot.Eval as BuildBoxplot
import SlamData.Workspace.Card.BuildChart.Candlestick.Eval as BuildCandlestick
import SlamData.Workspace.Card.BuildChart.Funnel.Eval as BuildFunnel
import SlamData.Workspace.Card.BuildChart.Gauge.Eval as BuildGauge
import SlamData.Workspace.Card.BuildChart.Graph.Eval as BuildGraph
import SlamData.Workspace.Card.BuildChart.Heatmap.Eval as BuildHeatmap
import SlamData.Workspace.Card.BuildChart.Line.Eval as BuildLine
import SlamData.Workspace.Card.BuildChart.Metric.Eval as BuildMetric
import SlamData.Workspace.Card.BuildChart.Parallel.Eval as BuildParallel
import SlamData.Workspace.Card.BuildChart.Pie.Eval as BuildPie
import SlamData.Workspace.Card.BuildChart.PivotTable.Eval as BuildPivotTable
import SlamData.Workspace.Card.BuildChart.PunchCard.Eval as BuildPunchCard
import SlamData.Workspace.Card.BuildChart.Radar.Eval as BuildRadar
import SlamData.Workspace.Card.BuildChart.Sankey.Eval as BuildSankey
import SlamData.Workspace.Card.BuildChart.Scatter.Eval as BuildScatter
import SlamData.Workspace.Card.Cache.Eval as Cache
import SlamData.Workspace.Card.CardType as CT
import SlamData.Workspace.Card.DownloadOptions.Component.State as DO
import SlamData.Workspace.Card.Eval.CardEvalT as CET
import SlamData.Workspace.Card.Markdown.Component.State.Core as MDS
import SlamData.Workspace.Card.Markdown.Eval as MDE
import SlamData.Workspace.Card.Markdown.Model as MD
import SlamData.Workspace.Card.Model as Model
import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.Card.Port.VarMap (renderVarMapValue)
import SlamData.Workspace.Card.Search.Interpret as Search
import SlamData.Workspace.Card.Variables.Eval as VariablesE
import SlamData.Workspace.Card.Variables.Model as Variables
import SlamData.Workspace.Deck.AdditionalSource (AdditionalSource)

import Text.SlamSearch as SS
import Text.Markdown.SlamDown as SD
import Text.Markdown.SlamDown.Halogen.Component.State as SDH

data Eval
  = Pass
  | Query SQL
  | Search String
  | Cache (Maybe String)
  | Error String
  | Markdown String
  | MarkdownForm MD.Model
  | Open R.Resource
  | Variables Variables.Model
  | DownloadOptions DO.State
  | Draftboard
  | BuildMetric BuildMetric.Model
  | BuildSankey BuildSankey.Model
  | BuildGauge BuildGauge.Model
  | BuildGraph BuildGraph.Model
  | BuildPie BuildPie.Model
  | BuildRadar BuildRadar.Model
  | BuildArea BuildArea.Model
  | BuildLine BuildLine.Model
  | BuildBar BuildBar.Model
  | BuildScatter BuildScatter.Model
  | BuildFunnel BuildFunnel.Model
  | BuildHeatmap BuildHeatmap.Model
  | BuildBoxplot BuildBoxplot.Model
  | BuildPivotTable BuildPivotTable.Model
  | BuildPunchCard BuildPunchCard.Model
  | BuildCandlestick BuildCandlestick.Model
  | BuildParallel BuildParallel.Model

tagEval ∷ Eval → String
tagEval = case _ of
  Pass → "Pass"
  Query str → "Query " <> show str
  Search str → "Search " <> show str
  Cache str → "Cache " <> show str
  Error str → "Error " <> show str
  Markdown str → "Markdown " <> show str
  Open res → "Open " <> show res
  MarkdownForm m → "MarkdownForm"
  Variables m → "Variables"
  DownloadOptions m → "DownloadOptions"
  Draftboard → "Draftboard"
  BuildMetric _ → "BuildMetric"
  BuildSankey _ → "BuildSankey"
  BuildGauge _ → "BuildGauge"
  BuildGraph _ → "BuildGraph"
  BuildPie _ → "BuildPie"
  BuildRadar _ → "BuildRadar"
  BuildArea _ → "BuildArea"
  BuildLine _ → "BuildLine"
  BuildBar _ → "BuildBar"
  BuildScatter _ → "BuildScatter"
  BuildFunnel _ → "BuildFunnel"
  BuildHeatmap _ → "BuildHeatmap"
  BuildBoxplot _ → "BuildBoxplot"
  BuildPivotTable _ → "BuildPivotTable"
  BuildPunchCard _ → "BuildPunchCard"
  BuildCandlestick _ → "BuildCandlestick"
  BuildParallel _ → "BuildParallel"

evalCard
  ∷ ∀ f m
  . (Monad m, Parallel f m, QuasarDSL m, Affable SlamDataEffects m)
  ⇒ CET.CardEvalInput
  → Eval
  → CET.CardEvalT m Port.Port
evalCard input =
  case _, input.input of
    Error msg, _ →
      pure $ Port.CardError msg
    _, Just Port.Blocked →
      pure Port.Blocked
    Pass, Nothing →
      QE.throw "Card expected an input value"
    Pass, Just port →
      pure port
    Draftboard, _ →
      pure Port.Draftboard
    Query sql, Just (Port.VarMap varMap) →
      map Port.TaggedResource
        $ evalQuery input sql varMap
    Query sql, _ →
      map Port.TaggedResource
        $ evalQuery input sql Port.emptyVarMap
    Markdown txt, _ →
      MDE.markdownEval input txt
    MarkdownForm model, (Just (Port.SlamDown doc)) →
      lift $ Port.VarMap <$> evalMarkdownForm doc model
    Search query, Just (Port.TaggedResource { resource }) →
      Port.TaggedResource <$> evalSearch input query resource
    Cache pathString, Just (Port.TaggedResource { resource, varMap }) →
      Port.TaggedResource <$> Cache.eval input pathString resource varMap
    Open res, _ →
      Port.TaggedResource <$> evalOpen input res
    Variables model, _ →
      pure $ Port.VarMap $ VariablesE.eval (fst input.cardCoord) input.urlVarMaps model
    DownloadOptions { compress, options }, Just (Port.TaggedResource { resource }) →
      pure $ Port.DownloadOptions { resource, compress, options }
    BuildMetric model, Just (Port.TaggedResource { resource }) →
      BuildMetric.eval model resource
    BuildSankey model, Just (Port.TaggedResource {resource}) →
      BuildSankey.eval model resource
    BuildGauge model, Just (Port.TaggedResource {resource}) →
      BuildGauge.eval model resource
    BuildGraph model, Just (Port.TaggedResource {resource}) →
      BuildGraph.eval model resource
    BuildPie model, Just (Port.TaggedResource {resource}) →
      BuildPie.eval model resource
    BuildRadar model, Just (Port.TaggedResource {resource}) →
      BuildRadar.eval model resource
    BuildArea model, Just (Port.TaggedResource {resource, axes}) →
      BuildArea.eval model resource axes
    BuildLine model, Just (Port.TaggedResource {resource, axes}) →
      BuildLine.eval model resource axes
    BuildBar model, Just (Port.TaggedResource {resource, axes}) →
      BuildBar.eval model resource axes
    BuildScatter model, Just (Port.TaggedResource {resource}) →
      BuildScatter.eval model resource
    BuildFunnel model, Just (Port.TaggedResource {resource}) →
      BuildFunnel.eval model resource
    BuildHeatmap model, Just (Port.TaggedResource {resource, axes}) →
      BuildHeatmap.eval model resource axes
    BuildBoxplot model, Just (Port.TaggedResource {resource}) →
      BuildBoxplot.eval model resource
    BuildPivotTable model, Just (Port.TaggedResource tr) →
      BuildPivotTable.eval model tr
    BuildPunchCard model, Just (Port.TaggedResource {resource, axes}) →
      BuildPunchCard.eval model resource axes
    BuildCandlestick model, Just (Port.TaggedResource {resource, axes}) →
      BuildCandlestick.eval model resource axes
    BuildParallel model, Just (Port.TaggedResource {resource}) →
      BuildParallel.eval model resource
    e, i →
      QE.throw $ "Card received unexpected input type; " <> tagEval e <> " | " <> Port.tagPort i

evalMarkdownForm
  ∷ ∀ m
  . (Monad m, Affable SlamDataEffects m)
  ⇒ (Port.VarMap × (SD.SlamDownP Port.VarMapValue))
  → MD.Model
  → m Port.VarMap
evalMarkdownForm (vm × doc) model = do
  let inputState = SDH.formStateFromDocument doc
  -- TODO: find a way to smash these annotations if possible -js
  thisVarMap ←
    fromEff (MDS.formStateToVarMap inputState model.state ∷ Eff.Eff SlamDataEffects Port.VarMap)
  pure $ thisVarMap `SM.union` vm

evalOpen
  ∷ ∀ m
  . (Monad m, QuasarDSL m)
  ⇒ CET.CardEvalInput
  → R.Resource
  → CET.CardEvalT m Port.TaggedResourcePort
evalOpen info res = do
  filePath ←
    maybe (QE.throw "No resource is selected") pure
      $ res ^? R._filePath
  msg ←
    CET.liftQ
      $ QFS.messageIfFileNotFound
        filePath
        ("File " ⊕ Path.printPath filePath ⊕ " doesn't exist")
  case msg of
    Nothing → do
      axes ←
        CET.liftQ $ QQ.axes filePath 20
      CET.addSource filePath
      pure { resource: filePath, tag: Nothing, axes, varMap: Nothing }
    Just err →
      QE.throw err

evalQuery
  ∷ ∀ f m
  . (Monad m, Parallel f m, QuasarDSL m)
  ⇒ CET.CardEvalInput
  → SQL
  → Port.VarMap
  → CET.CardEvalT m Port.TaggedResourcePort
evalQuery info sql varMap = do
  let
    resource =
      CET.temporaryOutputResource info
    backendPath =
      Left $ fromMaybe Path.rootDir (Path.parentDir resource)
  { inputs } ← CET.liftQ
    $ lmap (QE.prefixMessage "Error compiling query")
    <$> QQ.compile backendPath sql (renderVarMapValue <$> varMap)
  validateResources inputs
  CET.addSources inputs
  axes ← CET.liftQ do
    QQ.viewQuery backendPath resource sql (renderVarMapValue <$> varMap)
    QFS.messageIfFileNotFound resource "Requested collection doesn't exist"
    QQ.axes resource 20
  pure { resource, tag: pure sql, axes, varMap: Just varMap }

evalSearch
  ∷ ∀ f m
  . (Monad m, Parallel f m, QuasarDSL m)
  ⇒ CET.CardEvalInput
  → String
  → FilePath
  → CET.CardEvalT m Port.TaggedResourcePort
evalSearch info queryText resource = do
  query ← case SS.mkQuery queryText of
    Left _ → QE.throw "Incorrect query string"
    Right q → pure q

  fields ← CET.liftQ do
    QFS.messageIfFileNotFound
      resource
      ("Input resource " ⊕ Path.printPath resource ⊕ " doesn't exist")
    QQ.fields resource

  let
    template = Search.queryToSQL fields query
    sql = QQ.templated resource template
    outputResource = CET.temporaryOutputResource info

  compileResult ← lift $ QQ.compile (Right resource) sql SM.empty

  case compileResult of
    Left err →
      case GE.fromQError err of
        Left msg → QE.throw $ "Error compiling query: " ⊕ msg
        Right _ → QE.throw $ "Error compiling query: " ⊕ QE.printQError err
    Right { inputs } → do
      validateResources inputs
      CET.addSources inputs

  axes ← CET.liftQ do
    QQ.viewQuery (Right resource) outputResource template SM.empty
    QFS.messageIfFileNotFound
      outputResource
      "Error making search temporary resource"
    QQ.axes outputResource 20

  pure { resource: outputResource, tag: pure sql, axes, varMap: Nothing }

runEvalCard
  ∷ ∀ f m
  . (Monad m, Parallel f m, QuasarDSL m, Affable SlamDataEffects m)
  ⇒ CET.CardEvalInput
  → Eval
  → m (Either GE.GlobalError (Port.Port × (Set.Set AdditionalSource)))
runEvalCard input =
  CET.runCardEvalT ∘ evalCard input

validateResources
  ∷ ∀ f m t
  . (Functor m, QuasarDSL m, Parallel f m, Foldable t)
  ⇒ t FilePath
  → CET.CardEvalT m Unit
validateResources =
  parTraverse_ \path → do
    noAccess ← lift $ QFS.fileNotAccessible path
    for_ noAccess \reason →
      throwError $ QE.prefixMessage ("Resource `" ⊕ Path.printPath path ⊕ "` is unavailable") reason

modelToEval
  ∷ Model.AnyCardModel
  → String ⊹ Eval
modelToEval = case _ of
  Model.Ace CT.SQLMode model →
    pure $ Query $ fromMaybe "" $ _.text <$> model
  Model.Ace CT.MarkdownMode model →
    pure $ Markdown $ fromMaybe "" $ _.text <$> model
  Model.Markdown model →
    pure $ MarkdownForm model
  Model.Search txt →
    pure $ Search txt
  Model.Cache fp →
    pure $ Cache fp
  Model.Open (Just res) →
    pure $ Open res
  -- Do we need this? evalOpen is called only if Open has Just res
  Model.Open _ →
    Left "Open model missing resource"
  Model.Variables model →
    pure $ Variables model
  Model.DownloadOptions model →
    pure $ DownloadOptions model
  Model.Draftboard _ →
    pure Draftboard
  Model.BuildMetric model  →
    pure $ BuildMetric model
  Model.BuildSankey model →
    pure $ BuildSankey model
  Model.BuildGauge model →
    pure $ BuildGauge model
  Model.BuildGraph model →
    pure $ BuildGraph model
  Model.BuildPie model →
    pure $ BuildPie model
  Model.BuildRadar model →
    pure $ BuildRadar model
  Model.BuildArea model →
    pure $ BuildArea model
  Model.BuildLine model →
    pure $ BuildLine model
  Model.BuildBar model →
    pure $ BuildBar model
  Model.BuildScatter model →
    pure $ BuildScatter model
  Model.BuildFunnel model →
    pure $ BuildFunnel model
  Model.BuildHeatmap model →
    pure $ BuildHeatmap model
  Model.BuildBoxplot model →
    pure $ BuildBoxplot model
  Model.BuildPivotTable model →
    pure $ BuildPivotTable model
  Model.BuildPunchCard model →
    pure $ BuildPunchCard model
  Model.BuildCandlestick model →
    pure $ BuildCandlestick model
  Model.BuildParallel model →
    pure $ BuildParallel model
  _ →
    pure Pass

{-
Copyright 2016 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 SlamData.Workspace.Card.Eval where

import SlamData.Prelude

import Control.Monad.Eff as Eff
import Control.Monad.Aff.Free (class Affable, fromEff)

import Data.Lens ((^?))
import Data.Map as Map
import Data.Path.Pathy as Path
import Data.StrMap as SM
import Data.Set as Set

import Quasar.Types (SQL, FilePath)

import SlamData.Effects (SlamDataEffects)
import SlamData.FileSystem.Resource as R
import SlamData.GlobalError as GE
import SlamData.Quasar.Class (class QuasarDSL)
import SlamData.Quasar.Error as QE
import SlamData.Quasar.FS as QFS
import SlamData.Quasar.Query as QQ
import SlamData.Workspace.Card.BuildChart.Area.Eval as BuildArea
import SlamData.Workspace.Card.BuildChart.Bar.Eval as BuildBar
import SlamData.Workspace.Card.BuildChart.Boxplot.Eval as BuildBoxplot
import SlamData.Workspace.Card.BuildChart.Candlestick.Eval as BuildCandlestick
import SlamData.Workspace.Card.BuildChart.Funnel.Eval as BuildFunnel
import SlamData.Workspace.Card.BuildChart.Gauge.Eval as BuildGauge
import SlamData.Workspace.Card.BuildChart.Graph.Eval as BuildGraph
import SlamData.Workspace.Card.BuildChart.Heatmap.Eval as BuildHeatmap
import SlamData.Workspace.Card.BuildChart.Line.Eval as BuildLine
import SlamData.Workspace.Card.BuildChart.Metric.Eval as BuildMetric
import SlamData.Workspace.Card.BuildChart.Parallel.Eval as BuildParallel
import SlamData.Workspace.Card.BuildChart.Pie.Eval as BuildPie
import SlamData.Workspace.Card.BuildChart.PivotTable.Eval as BuildPivotTable
import SlamData.Workspace.Card.BuildChart.PunchCard.Eval as BuildPunchCard
import SlamData.Workspace.Card.BuildChart.Radar.Eval as BuildRadar
import SlamData.Workspace.Card.BuildChart.Sankey.Eval as BuildSankey
import SlamData.Workspace.Card.BuildChart.Scatter.Eval as BuildScatter
import SlamData.Workspace.Card.Cache.Eval as Cache
import SlamData.Workspace.Card.CardType as CT
import SlamData.Workspace.Card.DownloadOptions.Component.State as DO
import SlamData.Workspace.Card.Eval.CardEvalT as CET
import SlamData.Workspace.Card.Markdown.Component.State.Core as MDS
import SlamData.Workspace.Card.Markdown.Eval as MDE
import SlamData.Workspace.Card.Markdown.Model as MD
import SlamData.Workspace.Card.Model as Model
import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.Card.Search.Interpret as Search
import SlamData.Workspace.Card.Variables.Eval as VariablesE
import SlamData.Workspace.Card.Variables.Model as Variables
import SlamData.Workspace.Deck.AdditionalSource (AdditionalSource)

import Text.SlamSearch as SS
import Text.Markdown.SlamDown as SD
import Text.Markdown.SlamDown.Halogen.Component.State as SDH

data Eval
  = Pass
  | Query SQL
  | Search String
  | Cache (Maybe String)
  | Error String
  | Markdown String
  | MarkdownForm MD.Model
  | Open R.Resource
  | Variables Variables.Model
  | DownloadOptions DO.State
  | Draftboard
  | BuildMetric BuildMetric.Model
  | BuildSankey BuildSankey.Model
  | BuildGauge BuildGauge.Model
  | BuildGraph BuildGraph.Model
  | BuildPie BuildPie.Model
  | BuildRadar BuildRadar.Model
  | BuildArea BuildArea.Model
  | BuildLine BuildLine.Model
  | BuildBar BuildBar.Model
  | BuildScatter BuildScatter.Model
  | BuildFunnel BuildFunnel.Model
  | BuildHeatmap BuildHeatmap.Model
  | BuildBoxplot BuildBoxplot.Model
  | BuildPivotTable BuildPivotTable.Model
  | BuildPunchCard BuildPunchCard.Model
  | BuildCandlestick BuildCandlestick.Model
  | BuildParallel BuildParallel.Model

tagEval ∷ Eval → String
tagEval = case _ of
  Pass → "Pass"
  Query str → "Query " <> show str
  Search str → "Search " <> show str
  Cache str → "Cache " <> show str
  Error str → "Error " <> show str
  Markdown str → "Markdown " <> show str
  Open res → "Open " <> show res
  MarkdownForm m → "MarkdownForm"
  Variables m → "Variables"
  DownloadOptions m → "DownloadOptions"
  Draftboard → "Draftboard"
  BuildMetric _ → "BuildMetric"
  BuildSankey _ → "BuildSankey"
  BuildGauge _ → "BuildGauge"
  BuildGraph _ → "BuildGraph"
  BuildPie _ → "BuildPie"
  BuildRadar _ → "BuildRadar"
  BuildArea _ → "BuildArea"
  BuildLine _ → "BuildLine"
  BuildBar _ → "BuildBar"
  BuildScatter _ → "BuildScatter"
  BuildFunnel _ → "BuildFunnel"
  BuildHeatmap _ → "BuildHeatmap"
  BuildBoxplot _ → "BuildBoxplot"
  BuildPivotTable _ → "BuildPivotTable"
  BuildPunchCard _ → "BuildPunchCard"
  BuildCandlestick _ → "BuildCandlestick"
  BuildParallel _ → "BuildParallel"

evalCard
  ∷ ∀ f m
  . (Monad m, Parallel f m, QuasarDSL m, Affable SlamDataEffects m)
  ⇒ CET.CardEvalInput
  → Eval
  → CET.CardEvalT m Port.Port
evalCard input =
  case _, input.input of
    Error msg, _ →
      pure $ Port.CardError msg
    _, Just Port.Blocked →
      pure Port.Blocked
    Pass, Nothing →
      QE.throw "Card expected an input value"
    Pass, Just port →
      pure port
    Draftboard, _ →
      pure Port.Draftboard
    Query sql, Just (Port.VarMap varMap) →
      map Port.TaggedResource
        $ evalQuery input sql (fromMaybe SM.empty $ Map.lookup (fst input.cardCoord) input.urlVarMaps) varMap
    Query sql, _ →
      map Port.TaggedResource
        $ evalQuery input sql (fromMaybe SM.empty $ Map.lookup (fst input.cardCoord) input.urlVarMaps) Port.emptyVarMap
    Markdown txt, _ →
      MDE.markdownEval input txt
    MarkdownForm model, (Just (Port.SlamDown doc)) →
      lift $ Port.VarMap <$> evalMarkdownForm doc model
    Search query, Just (Port.TaggedResource { resource }) →
      Port.TaggedResource <$> evalSearch input query resource
    Cache pathString, Just (Port.TaggedResource { resource, varMap }) →
      Port.TaggedResource <$> Cache.eval input pathString resource varMap
    Open res, _ →
      Port.TaggedResource <$> evalOpen input res
    Variables model, _ →
      pure $ Port.VarMap $ VariablesE.eval (fst input.cardCoord) input.urlVarMaps model
    DownloadOptions { compress, options }, Just (Port.TaggedResource { resource }) →
      pure $ Port.DownloadOptions { resource, compress, options }
    BuildMetric model, Just (Port.TaggedResource { resource }) →
      BuildMetric.eval model resource
    BuildSankey model, Just (Port.TaggedResource {resource}) →
      BuildSankey.eval model resource
    BuildGauge model, Just (Port.TaggedResource {resource}) →
      BuildGauge.eval model resource
    BuildGraph model, Just (Port.TaggedResource {resource}) →
      BuildGraph.eval model resource
    BuildPie model, Just (Port.TaggedResource {resource}) →
      BuildPie.eval model resource
    BuildRadar model, Just (Port.TaggedResource {resource}) →
      BuildRadar.eval model resource
    BuildArea model, Just (Port.TaggedResource {resource, axes}) →
      BuildArea.eval model resource axes
    BuildLine model, Just (Port.TaggedResource {resource, axes}) →
      BuildLine.eval model resource axes
    BuildBar model, Just (Port.TaggedResource {resource, axes}) →
      BuildBar.eval model resource axes
    BuildScatter model, Just (Port.TaggedResource {resource}) →
      BuildScatter.eval model resource
    BuildFunnel model, Just (Port.TaggedResource {resource}) →
      BuildFunnel.eval model resource
    BuildHeatmap model, Just (Port.TaggedResource {resource, axes}) →
      BuildHeatmap.eval model resource axes
    BuildBoxplot model, Just (Port.TaggedResource {resource}) →
      BuildBoxplot.eval model resource
    BuildPivotTable model, Just (Port.TaggedResource tr) →
      BuildPivotTable.eval model tr
    BuildPunchCard model, Just (Port.TaggedResource {resource, axes}) →
      BuildPunchCard.eval model resource axes
    BuildCandlestick model, Just (Port.TaggedResource {resource, axes}) →
      BuildCandlestick.eval model resource axes
    BuildParallel model, Just (Port.TaggedResource {resource}) →
      BuildParallel.eval model resource
    e, i →
      QE.throw $ "Card received unexpected input type; " <> tagEval e <> " | " <> Port.tagPort i

evalMarkdownForm
  ∷ ∀ m
  . (Monad m, Affable SlamDataEffects m)
  ⇒ (Port.VarMap × (SD.SlamDownP Port.VarMapValue))
  → MD.Model
  → m Port.VarMap
evalMarkdownForm (vm × doc) model = do
  let inputState = SDH.formStateFromDocument doc
  -- TODO: find a way to smash these annotations if possible -js
  thisVarMap ←
    fromEff (MDS.formStateToVarMap inputState model.state ∷ Eff.Eff SlamDataEffects Port.VarMap)
  pure $ thisVarMap `SM.union` vm

evalOpen
  ∷ ∀ m
  . (Monad m, QuasarDSL m)
  ⇒ CET.CardEvalInput
  → R.Resource
  → CET.CardEvalT m Port.TaggedResourcePort
evalOpen info res = do
  filePath ←
    maybe (QE.throw "No resource is selected") pure
      $ res ^? R._filePath
  msg ←
    CET.liftQ
      $ QFS.messageIfFileNotFound
        filePath
        ("File " ⊕ Path.printPath filePath ⊕ " doesn't exist")
  case msg of
    Nothing → do
      axes ←
        CET.liftQ $ QQ.axes filePath 20
      CET.addSource filePath
      pure { resource: filePath, tag: Nothing, axes, varMap: Nothing }
    Just err →
      QE.throw err

evalQuery
  ∷ ∀ f m
  . (Monad m, Parallel f m, QuasarDSL m)
  ⇒ CET.CardEvalInput
  → SQL
  → Port.URLVarMap
  → Port.VarMap
  → CET.CardEvalT m Port.TaggedResourcePort
evalQuery info sql urlVarMap varMap = do
  let
    varMap' =
      SM.union urlVarMap $ map Port.renderVarMapValue varMap
    resource =
      CET.temporaryOutputResource info
    backendPath =
      Left $ fromMaybe Path.rootDir (Path.parentDir resource)
  { inputs } ← CET.liftQ
    $ lmap (QE.prefixMessage "Error compiling query")
    <$> QQ.compile backendPath sql varMap'
  validateResources inputs
  CET.addSources inputs
  axes ← CET.liftQ do
    QQ.viewQuery backendPath resource sql varMap'
    QFS.messageIfFileNotFound resource "Requested collection doesn't exist"
    QQ.axes resource 20
  pure { resource, tag: pure sql, axes, varMap: Just varMap }

evalSearch
  ∷ ∀ f m
  . (Monad m, Parallel f m, QuasarDSL m)
  ⇒ CET.CardEvalInput
  → String
  → FilePath
  → CET.CardEvalT m Port.TaggedResourcePort
evalSearch info queryText resource = do
  query ← case SS.mkQuery queryText of
    Left _ → QE.throw "Incorrect query string"
    Right q → pure q

  fields ← CET.liftQ do
    QFS.messageIfFileNotFound
      resource
      ("Input resource " ⊕ Path.printPath resource ⊕ " doesn't exist")
    QQ.fields resource

  let
    template = Search.queryToSQL fields query
    sql = QQ.templated resource template
    outputResource = CET.temporaryOutputResource info

  compileResult ← lift $ QQ.compile (Right resource) sql SM.empty

  case compileResult of
    Left err →
      case GE.fromQError err of
        Left msg → QE.throw $ "Error compiling query: " ⊕ msg
        Right _ → QE.throw $ "Error compiling query: " ⊕ QE.printQError err
    Right { inputs } → do
      validateResources inputs
      CET.addSources inputs

  axes ← CET.liftQ do
    QQ.viewQuery (Right resource) outputResource template SM.empty
    QFS.messageIfFileNotFound
      outputResource
      "Error making search temporary resource"
    QQ.axes outputResource 20

  pure { resource: outputResource, tag: pure sql, axes, varMap: Nothing }

runEvalCard
  ∷ ∀ f m
  . (Monad m, Parallel f m, QuasarDSL m, Affable SlamDataEffects m)
  ⇒ CET.CardEvalInput
  → Eval
  → m (Either GE.GlobalError (Port.Port × (Set.Set AdditionalSource)))
runEvalCard input =
  CET.runCardEvalT ∘ evalCard input

validateResources
  ∷ ∀ f m t
  . (Functor m, QuasarDSL m, Parallel f m, Foldable t)
  ⇒ t FilePath
  → CET.CardEvalT m Unit
validateResources =
  parTraverse_ \path → do
    noAccess ← lift $ QFS.fileNotAccessible path
    for_ noAccess \reason →
      throwError $ QE.prefixMessage ("Resource `" ⊕ Path.printPath path ⊕ "` is unavailable") reason

modelToEval
  ∷ Model.AnyCardModel
  → String ⊹ Eval
modelToEval = case _ of
  Model.Ace CT.SQLMode model →
    pure $ Query $ fromMaybe "" $ _.text <$> model
  Model.Ace CT.MarkdownMode model →
    pure $ Markdown $ fromMaybe "" $ _.text <$> model
  Model.Markdown model →
    pure $ MarkdownForm model
  Model.Search txt →
    pure $ Search txt
  Model.Cache fp →
    pure $ Cache fp
  Model.Open (Just res) →
    pure $ Open res
  -- Do we need this? evalOpen is called only if Open has Just res
  Model.Open _ →
    Left "Open model missing resource"
  Model.Variables model →
    pure $ Variables model
  Model.DownloadOptions model →
    pure $ DownloadOptions model
  Model.Draftboard _ →
    pure Draftboard
  Model.BuildMetric model  →
    pure $ BuildMetric model
  Model.BuildSankey model →
    pure $ BuildSankey model
  Model.BuildGauge model →
    pure $ BuildGauge model
  Model.BuildGraph model →
    pure $ BuildGraph model
  Model.BuildPie model →
    pure $ BuildPie model
  Model.BuildRadar model →
    pure $ BuildRadar model
  Model.BuildArea model →
    pure $ BuildArea model
  Model.BuildLine model →
    pure $ BuildLine model
  Model.BuildBar model →
    pure $ BuildBar model
  Model.BuildScatter model →
    pure $ BuildScatter model
  Model.BuildFunnel model →
    pure $ BuildFunnel model
  Model.BuildHeatmap model →
    pure $ BuildHeatmap model
  Model.BuildBoxplot model →
    pure $ BuildBoxplot model
  Model.BuildPivotTable model →
    pure $ BuildPivotTable model
  Model.BuildPunchCard model →
    pure $ BuildPunchCard model
  Model.BuildCandlestick model →
    pure $ BuildCandlestick model
  Model.BuildParallel model →
    pure $ BuildParallel model
  _ →
    pure Pass