SimpleDebugger.elm

import Html exposing (..)
import Html.App as Html
import Html.Attributes exposing (..)
import Html.Events exposing (on)
import Json.Decode as Json exposing ((:=))
import Mouse exposing (Position)

main =
  Html.program <| debugOn
    { init = init
    , view = view
    , update = update
    , subscriptions = subscriptions
    }


-- MODEL


type alias Model =
    { position : Position
    , drag : Maybe Drag
    }


type alias Drag =
    { start : Position
    , current : Position
    }


init : ( Model, Cmd Msg )
init =
  ( Model (Position 200 200) Nothing, Cmd.none )



-- UPDATE


type Msg
    = DragStart Position
    | DragAt Position
    | DragEnd Position


update : Msg -> Model -> ( Model, Cmd Msg )
update msg model =
  ( updateHelp msg model, Cmd.none )


updateHelp : Msg -> Model -> Model
updateHelp msg ({position, drag} as model) =
  case msg of
    DragStart xy ->
      Model position (Just (Drag xy xy))

    DragAt xy ->
      Model position (Maybe.map (\{start} -> Drag start xy) drag)

    DragEnd _ ->
      Model (getPosition model) Nothing



-- SUBSCRIPTIONS


subscriptions : Model -> Sub Msg
subscriptions model =
  case model.drag of
    Nothing ->
      Sub.none

    Just _ ->
      Sub.batch [ Mouse.moves DragAt, Mouse.ups DragEnd ]



-- VIEW


(=>) = (,)


view : Model -> Html Msg
view model =
  let
    realPosition =
      getPosition model
  in
    div
      [ onMouseDown
      , style
          [ "background-color" => "#3C8D2F"
          , "cursor" => "move"

          , "width" => "100px"
          , "height" => "100px"
          , "border-radius" => "4px"
          , "position" => "absolute"
          , "left" => px realPosition.x
          , "top" => px realPosition.y

          , "color" => "white"
          , "display" => "flex"
          , "align-items" => "center"
          , "justify-content" => "center"
          ]
      ]
      [ text "Drag Me!"
      ]


px : Int -> String
px number =
  toString number ++ "px"


getPosition : Model -> Position
getPosition {position, drag} =
  case drag of
    Nothing ->
      position

    Just {start,current} ->
      Position
        (position.x + current.x - start.x)
        (position.y + current.y - start.y)


onMouseDown : Attribute Msg
onMouseDown =
  on "mousedown" (Json.map DragStart Mouse.position)


-----------

type alias DebuggerModel model msg =
  { history : List model, msgList : List msg }
  

debugOn :
  { init : (model, Cmd msg)
  , view : model -> Html msg
  , update : msg -> model -> (model, Cmd msg)
  , subscriptions : model -> Sub msg
  } ->
  { init : (DebuggerModel model msg, Cmd msg)
  , view : DebuggerModel model msg -> Html msg
  , update : msg -> DebuggerModel model msg -> (DebuggerModel model msg, Cmd msg)
  , subscriptions : DebuggerModel model msg -> Sub msg
  }
debugOn { init, view, update, subscriptions } =
  let
    init' = ({ history = [ fst init ], msgList = [] }, snd init)
    update' msg model =
      let
        (newModel, cmd)
          = update msg (head' model.history)
      in
        { model |
          history = newModel :: model.history
        , msgList = msg :: model.msgList
        } ! [ cmd ]
    view' model =
      div [] [ view (head' model.history), debugView model ]
    subscriptions' model =
      subscriptions (head' model.history)
  in
    { init = init'
    , update = update'
    , view = view'
    , subscriptions = subscriptions'
    }
  
debugOff = identity



head' list =
  case List.head list of
    Just h -> h
    Nothing -> Debug.crash "empty"


debugView : DebuggerModel model msg -> Html msg
debugView model =
  div
    [ style
      [ ("position", "fixed")
      , ("width", "250px")
      , ("top", "0")
      , ("right", "0")
      , ("bottom", "0")
      , ("background-color", "#444")
      , ("color", "#eee")
      ]
    ]
    [ modelView (head' model.history)
    , msgListView model.msgList
    ]


panel : List (String, String)
panel =
  [ ("padding", "20px")
  ]
  
modelViewStyle : List (String, String)
modelViewStyle =
  [ ("height", "100px")
  , ("border-bottom", "solid 1px #666")
  ] ++ panel

modelView : model -> Html msg
modelView model =
  div
    [ style modelViewStyle ] [ text (toString model) ]


msgListView : List m -> Html msg
msgListView msgList =
  div [ style panel ] (List.map msgView msgList)

msgView : m -> Html msg
msgView msg =
  div [] [ text (toString msg) ]