Merge pull request #483 from eikek/card-title

Card title

modules/webapp/src/main/elm/Comp/ItemCard.elm

@@ -11,13 +11,13 @@ module Comp.ItemCard exposing
 import Api
 import Api.Model.AttachmentLight exposing (AttachmentLight)
 import Api.Model.HighlightEntry exposing (HighlightEntry)
-import Api.Model.IdName exposing (IdName)
 import Api.Model.ItemLight exposing (ItemLight)
 import Comp.LinkTarget exposing (LinkTarget(..))
 import Data.Direction
 import Data.Fields
 import Data.Icons as Icons
 import Data.ItemSelection exposing (ItemSelection)
+import Data.ItemTemplate as IT
 import Data.UiSettings exposing (UiSettings)
 import Html exposing (..)
 import Html.Attributes exposing (..)
@@ -30,7 +30,6 @@ import Util.ItemDragDrop as DD
 import Util.List
 import Util.Maybe
 import Util.String
-import Util.Time
 
 
 type alias Model =
@@ -220,8 +219,7 @@ metaDataContent settings item =
             Data.UiSettings.fieldHidden settings f
 
         dueDate =
-            Maybe.map Util.Time.formatDateShort item.dueDate
+            IT.render IT.dueDateShort item
-                |> Maybe.withDefault ""
     in
     div [ class "content" ]
         [ div [ class "ui horizontal link list" ]
@@ -268,7 +266,7 @@ metaDataContent settings item =
                     [ class "item"
                     , title "Source"
                     ]
-                    [ text item.source
+                    [ IT.render IT.source item |> text
                     ]
                 , div
                     [ classList
@@ -321,6 +319,12 @@ mainContent cardAction cardColor isConfirmed settings _ item =
 
         fieldHidden f =
             Data.UiSettings.fieldHidden settings f
+
+        titlePattern =
+            settings.cardTitleTemplate.template
+
+        subtitlePattern =
+            settings.cardSubtitleTemplate.template
     in
     a
         [ class "content"
@@ -329,18 +333,16 @@ mainContent cardAction cardColor isConfirmed settings _ item =
         ]
         [ if fieldHidden Data.Fields.Direction then
             div [ class "header" ]
-                [ Util.String.underscoreToSpace item.name |> text
+                [ IT.render titlePattern item |> text
                 ]
 
           else
             div
                 [ class "header"
-                , Data.Direction.labelFromMaybe item.direction
+                , IT.render IT.direction item |> title
-                    |> title
                 ]
                 [ dirIcon
-                , Util.String.underscoreToSpace item.name
+                , IT.render titlePattern item |> text
-                    |> text
                 ]
         , div
             [ classList
@@ -358,7 +360,7 @@ mainContent cardAction cardColor isConfirmed settings _ item =
                 , ( "invisible hidden", fieldHidden Data.Fields.Date )
                 ]
             ]
-            [ Util.Time.formatDate item.date |> text
+            [ IT.render subtitlePattern item |> text
             ]
         , div [ class "meta description" ]
             [ mainTagsAndFields settings item

modules/webapp/src/main/elm/Comp/UiSettingsForm.elm

@@ -16,12 +16,15 @@ import Data.BasicSize exposing (BasicSize)
 import Data.Color exposing (Color)
 import Data.Fields exposing (Field)
 import Data.Flags exposing (Flags)
-import Data.UiSettings exposing (Pos(..), UiSettings)
+import Data.ItemTemplate as IT exposing (ItemTemplate)
+import Data.UiSettings exposing (ItemPattern, Pos(..), UiSettings)
 import Dict exposing (Dict)
 import Html exposing (..)
 import Html.Attributes exposing (..)
-import Html.Events exposing (onCheck)
+import Html.Events exposing (onCheck, onClick, onInput)
 import Http
+import Markdown
+import Util.Maybe
 import Util.Tag
 
 
@@ -45,6 +48,44 @@ type alias Model =
     , searchMenuVisible : Bool
     , editMenuVisible : Bool
     , cardPreviewSize : BasicSize
+    , cardTitlePattern : PatternModel
+    , cardSubtitlePattern : PatternModel
+    , showPatternHelp : Bool
+    }
+
+
+type alias PatternModel =
+    { pattern : Maybe String
+    , current : ItemTemplate
+    , result : Result String ItemTemplate
+    }
+
+
+initPatternModel : ItemPattern -> PatternModel
+initPatternModel ip =
+    { pattern = Just ip.pattern
+    , current = ip.template
+    , result = Ok ip.template
+    }
+
+
+updatePatternModel : PatternModel -> String -> PatternModel
+updatePatternModel pm str =
+    let
+        result =
+            case IT.readTemplate str of
+                Just t ->
+                    Ok t
+
+                Nothing ->
+                    Err "Template invalid, check for unclosed variables."
+
+        p =
+            Util.Maybe.fromString str
+    in
+    { pattern = p
+    , current = Result.withDefault pm.current result
+    , result = result
     }
 
 
@@ -97,6 +138,9 @@ init flags settings =
       , searchMenuVisible = settings.searchMenuVisible
       , editMenuVisible = settings.editMenuVisible
       , cardPreviewSize = settings.cardPreviewSize
+      , cardTitlePattern = initPatternModel settings.cardTitleTemplate
+      , cardSubtitlePattern = initPatternModel settings.cardSubtitleTemplate
+      , showPatternHelp = False
       }
     , Api.getTags flags "" GetTagsResp
     )
@@ -117,6 +161,9 @@ type Msg
     | ToggleSearchMenuVisible
     | ToggleEditMenuVisible
     | CardPreviewSizeMsg Comp.BasicSizeField.Msg
+    | SetCardTitlePattern String
+    | SetCardSubtitlePattern String
+    | TogglePatternHelpMsg
 
 
 
@@ -319,6 +366,55 @@ update sett msg model =
             , newSettings
             )
 
+        SetCardTitlePattern str ->
+            let
+                pm =
+                    model.cardTitlePattern
+
+                pm_ =
+                    updatePatternModel pm str
+
+                newSettings =
+                    if pm_.pattern /= Just sett.cardTitleTemplate.pattern then
+                        Just
+                            { sett
+                                | cardTitleTemplate =
+                                    ItemPattern
+                                        (Maybe.withDefault "" pm_.pattern)
+                                        pm_.current
+                            }
+
+                    else
+                        Nothing
+            in
+            ( { model | cardTitlePattern = pm_ }, newSettings )
+
+        SetCardSubtitlePattern str ->
+            let
+                pm =
+                    model.cardSubtitlePattern
+
+                pm_ =
+                    updatePatternModel pm str
+
+                newSettings =
+                    if pm_.pattern /= Just sett.cardSubtitleTemplate.pattern then
+                        Just
+                            { sett
+                                | cardSubtitleTemplate =
+                                    ItemPattern
+                                        (Maybe.withDefault "" pm_.pattern)
+                                        pm_.current
+                            }
+
+                    else
+                        Nothing
+            in
+            ( { model | cardSubtitlePattern = pm_ }, newSettings )
+
+        TogglePatternHelpMsg ->
+            ( { model | showPatternHelp = not model.showPatternHelp }, Nothing )
+
 
 
 --- View
@@ -369,6 +465,51 @@ view flags _ model =
                 "Size of item preview"
                 model.cardPreviewSize
             )
+        , div [ class "field" ]
+            [ label []
+                [ text "Card Title Pattern"
+                , a
+                    [ class "right-float"
+                    , title "Toggle pattern help text"
+                    , href "#"
+                    , onClick TogglePatternHelpMsg
+                    ]
+                    [ i [ class "help link icon" ] []
+                    ]
+                ]
+            , input
+                [ type_ "text"
+                , Maybe.withDefault "" model.cardTitlePattern.pattern |> value
+                , onInput SetCardTitlePattern
+                ]
+                []
+            ]
+        , div [ class "field" ]
+            [ label []
+                [ text "Card Subtitle Pattern"
+                , a
+                    [ class "right-float"
+                    , title "Toggle pattern help text"
+                    , href "#"
+                    , onClick TogglePatternHelpMsg
+                    ]
+                    [ i [ class "help link icon" ] []
+                    ]
+                ]
+            , input
+                [ type_ "text"
+                , Maybe.withDefault "" model.cardSubtitlePattern.pattern |> value
+                , onInput SetCardSubtitlePattern
+                ]
+                []
+            ]
+        , Markdown.toHtml
+            [ classList
+                [ ( "ui message", True )
+                , ( "hidden", not model.showPatternHelp )
+                ]
+            ]
+            IT.helpMessage
         , div [ class "ui dividing header" ]
             [ text "Search Menu" ]
         , div [ class "field" ]

modules/webapp/src/main/elm/Data/ItemTemplate.elm

@@ -0,0 +1,386 @@
+module Data.ItemTemplate exposing
+    ( ItemTemplate
+    , concEquip
+    , concPerson
+    , concat
+    , concerning
+    , corrOrg
+    , corrPerson
+    , correspondent
+    , dateLong
+    , dateShort
+    , direction
+    , dueDateLong
+    , dueDateShort
+    , empty
+    , fileCount
+    , folder
+    , from
+    , fromMaybe
+    , helpMessage
+    , isEmpty
+    , literal
+    , map
+    , name
+    , nonEmpty
+    , readTemplate
+    , render
+    , source
+    , splitTokens
+    )
+
+import Api.Model.IdName exposing (IdName)
+import Api.Model.ItemLight exposing (ItemLight)
+import Data.Direction
+import Set
+import Util.List
+import Util.String
+import Util.Time
+
+
+type ItemTemplate
+    = ItemTemplate (ItemLight -> String)
+
+
+readTemplate : String -> Maybe ItemTemplate
+readTemplate str =
+    let
+        read tokens =
+            List.map patternToken tokens
+                |> concat
+    in
+    if str == "" then
+        Just empty
+
+    else
+        Maybe.map read (splitTokens str)
+
+
+render : ItemTemplate -> ItemLight -> String
+render pattern item =
+    case pattern of
+        ItemTemplate f ->
+            f item
+
+
+isEmpty : ItemTemplate -> ItemLight -> Bool
+isEmpty pattern item =
+    render pattern item |> String.isEmpty
+
+
+nonEmpty : ItemTemplate -> ItemLight -> Bool
+nonEmpty pattern item =
+    isEmpty pattern item |> not
+
+
+
+--- Pattern Combinators
+
+
+map : (String -> String) -> ItemTemplate -> ItemTemplate
+map f pattern =
+    case pattern of
+        ItemTemplate p ->
+            from (p >> f)
+
+
+map2 : (String -> String -> String) -> ItemTemplate -> ItemTemplate -> ItemTemplate
+map2 f pattern1 pattern2 =
+    case ( pattern1, pattern2 ) of
+        ( ItemTemplate p1, ItemTemplate p2 ) ->
+            from (\i -> f (p1 i) (p2 i))
+
+
+combine : String -> ItemTemplate -> ItemTemplate -> ItemTemplate
+combine sep p1 p2 =
+    map2
+        (\s1 ->
+            \s2 ->
+                List.filter (String.isEmpty >> not) [ s1, s2 ]
+                    |> String.join sep
+        )
+        p1
+        p2
+
+
+concat : List ItemTemplate -> ItemTemplate
+concat patterns =
+    from
+        (\i ->
+            List.map (\p -> render p i) patterns
+                |> String.join ""
+        )
+
+
+firstNonEmpty : List ItemTemplate -> ItemTemplate
+firstNonEmpty patterns =
+    from
+        (\i ->
+            List.map (\p -> render p i) patterns
+                |> List.filter (String.isEmpty >> not)
+                |> List.head
+                |> Maybe.withDefault ""
+        )
+
+
+
+--- Patterns
+
+
+from : (ItemLight -> String) -> ItemTemplate
+from f =
+    ItemTemplate f
+
+
+fromMaybe : (ItemLight -> Maybe String) -> ItemTemplate
+fromMaybe f =
+    ItemTemplate (f >> Maybe.withDefault "")
+
+
+literal : String -> ItemTemplate
+literal str =
+    ItemTemplate (\_ -> str)
+
+
+empty : ItemTemplate
+empty =
+    literal ""
+
+
+name : ItemTemplate
+name =
+    ItemTemplate (.name >> Util.String.underscoreToSpace)
+
+
+direction : ItemTemplate
+direction =
+    let
+        dirStr ms =
+            Maybe.andThen Data.Direction.fromString ms
+                |> Maybe.map Data.Direction.toString
+    in
+    fromMaybe (.direction >> dirStr)
+
+
+dateLong : ItemTemplate
+dateLong =
+    ItemTemplate (.date >> Util.Time.formatDate)
+
+
+dateShort : ItemTemplate
+dateShort =
+    ItemTemplate (.date >> Util.Time.formatDateShort)
+
+
+dueDateLong : ItemTemplate
+dueDateLong =
+    fromMaybe (.dueDate >> Maybe.map Util.Time.formatDate)
+
+
+dueDateShort : ItemTemplate
+dueDateShort =
+    fromMaybe (.dueDate >> Maybe.map Util.Time.formatDateShort)
+
+
+source : ItemTemplate
+source =
+    ItemTemplate .source
+
+
+folder : ItemTemplate
+folder =
+    ItemTemplate (.folder >> getName)
+
+
+corrOrg : ItemTemplate
+corrOrg =
+    ItemTemplate (.corrOrg >> getName)
+
+
+corrPerson : ItemTemplate
+corrPerson =
+    ItemTemplate (.corrPerson >> getName)
+
+
+correspondent : ItemTemplate
+correspondent =
+    combine ", " corrOrg corrPerson
+
+
+concPerson : ItemTemplate
+concPerson =
+    ItemTemplate (.concPerson >> getName)
+
+
+concEquip : ItemTemplate
+concEquip =
+    ItemTemplate (.concEquipment >> getName)
+
+
+concerning : ItemTemplate
+concerning =
+    combine ", " concPerson concEquip
+
+
+fileCount : ItemTemplate
+fileCount =
+    ItemTemplate (.fileCount >> String.fromInt)
+
+
+
+--- Helpers
+
+
+getName : Maybe IdName -> String
+getName =
+    Maybe.map .name >> Maybe.withDefault ""
+
+
+
+--- Parse pattern
+
+
+helpMessage : String
+helpMessage =
+    """
+A pattern allows to customize the title and subtitle of each card.
+Variables expressions are enclosed in `{{` and `}}`, other text is
+used as-is. The following variables are available:
+
+- `{{name}}` the item name
+- `{{source}}` the source the item was created from
+- `{{folder}}` the items folder
+- `{{corrOrg}}` the correspondent organization
+- `{{corrPerson}}` the correspondent person
+- `{{correspondent}}` both organization and person separated by a comma
+- `{{concPerson}}` the concerning person
+- `{{concEquip}}` the concerning equipment
+- `{{concerning}}` both person and equipment separated by a comma
+- `{{fileCount}}` the number of attachments of this item
+- `{{dateLong}}` the item date as full formatted date
+- `{{dateShort}}` the item date as short formatted date (yyyy/mm/dd)
+- `{{dueDateLong}}` the item due date as full formatted date
+- `{{dueDateShort}}` the item due date as short formatted date (yyyy/mm/dd)
+- `{{direction}}` the items direction values as string
+
+If some variable is not present, an empty string is rendered. You can
+combine multiple variables with `|` to use the first non-empty one,
+for example `{{corrOrg|corrPerson|-}}` would render the organization
+and if that is not present the person. If both are absent a dash `-`
+is rendered.
+"""
+
+
+knownPattern : String -> Maybe ItemTemplate
+knownPattern str =
+    case str of
+        "{{name}}" ->
+            Just name
+
+        "{{source}}" ->
+            Just source
+
+        "{{folder}}" ->
+            Just folder
+
+        "{{corrOrg}}" ->
+            Just corrOrg
+
+        "{{corrPerson}}" ->
+            Just corrPerson
+
+        "{{correspondent}}" ->
+            Just correspondent
+
+        "{{concPerson}}" ->
+            Just concPerson
+
+        "{{concEquip}}" ->
+            Just concEquip
+
+        "{{concerning}}" ->
+            Just concerning
+
+        "{{fileCount}}" ->
+            Just fileCount
+
+        "{{dateLong}}" ->
+            Just dateLong
+
+        "{{dateShort}}" ->
+            Just dateShort
+
+        "{{dueDateLong}}" ->
+            Just dueDateLong
+
+        "{{dueDateShort}}" ->
+            Just dueDateShort
+
+        "{{direction}}" ->
+            Just direction
+
+        _ ->
+            Nothing
+
+
+patternToken : String -> ItemTemplate
+patternToken str =
+    knownPattern str
+        |> Maybe.withDefault
+            (alternativeToken str
+                |> Maybe.withDefault (literal str)
+            )
+
+
+alternativeToken : String -> Maybe ItemTemplate
+alternativeToken str =
+    let
+        inner =
+            String.dropLeft 2 str
+                |> String.dropRight 2
+                |> String.split "|"
+                |> List.filter (String.isEmpty >> not)
+
+        pattern s =
+            knownPattern ("{{" ++ s ++ "}}")
+                |> Maybe.withDefault (literal s)
+    in
+    if String.startsWith "{{" str && String.endsWith "}}" str then
+        case inner of
+            [] ->
+                Nothing
+
+            _ ->
+                List.map pattern inner
+                    |> firstNonEmpty
+                    |> Just
+
+    else
+        Nothing
+
+
+splitTokens : String -> Maybe (List String)
+splitTokens str =
+    let
+        begins =
+            String.indexes "{{" str
+
+        ends =
+            String.indexes "}}" str
+                |> List.map ((+) 2)
+
+        indexes =
+            Set.union (Set.fromList begins) (Set.fromList ends)
+                |> Set.insert 0
+                |> Set.insert (String.length str)
+                |> Set.toList
+                |> List.sort
+
+        mkSubstring i1 i2 =
+            String.slice i1 i2 str
+    in
+    if List.length begins == List.length ends then
+        Util.List.sliding mkSubstring indexes |> Just
+
+    else
+        Nothing

modules/webapp/src/main/elm/Data/UiSettings.elm

@@ -1,5 +1,6 @@
 module Data.UiSettings exposing
-    ( Pos(..)
+    ( ItemPattern
+    , Pos(..)
     , StoredUiSettings
     , UiSettings
     , cardPreviewSize
@@ -21,6 +22,7 @@ import Api.Model.Tag exposing (Tag)
 import Data.BasicSize exposing (BasicSize)
 import Data.Color exposing (Color)
 import Data.Fields exposing (Field)
+import Data.ItemTemplate exposing (ItemTemplate)
 import Dict exposing (Dict)
 import Html exposing (Attribute)
 import Html.Attributes as HA
@@ -48,6 +50,8 @@ type alias StoredUiSettings =
     , searchMenuVisible : Bool
     , editMenuVisible : Bool
     , cardPreviewSize : Maybe String
+    , cardTitleTemplate : Maybe String
+    , cardSubtitleTemplate : Maybe String
     }
 
 
@@ -72,9 +76,23 @@ type alias UiSettings =
     , searchMenuVisible : Bool
     , editMenuVisible : Bool
     , cardPreviewSize : BasicSize
+    , cardTitleTemplate : ItemPattern
+    , cardSubtitleTemplate : ItemPattern
     }
 
 
+type alias ItemPattern =
+    { pattern : String
+    , template : ItemTemplate
+    }
+
+
+readPattern : String -> Maybe ItemPattern
+readPattern str =
+    Data.ItemTemplate.readTemplate str
+        |> Maybe.map (ItemPattern str)
+
+
 type Pos
     = Top
     | Bottom
@@ -118,6 +136,14 @@ defaults =
     , searchMenuVisible = False
     , editMenuVisible = False
     , cardPreviewSize = Data.BasicSize.Medium
+    , cardTitleTemplate =
+        { template = Data.ItemTemplate.name
+        , pattern = "{{name}}"
+        }
+    , cardSubtitleTemplate =
+        { template = Data.ItemTemplate.dateLong
+        , pattern = "{{dateLong}}"
+        }
     }
 
 
