Progress on #154: Add custom call support for Czar Choices house rule.

client/src/elm/MassiveDecks/Card/Call.elm

@@ -11,6 +11,7 @@ import Html.Attributes as HtmlA
 import MassiveDecks.Card as Card
 import MassiveDecks.Card.Model exposing (..)
 import MassiveDecks.Card.Parts as Parts exposing (Parts)
+import MassiveDecks.Card.Source.Model as Source
 import MassiveDecks.Game.Rules exposing (Rules)
 import MassiveDecks.Model exposing (Shared)
 import MassiveDecks.Pages.Lobby.Configure.Decks as Decks
@@ -41,13 +42,32 @@ viewFilled shared config side attributes slotAttrs fillWith call =
     viewInternal shared config side attributes (Parts.viewFilled slotAttrs fillWith) call
 
 
+{-| Render a potentially blank card to HTML.
+-}
+viewPotentiallyCustom : Shared -> Config -> Side -> (String -> msg) -> (String -> msg) -> List (Html.Attribute msg) -> Call -> Html msg
+viewPotentiallyCustom shared config side update canonicalize attributes call =
+    case call.details.source of
+        Source.Custom ->
+            viewCustom shared config side update canonicalize attributes call
+
+        _ ->
+            view shared config side attributes call
+
+
 {-| Render an unknown response to HTML, face-down.
 -}
 viewUnknown : Shared -> List (Html.Attribute msg) -> Html msg
 viewUnknown shared attributes =
     Card.viewUnknown shared "call" attributes
 
 
+{-| Render a blank card to HTML.
+-}
+viewCustom : Shared -> Config -> Side -> (String -> msg) -> (String -> msg) -> List (Html.Attribute msg) -> Call -> Html msg
+viewCustom shared config side update canonicalize attributes call =
+    Html.div [] []
+
+
 
 {- Private -}
 

client/src/elm/MassiveDecks/Card/Call/Editor.elm

