update to valid data

Sam.elm

import Html exposing (..)
import Html.App as App
import Html.Events exposing (on, onClick)
import Html.Attributes exposing (style)
import Mouse exposing (Position)
import Json.Decode as Json


-- MODEL


type alias Rectangle =
    { from : Position
    , to : Position
    , complete : Bool
    }


type alias Model =
    Maybe Rectangle


init : Model
init =
    Nothing



-- UPDATE


type Msg
    = Down Position
    | Move Position
    | Up Position


updateToMax200 : Position -> Rectangle -> Rectangle
updateToMax200 { x, y } rect =
    let
        newX =
            rect.from.x + (min 200 (x - rect.from.x))
    in
        { rect | to = { x = newX, y = y } }


updateComplete : Bool -> Rectangle -> Rectangle
updateComplete complete rect =
    { rect | complete = complete }


present : Msg -> Model -> Model
present msg model =
    case (Debug.log "msg" msg) of
        Down pos ->
            Just (Rectangle pos pos False)

        Move pos ->
            Maybe.map (updateToMax200 pos) model

        Up pos ->
            Maybe.map (updateToMax200 pos >> updateComplete True) model



-- VIEW


px : number -> String
px n =
    (toString n) ++ "px"


representation : Rectangle -> Html a
representation rect =
    let
        w =
            rect.to.x - rect.from.x

        h =
            rect.to.y - rect.from.y
    in
        div
            [ style
                [ ( "width", px w )
                , ( "height", px h )
                , ( "top", px rect.from.y )
                , ( "left", px rect.from.x )
                , ( "border", "1px solid black" )
                , ( "position", "relative" )
                , ( "backgroundColor"
                  , if rect.complete then
                        "green"
                    else
                        "red"
                  )
                ]
            ]
            []


render : Model -> Html Msg
render model =
    let
        rect =
            case model of
                Nothing ->
                    text ""

                Just rect ->
                    representation rect
    in
        div
            [ style [ ( "width", "100vw" ), ( "height", "100vh" ), ( "background", "lightgrey" ) ]
            , onMouseDown
            ]
            [ rect
            ]


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



-- WIRING


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

        Just rect ->
            if rect.complete then
                Sub.none
            else
                Sub.batch [ Mouse.moves Move, Mouse.ups Up ]


main : Program Never
main =
    App.program
        { init = init ! []
        , update = \msg model -> present msg model ! []
        , view = render
        , subscriptions = subscriptions
        }