@@ -157,6 +183,12 @@ merge given fallback =
         given.cardPreviewSize
             |> Maybe.andThen Data.BasicSize.fromString
             |> Maybe.withDefault fallback.cardPreviewSize
+    , cardTitleTemplate =
+        Maybe.andThen readPattern given.cardTitleTemplate
+            |> Maybe.withDefault fallback.cardTitleTemplate
+    , cardSubtitleTemplate =
+        Maybe.andThen readPattern given.cardSubtitleTemplate
+            |> Maybe.withDefault fallback.cardSubtitleTemplate
     }
 
 
@@ -187,6 +219,8 @@ toStoredUiSettings settings =
         settings.cardPreviewSize
             |> Data.BasicSize.asString
             |> Just
+    , cardTitleTemplate = settings.cardTitleTemplate.pattern |> Just
+    , cardSubtitleTemplate = settings.cardSubtitleTemplate.pattern |> Just
     }
 
 

modules/webapp/src/main/elm/Util/List.elm

@@ -6,6 +6,7 @@ module Util.List exposing
     , findNext
     , findPrev
     , get
+    , sliding
     )
 
 
@@ -88,3 +89,17 @@ dropRight n list =
     List.reverse list
         |> List.drop n
         |> List.reverse
+
+
+sliding : (a -> a -> b) -> List a -> List b
+sliding f list =
+    let
+        windows =
+            case list of
+                _ :: xs ->
+                    List.map2 Tuple.pair list xs
+
+                _ ->
+                    []
+    in
+    List.map (\( e1, e2 ) -> f e1 e2) windows