Give up on typesafe menu generation and use 'bless'

author: Benjamin Barenblat <bbaren@mit.edu> 2013-03-16 16:08:06 -0400
committer: Benjamin Barenblat <bbaren@mit.edu> 2013-03-16 16:08:06 -0400
commit: 963ab32b176228017635e4ef1bb60555c4022142 (patch)
tree: 1b01fbdfe1b7e2d453a577eec59b73a902af4bd4
parent: a89dc76b6a861f2579ba57b6cbb0bdb341484c45 (diff)
4 files changed, 90 insertions, 36 deletions
diff --git a/main.ur b/main.ur
index b498861..1d3483b 100644
--- a/main.ur
+++ b/main.ur
@@ -30,7 +30,7 @@ fun generic (pageName : option string) (content : xbody) : xhtml [] [] =
 	<xml>
 	  <head>
 	    <title>{[titleString]}</title>
-	    <link rel="stylesheet" type="text/css" href="//bbaren.scripts.mit.edu/urweb/6.947/site.css"/>
+	    <link rel="stylesheet" type="text/css" href="//bbaren.scripts.mit.edu/urweb/6.947-static/site.css"/>
 	  </head>
 	  <body>
 	    {content}
@@ -53,42 +53,11 @@ fun generic (pageName : option string) (content : xbody) : xhtml [] [] =
     end
 
 
