Single Month Calendar Selector in Elm

Calendar.elm

module Calendar exposing (..)

import Date exposing (Date)
import Debug
import Html as H exposing (..)
import Html.App as Html
import Html.Attributes exposing (..)
import Html.Events exposing (onClick)
import String
import Task


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



-- MODEL

type alias Model = Date


splitDate : Date -> (Int, Int, Int)
splitDate date =
  let month = case Date.month date of
    Date.Jan -> 1
    Date.Feb -> 2
    Date.Mar -> 3
    Date.Apr -> 4
    Date.May -> 5
    Date.Jun -> 6
    Date.Jul -> 7
    Date.Aug -> 8
    Date.Sep -> 9
    Date.Oct -> 10
    Date.Nov -> 11
    Date.Dec -> 12
  in ( Date.year date, month, Date.day date )


dateString : (Int, Int, Int) -> String
dateString (y, m, d) =
  [y, m, d]
    |> List.map toString
    |> List.map (\s -> if String.length s < 2 then "0" ++ s else s)
    |> String.join "-"
    |> \s -> s ++ " 12:00"


init =
  let epoch = Date.fromTime 0
  in  ( epoch, Task.perform Set Set Date.now )



-- UPDATE

type Msg
  = Set Date
  | Select Int
  | Next
  | Prev


update : Msg -> Model -> ( Model, Cmd Msg )
update msg model =
  let changeMonth delta date =
        date
          |> splitDate
          |> changeMonthHelp delta
          |> dateString
          |> Date.fromString
      changeMonthHelp delta (y, m, d) =
        let 
          (year, month) = 
            case m of
              1  -> if delta < 0 then (y - 1, 12) else (y, m + delta)
              12 -> if delta > 0 then (y + 1, 1)  else (y, m + delta)
              _  -> (y, m + delta)
          day =
            case Date.fromString (dateString (year, month, 1)) of
              Ok date -> Basics.min d (daysInMonth date)
              Err msg -> Debug.crash msg
        in
          (year, month, day)
  in case msg of
    Set date ->
      ( date, Cmd.none )
    Select i ->
      let date =
        model 
          |> splitDate 
          |> (\(y, m, d) -> (y, m, i))
          |> dateString
          |> Date.fromString
      in case date of
        Ok date -> ( date, Cmd.none)
        Err msg -> ( model, Cmd.none )
    Next ->
      case changeMonth 1 model of
        Ok date -> ( date , Cmd.none)
        Err msg -> ( model , Cmd.none )
    Prev ->
      case changeMonth -1 model of
        Ok date -> ( date , Cmd.none)
        Err msg -> ( model , Cmd.none )



-- SUBSCRIPTIONS

subscriptions : Model -> Sub Msg
subscriptions model =
  Sub.none



-- VIEW

weekPos : Date -> Int
weekPos date =
  case Date.dayOfWeek date of
    Date.Sun -> 0
    Date.Mon -> 1
    Date.Tue -> 2
    Date.Wed -> 3
    Date.Thu -> 4
    Date.Fri -> 5
    Date.Sat -> 6


daysInMonth : Date -> Int
daysInMonth date =
  case Date.month date of
    Date.Jan -> 31
    Date.Feb ->
      let year = Date.year date
          leap = (year % 4 == 0) && (year % 100 /= 0) || (year % 400 == 0)
      in  if leap then 29 else 28
    Date.Mar -> 31
    Date.Apr -> 30
    Date.May -> 31
    Date.Jun -> 30
    Date.Jul -> 31
    Date.Aug -> 31
    Date.Sep -> 30
    Date.Oct -> 31
    Date.Nov -> 30
    Date.Dec -> 31


viewMonth : Date -> Html Msg
viewMonth date =
  let 
    posOfFirst = (weekPos date - Date.day date + 1) % 7
    week start current max =
      let leftPad = List.map (always <| td [] [text ""]) [0..posOfFirst-1]
          elementStyle i = style <| [("text-align","center")] ++
                           if i + start == current 
                           then [("color","white"), ("background", "black")]
                           else [("color","black"), ("background", "white")]
          toElement i = td [onClick (Select <| i + start), elementStyle i]
                           [text << toString <| i + start]
      in  if start == 1 then
            (tr [] (leftPad ++ List.map toElement [0..6-posOfFirst]))
            :: week (start + 7 - posOfFirst) current max
          else if start <= max then
            (tr [] (List.map toElement [0..Basics.min 6 (max-start)]))
            :: week (start + 7) current max
          else []
    weeks = week 1 (Date.day date) (daysInMonth date)
  in table [style [("cursor","default"), ("width","100%")]] <|
     [ tr [] <| 
       List.map (\day -> td [style [("text-align","center")]] [text day]) 
         ["Sun","Mon","Tue","Wed","Thu","Fri","Sat"]
     ] ++ weeks


view : Model -> Html Msg
view model =
  div [style [("width","240px")]]
    [ div [style [("display","flex"), ("justify-content","space-between"), ("padding","5px")]]
      [ button [onClick Prev] [ text "<" ]
      , strong [] 
        [ text << (\d -> toString (Date.month d) ++ " " ++ toString (Date.year d)) <| model ]
      , button [onClick Next] [ text ">" ]
      ]
    , viewMonth model
    ]