CacheSim/src/CacheSim/View.elm

module CacheSim.View exposing (..)
import CacheSim.Raw exposing (..)
import CacheSim.Model exposing (..)
import CacheSim.Cache exposing (..)
import CacheSim.AccessView exposing (..)
import CacheSim.Hierarchy exposing (..)
import Html exposing (Html, Attribute, input, text, div, label, span, h2, h3, table, tr, td, th)
import Html.Attributes exposing (type_, class, value, for, classList, disabled, colspan, hidden)
import Html.Events exposing (onInput, onClick)

-- Button components, powered by Bootstrap
basicButton : List (Attribute Msg) -> String -> Html Msg
basicButton attrs s = input ([ type_ "button", value s, class "btn", class "btn-info" ] ++ attrs) []

disabledButton : String -> Html Msg
disabledButton = basicButton [ disabled True ]

advancedButton : List (Attribute Msg) -> String -> Msg -> Html Msg
advancedButton attrs s m = basicButton (attrs ++ [ onClick m ]) s

button : String -> Msg -> Html Msg
button s m = basicButton [ onClick m ] s

dangerButton : String -> Msg -> Html Msg
dangerButton = advancedButton [ class "btn-danger" ]

primaryButton : String -> Msg -> Html Msg
primaryButton = advancedButton [ class "btn-primary" ]

secondaryButton : String -> Msg -> Html Msg
secondaryButton = advancedButton [ class "btn-secondary" ]

maybeButton : Maybe a -> String -> (a -> Msg) -> Html Msg
maybeButton m s f =
    case m of
        Just v -> button s (f v)
        _ -> disabledButton s 

resultButton : Result e a -> String -> (a -> Msg) -> Html Msg
resultButton = maybeButton << Result.toMaybe

-- Button wrapper (button group)
buttonWrapper : List (Html Msg) -> Html Msg
buttonWrapper = div [ classList [("btn-group", True), ("mb-3", True) ] ]

-- Input with a label
labeledInput : String -> String -> (String -> Msg) -> Html Msg
labeledInput s val f =
    div [ class "input-group mb-3" ]
        [ div [ class "input-group-prepend" ]
            [ span [ class "input-group-text" ] [ text s ]
            ]
        , input [ value val, type_ "text", class "form-control", onInput f ] []
        ]

-- Error view
viewError : Bool -> String -> Html Msg
viewError hide e = div
    [ classList
        [ ("alert", True)
        , ("alert-danger", True)
        ]
    , hidden hide
    ] [ text e ]

panel : List (Html Msg) -> Html Msg
panel = div [ classList [("card", True), ("p-3", True), ("mb-3", True) ] ]

viewRawCacheModel : Int -> RawCacheModel -> Html Msg
viewRawCacheModel level rcm =
    let
        updateBlockSize s cm = { cm | blockSize = s}
        updateSetCount s cm = { cm | setCount = s}
        updateSetSize s cm = { cm | setSize = s}
        wrapUpdate f s = ChangeRawModel level (f s)

        deleteButton = dangerButton "Delete" (DeleteRawModel level)

        params = div []
            [ labeledInput "Block size" rcm.blockSize (wrapUpdate updateBlockSize)
            , labeledInput "Set count" rcm.setCount (wrapUpdate updateSetCount)
            , labeledInput "Set size" rcm.setSize (wrapUpdate updateSetSize)
            ]
    in
        panel
            [ h3 [] [ text <| "L" ++ String.fromInt (level + 1) ++ " Cache" ]
            , buttonWrapper [ deleteButton ]
            , params
            ]

viewRawCacheModelHierarchy : RawCacheModelHierarchy -> Html Msg
viewRawCacheModelHierarchy rcmh =
    let
        models = div [ class "cache-model-levels" ] 
            <| List.indexedMap viewRawCacheModel rcmh
        translationResult = Result.andThen validateCacheModelHierarchy
            <| translateRawCacheModelHierarchy rcmh
        errorHtml =
            case translationResult of
                Ok _ -> viewError True ""
                Err e -> viewError False e
        
        newButton = button "Add level" CreateRawModel
        useButton = resultButton translationResult "Use hierarchy" (UseHierarchy << Just) 
    in
        div []
            [ h2 [] [ text "Cache hierarchy" ]
            , errorHtml
            , buttonWrapper [ newButton, useButton ]
            , models
            ]