@@ -0,0 +1,336 @@
+module MassiveDecks.Card.Call.Editor exposing
+    ( init
+    , toParts
+    , update
+    , view
+    )
+
+import FontAwesome.Icon as Icon
+import FontAwesome.Layering as Icon
+import FontAwesome.Solid as Icon
+import Html exposing (Html)
+import Html.Attributes as HtmlA
+import Html.Events as HtmlE
+import Html5.DragDrop as DragDrop
+import List.Extra as List
+import MassiveDecks.Card.Call.Editor.Model exposing (..)
+import MassiveDecks.Card.Model as Card
+import MassiveDecks.Card.Parts as Parts exposing (Parts)
+import MassiveDecks.Card.Parts.Part as Part
+import MassiveDecks.Components.Form as Form
+import MassiveDecks.Components.Form.Message as Message
+import MassiveDecks.Model exposing (Shared)
+import MassiveDecks.Strings as Strings exposing (MdString)
+import MassiveDecks.Strings.Languages as Lang
+import MassiveDecks.Util.Html as Html
+import MassiveDecks.Util.Maybe as Maybe
+import MassiveDecks.Util.NeList as NeList
+import Material.Button as Button
+import Material.IconButton as IconButton
+import Material.TextArea as TextArea
+import Material.TextField as TextField
+
+
+init : Card.Call -> Model
+init source =
+    { source = source
+    , parts = source.body |> Parts.toList |> List.intersperse [ Parts.Text "\n" Part.NoStyle ] |> List.concat
+    , selected = Nothing
+    , error = Nothing
+    , dragDrop = DragDrop.init
+    }
+
+
+update : Msg -> Model -> ( Model, Cmd msg )
+update msg model =
+    case msg of
+        Select index ->
+            ( { model | selected = index }, Cmd.none )
+
+        Add index part ->
+            ( model |> changeParts (Just index) (model.parts |> insertAt index part), Cmd.none )
+
+        Set index part ->
+            case part of
+                Parts.Text "" _ ->
+                    ( model |> changeParts Nothing (model.parts |> List.removeAt index), Cmd.none )
+
+                _ ->
+                    ( model |> changeParts model.selected (model.parts |> List.setAt index part), Cmd.none )
+
+        Move index by ->
+            let
+                from =
+                    index
+
+                to =
+                    index + by
+            in
+            ( model |> changeParts (Just to) (model.parts |> List.swapAt from to), Cmd.none )
+
+        Remove index ->
+            ( model |> changeParts Nothing (model.parts |> List.removeAt index), Cmd.none )
+
+        NoOp ->
+            ( model, Cmd.none )
+
+        DragDropMsg dragDropMsg ->
+            let
+                ( newDragDrop, drag ) =
+                    DragDrop.update dragDropMsg model.dragDrop
+
+                newModel =
+                    case drag of
+                        Just ( from, to, _ ) ->
+                            model |> changeParts (Just to) (model.parts |> List.swapAt from to)
+
+                        Nothing ->
+                            model
+            in
+            ( { newModel | dragDrop = newDragDrop }, Cmd.none )
+
+
+view : (Msg -> msg) -> Shared -> Model -> Html msg
+view wrap shared { parts, selected, error } =
+    let
+        partFor index =
+            parts |> List.getAt index |> Maybe.map (\p -> ( index, p ))
+
+        interactions index =
+            List.concat
+                [ [ HtmlE.onClick (index |> Just |> Select |> wrap) ]
+                , DragDrop.draggable (DragDropMsg >> wrap) index
+                , DragDrop.droppable (DragDropMsg >> wrap) index
+                ]
+
+        renderPart index part =
+            case part of
+                Parts.Text text style ->
+                    Part.styledElement
+                        style
+                        (HtmlA.classList [ ( "text", True ), ( "selected", Just index == selected ) ] :: interactions index)
+                        [ Html.text text ]
+
+                Parts.Slot slot transform style ->
+                    Part.transformedStyledElement
+                        transform
+                        style
+                        (HtmlA.classList [ ( "slot", True ), ( "selected", Just index == selected ) ] :: interactions index)
+                        [ Html.span [] [ Strings.Blank |> Lang.string shared |> String.toLower |> Html.text ]
+                        , Html.span [ HtmlA.class "index" ] [ slot + 1 |> String.fromInt |> Html.text ]
+                        ]
+
+        renderedParts =
+            parts |> List.indexedMap renderPart
+
+        addAction part =
+            Add (parts |> List.length) part |> wrap
+
+        nextSlotIndex =
+            parts |> Parts.nextSlotIndex
+
+        addSlot =
+            addAction (Parts.Slot nextSlotIndex Part.NoTransform Part.NoStyle)
+
+        inlineControls =
+            Html.p []
+                [ Button.view shared Button.Outlined Strings.AddText Strings.AddText (Icon.plus |> Icon.viewIcon) [ addAction (Parts.Text "..." Part.NoStyle) |> HtmlE.onClick ]
+                , Button.view shared Button.Outlined Strings.AddSlot Strings.AddSlot (Icon.plus |> Icon.viewIcon) [ addSlot |> HtmlE.onClick ]
+                ]
+
+        selectedPart =
+            selected |> Maybe.andThen partFor
+
+        editor =
+            case selectedPart of
+                Just ( index, Parts.Text text style ) ->
+                    Form.section shared
+                        "part-editor"
+                        (TextArea.view
+                            [ (\t -> Set index (Parts.Text t style) |> wrap) |> HtmlE.onInput
+                            , HtmlA.class "text part-editor"
+                            , HtmlA.value text
+                            ]
+                            []
+                        )
+                        []
+
+                Just ( index, Parts.Slot slotIndex transform style ) ->
+                    let
+                        setSlotIndex str =
+                            str
+                                |> String.toInt
+                                |> Maybe.map (\i -> Set index (Parts.Slot (i - 1) transform style))
+                                |> Maybe.withDefault NoOp
+                                |> wrap
+                    in
+                    Form.section shared
+                        "part-editor"
+                        (TextField.view shared
+                            Strings.Blank
+                            TextField.Number
+                            (slotIndex + 1 |> String.fromInt)
+                            [ HtmlA.min "1"
+                            , HtmlE.onInput setSlotIndex
+                            ]
+                        )
+                        [ Message.info Strings.SlotIndexExplanation ]
+
+                Nothing ->
+                    Html.nothing
+
+        viewError e =
+            Message.errorWithFix e [ { description = Strings.AddSlot, icon = Icon.plus, action = addSlot } ]
+                |> Message.view shared
+    in
+    Html.div [ HtmlA.class "call-editor" ]
+        [ Html.div [ HtmlA.class "parts" ] [ Html.p [] renderedParts, inlineControls ]
+        , controls wrap shared (List.length parts - 1) selectedPart
+        , editor
+        , error |> Maybe.andThen viewError |> Maybe.withDefault Html.nothing
+        ]
+
+
+toParts : List Parts.Part -> Result MdString Parts
+toParts parts =
+    let
+        splitOnNewLines part =
+            case part of
+                Parts.Slot _ _ _ ->
+                    Just part
+
+                Parts.Text text _ ->
+                    if text == "\n" then
+                        Nothing
+
+                    else
+                        Just part
+    in
+    parts |> List.concatMap separateNewLines |> splitMap splitOnNewLines |> Parts.fromList
+
+
+
+{- Private -}
+
+
+changeParts : Maybe Index -> List Parts.Part -> Model -> Model
+changeParts selected newParts model =
+    let
+        source =
+            model.source
+
+        ( newSource, error ) =
+            case newParts |> toParts of
+                Ok body ->
+                    ( { source | body = body }, Nothing )
+
+                Err e ->
+                    ( source, Just e )
+    in
+    { model | parts = newParts, selected = selected, source = newSource, error = error }
+
+
+controls : (Msg -> msg) -> Shared -> Int -> Maybe ( Index, Parts.Part ) -> Html msg
+controls wrap shared max selected =
+    let
+        sep =
+            Html.div [ HtmlA.class "separator" ] []
+
+        index =
+            selected |> Maybe.map Tuple.first
+
+        move by test =
+            index |> Maybe.andThen (\i -> Move i by |> wrap |> Maybe.justIf (test i))
+
+        generalControls =
+            [ IconButton.view shared Strings.Remove (Icon.minus |> Icon.present |> NeList.just) (index |> Maybe.map (Remove >> wrap))
+            , IconButton.view shared Strings.MoveLeft (Icon.arrowLeft |> Icon.present |> NeList.just) (move -1 ((<) 0))
+            , IconButton.view shared Strings.MoveRight (Icon.arrowRight |> Icon.present |> NeList.just) (move 1 ((>) max))
+            ]
+
+        setIfDifferent old updated new =
+            index |> Maybe.andThen (\i -> Set i (updated new) |> wrap |> Maybe.justIf (old /= new))
+
+        styleControls setStyle =
+            [ IconButton.view shared Strings.Normal (Icon.font |> Icon.present |> NeList.just) (setStyle Part.NoStyle)
+            , IconButton.view shared Strings.Emphasise (Icon.italic |> Icon.present |> NeList.just) (setStyle Part.Em)
+            ]
+
+        transformControls setTransform =
+            let
+                textIcon text =
+                    Icon.layers [] [ Icon.text [] text ]
+            in
+            [ IconButton.viewCustomIcon shared Strings.Normal (textIcon "aa") (setTransform Part.NoTransform)
+            , IconButton.viewCustomIcon shared Strings.Capitalise (textIcon "Aa") (setTransform Part.Capitalize)
+            , IconButton.viewCustomIcon shared Strings.UpperCase (textIcon "AA") (setTransform Part.UpperCase)
+            ]
+
+        ( replaceStyle, replaceTransform ) =
+            case selected of
+                Just ( _, Parts.Slot slot transform style ) ->
+                    ( setIfDifferent style (Parts.Slot slot transform)
+                    , setIfDifferent transform (\t -> Parts.Slot slot t style)
+                    )
+
+                Just ( _, Parts.Text text style ) ->
+                    ( setIfDifferent style (Parts.Text text), always Nothing )
+
+                _ ->
+                    ( always Nothing, always Nothing )
+
+        collected =
+            List.concat
+                [ generalControls
+                , [ sep ]
+                , styleControls replaceStyle
+                , [ sep ]
+                , transformControls replaceTransform
+                ]
+    in
+    Html.div [ HtmlA.class "controls" ] collected
+
+
+splitMap : (x -> Maybe y) -> List x -> List (List y)
+splitMap map values =
+    let
+        internal vs =
+            case vs of
+                first :: rest ->
+                    let
+                        ( current, lines ) =
+                            internal rest
+                    in
+                    case map first of
+                        Just value ->
+                            ( value :: current, lines )
+
+                        Nothing ->
+                            ( [], current :: lines )
+
+                [] ->
+                    ( [], [] )
+
+        ( a, b ) =
+            values |> internal
+    in
+    a :: b
+
+
+separateNewLines : Parts.Part -> List Parts.Part
+separateNewLines part =
+    case part of
+        Parts.Text string style ->
+            String.split "\n" string |> List.map (\t -> Parts.Text t style) |> List.intersperse (Parts.Text "\n" style)
+
+        Parts.Slot _ _ _ ->
+            [ part ]
+
+
+insertAt : Int -> a -> List a -> List a
+insertAt index item items =
+    let
+        ( start, end ) =
+            List.splitAt index items
+    in
+    start ++ item :: end