diff --git a/src/Route.hs b/src/Route.hs new file mode 100644 index 0000000..397d5ec --- /dev/null +++ b/src/Route.hs @@ -0,0 +1,49 @@ +module Route (Route(..), link, breadcrumb) where + +import Common +import Lucid +import Data.List (foldl') + +data Route + = IndexRoute + | VisualRoute + | PostRoute + | ProjectsRoute + | ProjectRoute Text + | ProjectPageRoute Text Route + | VEntryRoute + +link :: Route -> Html () +link route = a_ [href_ (path route)] (toHtml $ name route) + where + path IndexRoute = "/" + path ProjectsRoute = "/projects.html" + path VisualRoute = "/visual.html" + path PostRoute = "/" + path (ProjectRoute _) = "/projects/" + path (ProjectPageRoute _ _) = "/" + path VEntryRoute = "/" + + name IndexRoute = "index" + name ProjectsRoute = "projects" + name VisualRoute = "visual" + name PostRoute = "post" + name (ProjectRoute n) = n + name (ProjectPageRoute n r) = n + +walk :: Route -> [Route] +walk IndexRoute = [] +walk VisualRoute = [] +walk PostRoute = [IndexRoute] +walk ProjectsRoute = [] +walk (ProjectRoute _) = [ProjectsRoute] +walk (ProjectPageRoute _ r) = walk r ++ [r] +walk (VEntryRoute) = [VisualRoute] + +breadcrumb :: Route -> Html () +breadcrumb route = + case walk route of + [] -> mempty + xs -> p_ [class_ "breadcrumb"] $ + foldl' (\b r -> b <> sep <> link r) "∅" xs + where sep = span_ [class_ "sep"] "←"