Client-side Routing in Elm Using Parser Combinators

Main.elm

module Main where

import Combine exposing (Parser, string, parse, end, andThen, many1, while, many, skip, Result (..))
import Combine.Char exposing (noneOf, char)
import Combine.Num exposing (int)
import Combine.Infix exposing ((<$>), (<$), (<*), (*>), (<*>), (<|>))
import Maybe exposing (Maybe)
import History exposing (path, setPath)
import Signal exposing (Signal, (<~), (~), send, message)
import Effects exposing (Effects, task)
import Html exposing (Html, div, h1, text, ul, li, a, input, button)
import Html.Attributes as HA
import Html.Events exposing (..)
import StartApp exposing (start, App)
import Task exposing (Task)

-- ROUTING

type alias Url = String

type Route
  = Home
  | About
  | Topic Int
  | Page404


convertRoute : Route -> Url
convertRoute route =
  case route of
    Home -> "/"
    About -> "/about"
    Topic int -> "/topic/" ++ (toString int)


homeRouteParser : Parser Route
homeRouteParser 
  = Home <$ (string "/" *> end)

aboutRouteParser : Parser Route
aboutRouteParser
  = About <$ (string "/about" *> end)

topicRouteParser : Parser Route
topicRouteParser 
  = Topic <$> ((string "/topic/" *> int) <* end)

-- obviously, the match function could be optimized

match : List (Parser Route) -> Url -> Maybe Route
match ps url
  = if List.isEmpty ps
    then Nothing 
    else
      let
          routeParser = Maybe.withDefault homeRouteParser (List.head ps)
      in
          case parse routeParser url of
            ((Done route), _) -> Just route
            _                 -> let
                                    tail = Maybe.withDefault [] (List.tail ps)
                                 in
                                    match tail url


routeParsers : List (Parser Route)
routeParsers = [ homeRouteParser
               , aboutRouteParser
               , topicRouteParser
               ]

toMaybeInt : String -> Maybe Int
toMaybeInt str =
  case (parse (int <* end) str ) of
    ((Done n), _) -> Just n
    _             -> Nothing

-- MODEL

type alias Model =
  {
    currentRoute : Route
  , topicNumber  : Maybe Int
  }

initialModel =
  {
    currentRoute = Home
  , topicNumber  = Nothing
  }

-- SIGNALS AND MAILBOXES

currentRouteSignal : Signal Action
currentRouteSignal 
  = (LatestRoute << (match routeParsers)) <~ path

newInputBox : Signal.Mailbox Action
newInputBox
  = Signal.mailbox <| LatestRoute (Just Home)

addr = newInputBox.address

-- ACTIONS

type Action
  = LatestRoute (Maybe Route)
  | UpdateUrl Route
  | NoOp ()
  | SetTopicNumber (Maybe Int)

-- UPDATE

update : Action -> Model -> (Model, Effects Action)
update action model
  = case action of
      LatestRoute (Just route) -> ({ model | currentRoute <- route },   Effects.none)
      LatestRoute Nothing      -> ({ model | currentRoute <- Page404 }, Effects.none) 
      UpdateUrl route          -> (model, pushPath route)
      SetTopicNumber mInt      -> ({ model | topicNumber <- mInt }, Effects.none)
      NoOp _                   -> (model, Effects.none)

pushPath : Route -> Effects Action
pushPath route =
  setPath (convertRoute route) |> Task.map NoOp  |> Effects.task


-- VIEW

view : Signal.Address Action -> Model -> Html
view address model =
  case model.currentRoute of
    
    Home -> div [] [ h1 [] [
                             a [ onClick addr (UpdateUrl About) ]
                               [ text "This is the home page.  Click for the about page." ] 
                           ]
                   ]

    About -> div [] [ div [] [ text "This is the about page. Please input a topic number (Integer)." ]
                    
                    , input [ on "input" targetValue (\str -> message addr (SetTopicNumber (toMaybeInt str)))] []
                    , button [ onClick addr (getTopicNumber model.topicNumber) ] [ text "Click me!" ]
                    , text <| (if (isNothing model.topicNumber) then "You haven't entered a number." else "")               
                    ]

    Topic num -> div [] [ h1 [] 
                             [ text <| "This is the topic page.  You passed param: " ++ (toString num)]
                        ,

                          a  [ onClick addr (UpdateUrl Home)]
                             [ text "Click to go home." ]
                        ]

    Page404 -> div [] [ h1 [] [ text "You gone done broke it now." ] 
                      , a  [ onClick addr (UpdateUrl Home) ] [ text "Go to the home page." ]
                      ]

isNothing : Maybe a -> Bool
isNothing m =
  case m of
    Nothing -> True
    _       -> False

getTopicNumber : Maybe Int -> Action
getTopicNumber mInt =
  case mInt of
    Just int -> UpdateUrl (Topic int)
    _        -> NoOp ()


-- WIRING
app : App Model
app = start { init = (initialModel,  Effects.none)
            , update = update
            , view = view
            , inputs = [ Signal.merge newInputBox.signal currentRouteSignal ]
            }

port runner : Signal (Task.Task Effects.Never ())
port runner = app.tasks

-- MAIN

main = app.html