-(******************************* Page headings *******************************)
-
-(* Generating nice headings and menus is quite difficult in Ur/Web--there are a
-lot of links that the compiler needs to be convinced aren't broken.  The link
-scheme in this app is based on a variant 'pageName', which describes the name
-of the page.  There's one value for each page. *)
-
-con pageName = variant (mapU unit [Main, Forum])
-
-(* 'getName' generates the link text given a 'pageName'. *)
-fun getName (n : pageName) : xbody =
-    match n { Main = fn ()  => <xml>Main</xml>,
-	      Forum = fn () => <xml>Forum</xml> }
-
-(* Now we can do the actual title and menu generation code. *)
-fun header (current : pageName) : xbody =
-    let fun item (target : pageName) (page : unit -> transaction page) =
-    	    if Variant.eq current target
-    	    then <xml><li class={active}>{getName target}</li></xml>
-    	    else <xml><li><a link={page ()}>{getName target}</a></li></xml>
-    in
-	<xml>
-	  <h1 class={siteTitle}><a link={main ()}>6.947 &ndash; Functional Programming Project Laboratory</a></h1>
-	  <ul class={navBar}>
-	    {item (make [#Main] ()) main}
-	    {item (make [#Forum] ()) forum}
-	  </ul>
-	</xml>
-    end
-
-
 (*********************************** Pages ***********************************)
 
 and main () =
     return (generic None <xml>
-      {header (make [#Main] ())}
+      {Menu.header (make [#Main] ())}
       <div class={content}>
 	<p>
 	  Like <a href="//web.mit.edu/6.115/www/">6.115</a>, 6.947 is a chance to remember why you came to <span class={smallCaps}>mit</span>: to learn and to build.
@@ -101,7 +70,7 @@ and main () =
 and forum () = forumWorker Forum.main
 and forumWorker (f : unit -> xbody) =
     return (generic (Some "Forum") <xml>
-      {header (make [#Forum] ())}
+      {Menu.header (make [#Forum] ())}
       {f ()}
     </xml>)
 
diff --git a/menu.ur b/menu.ur
new file mode 100644
index 0000000..4be6d3d
--- /dev/null
+++ b/menu.ur
@@ -0,0 +1,57 @@
+(* Menu -- site menu
+Copyright (C) 2013  Benjamin Barenblat <bbaren@mit.edu>
+
+This file is a part of 6.947.
+
+6.947 is is free software: you can redistribute it and/or modify it under the
+terms of the GNU Affero General Public License as published by the Free
+Software Foundation, either version 3 of the License, or (at your option) any
+later version.
+
+6.947 is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
+PARTICULAR PURPOSE.  See the GNU Affero General Public License for more
+details.
+
+You should have received a copy of the GNU Affero General Public License along
+with 6.947.  If not, see <http://www.gnu.org/licenses/>. *)
+
+(* Generating nice headings and menus is quite difficult in Ur/Web--there are a
+lot of links that the compiler needs to be convinced aren't broken.  I tried
+for multiple weeks to get a nice, typesafe solution to this; however, it was
+just too brittle.  I've instead settled for a simpler solution--pass the URLs
+of the pages the menu links to to 'bless'.  It's a bit sketchy, but it works,
+and it's no more unsafe than anything you'd do in a "normal" Web framework. *)
+
+open Styles
+
+con pageName = variant (mapU unit [Main, Forum])
+
+(* Generates the link text *)
+fun getName (n : pageName) : xbody =
+    match n { Main = fn ()  => <xml>Main</xml>,
+	      Forum = fn () => <xml>Forum</xml> }
+
+(* Generates the link URL *)
+fun getUrl (n : pageName) : url =
+    let val base = "/urweb/6.947"
+    in
+	match n { Main = fn ()  => bless (base ^ "/index"),
+		  Forum = fn () => bless (base ^ "/forum") }
+    end
+
+(* Actual title and menu generation code *)
+fun header (current : pageName) : xbody =
+    let fun item (target : pageName) =
+    	    if Variant.eq current target
+    	    then <xml><li class={active}>{getName target}</li></xml>
+    	    else <xml><li><a href={getUrl target}>{getName target}</a></li></xml>
+    in
+	<xml>
+	  <h1 class={siteTitle}><a href={getUrl (make [#Main] ())}>6.947 &ndash; Functional Programming Project Laboratory</a></h1>
+	  <ul class={navBar}>
+	    {item (make [#Main] ())}
+	    {item (make [#Forum] ())}
+	  </ul>
+	</xml>
+    end
diff --git a/menu.urs b/menu.urs
new file mode 100644
index 0000000..0372aab
--- /dev/null
+++ b/menu.urs
@@ -0,0 +1,23 @@
+(* Menu -- site menu
+Copyright (C) 2013  Benjamin Barenblat <bbaren@mit.edu>
+
+This file is a part of 6.947.
+
+6.947 is is free software: you can redistribute it and/or modify it under the
+terms of the GNU Affero General Public License as published by the Free
+Software Foundation, either version 3 of the License, or (at your option) any
+later version.
+
+6.947 is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
+PARTICULAR PURPOSE.  See the GNU Affero General Public License for more
+details.
+
+You should have received a copy of the GNU Affero General Public License along
+with 6.947.  If not, see <http://www.gnu.org/licenses/>. *)
+
+(* The menu scheme in this app is based on a variant 'pageName', which
+describes the name of the page.  There's one value for each page. *)
+con pageName = variant (mapU unit [Main, Forum])
+
+val header : pageName -> xbody
diff --git a/site.urp b/site.urp
index 287c010..03d4efe 100644
--- a/site.urp
+++ b/site.urp
@@ -1,7 +1,9 @@
-prefix /urweb/6.947/site.exe/
+prefix /urweb/6.947/
+allow url /urweb/6.947/index
+allow url /urweb/6.947/forum
 allow url file:///afs/athena.mit.edu/user/b/b/bbaren/web_scripts/urweb/6.947/
 allow url //www.youtube.com/watch?v=OyRW9uFSmh0
-allow url //bbaren.scripts.mit.edu/urweb/6.947/site.css
+allow url //bbaren.scripts.mit.edu/urweb/6.947-static/site.css
 allow url //web.mit.edu/6.115/www/
 allow url //gnu.org/licenses/agpl
 rewrite style Styles/smallCaps smallCaps
@@ -10,8 +12,11 @@ rewrite style Styles/navBar navBar
 rewrite style Styles/active active
 rewrite style Styles/content content
 rewrite style Styles/footer footer
+rewrite url Main/main index
+rewrite url Main/*
 library meta
 library forum
 
 styles
+menu
 main
author	Benjamin Barenblat <bbaren@mit.edu>	2013-03-16 16:08:06 -0400
committer	Benjamin Barenblat <bbaren@mit.edu>	2013-03-16 16:08:06 -0400
commit	963ab32b176228017635e4ef1bb60555c4022142 (patch)
tree	1b01fbdfe1b7e2d453a577eec59b73a902af4bd4
parent	a89dc76b6a861f2579ba57b6cbb0bdb341484c45 (diff)