viewCache : Int -> Cache -> Html Msg
viewCache level (cm, cs) =
    let
        slotLabels =
            List.indexedMap (\i _ -> td [] [ text <| String.fromInt i ])
            <| List.repeat cm.setSize ()
        slotLabel = th [ colspan cm.setSize ] [ text "Slot" ]
        allSlotLabels = List.concat <| List.repeat cm.setCount slotLabels
        allSlotsLabel = List.repeat cm.setCount slotLabel

        setLabels =
            List.indexedMap (\i _ -> td [ colspan cm.setSize ] [ text <| String.fromInt i ])
            <| List.repeat cm.setCount ()
        setLabel = [ th [ colspan <| cm.setSize * cm.setCount ] [ text "Set" ] ]
        setRow set =
            let
                slotHtml s =
                    case s of
                        Empty -> td [] [ text "" ]
                        Used l a -> td [] [ text <| String.fromInt a ]
            in
                List.map slotHtml set
        cacheRow = List.concat <| List.map setRow cs
        cacheTable =
            table [ class "table" ]
                [ tr [ hidden (cm.setCount == 1), class "table-info" ] setLabel
                , tr [ hidden (cm.setCount == 1) ] setLabels
                , tr [ hidden (cm.setSize == 1), class "table-info" ] allSlotsLabel
                , tr [ hidden (cm.setSize == 1) ] allSlotLabels
                , tr [] cacheRow
                ]

    in
        panel
            [ h3 [] [ text <| "L" ++ String.fromInt (level + 1) ++ " Cache" ]
            , cacheTable
            ]

viewCacheHierarchy : CacheHierarchy -> Html Msg
viewCacheHierarchy ch =
    let
        levels = div [ class "cache-levels" ] 
            <| List.indexedMap viewCache ch
    in
    div [] <|
        [ h2 [] [ text <| "Cache State" ]
        , levels
        ]
        
viewAccessView : Model -> AccessView -> Html Msg
viewAccessView m av =
    let
        currentCache = Maybe.withDefault [] m.hierarchy
    in
        div []
            [ h2 [] [ text "Access Simulation" ]
            , buttonWrapper
                [ primaryButton "Back" AccessViewBack
                , primaryButton "Forward" AccessViewForward
                ]
            , viewAccessLog av
            , viewCacheHierarchy <| effectiveCacheHierarchy currentCache av
            ]   

viewAccessLog : AccessView -> Html Msg
viewAccessLog (aes, ap) =
    let
        resultSpan r =
            span [ classList [ ("badge", True), ("badge-danger", True), ("badge-success", r == Hit) ] ]
                [ text <| if r == Hit then "Hit" else "Miss" ]
        downEvent n ae = div [ class "event" ]
            [ text <| "L" ++ String.fromInt (n + 1) ++ " "
            , resultSpan ae.result
            ]
        upEvent n ae = div [ class "event" ]
            [ text <| "Updated L" ++ String.fromInt (List.length aes - n)
            ]
        events = 
            case ap of
                Done -> []
                Down n -> List.indexedMap downEvent <| List.take (n + 1) aes
                Up n -> List.indexedMap downEvent aes ++
                    (List.indexedMap upEvent <| List.drop n aes)
    in
        div [ ]
            [ h3 [] [ text "Simulation events" ]
            , div [] events
            ]

viewAccessInput : Model -> Html Msg
viewAccessInput m =
    let
        accessButton = maybeButton (String.toInt m.accessInput) "Access address" Access
    in
        div []
            [ h2 [] [ text "Run access simulation" ]
            , div [ classList [("alert", True), ("alert-primary", True)] ]
                [ text  "Please make sure to click \"Use Hierarchy\" to load a hierarchy to simulate."
                ]
            , labeledInput "Access address" m.accessInput ChangeAccessInput
            , accessButton 
            ]

viewBase : Model -> Html Msg
viewBase m =
    let
        rawView = 
            case m.accessView of
                Nothing -> [ viewRawCacheModelHierarchy m.rawHierarchy ]
                Just _ -> []
        cacheView =
            case m.accessView of
                Nothing ->
                    Maybe.withDefault []
                        <| Maybe.map (List.singleton << viewCacheHierarchy) <| m.hierarchy
                Just _ -> []
        accessView = Maybe.withDefault [] <| Maybe.map (List.singleton << viewAccessView m) <| m.accessView
        accessInputView = [ viewAccessInput m ]
    in
        div [ class "container" ]
            <| rawView ++ cacheView ++ accessView ++ accessInputView