Enable generation of noscript tags.

For better indexing (for Google! Bing is actually fine...)

src/CompileToJS.hs

@@ -11,7 +11,7 @@ import Initialize
 
 
 compile = (return . addMain . toJS) <=< initialize
-compileToJS = addMain . either (\err -> "text('"++err++"')") toJS . initialize
+compileToJS = addMain . either (\err -> "text('"++err++"')") toJS
 addMain body = "function main(){return " ++ body ++ ";}"
 
 parens = ("("++) . (++")")

src/ExtractNoscript.hs

@@ -2,42 +2,25 @@
 module ExtractNoscript (extract) where
 
 import Ast
-import Data.List (isPrefixOf)
 
-extract = extract'
+extract = concatMap (\s -> "<p>" ++ s ++ "</p>") . extract'
 
-extract' expr = makeLinks terms where
-    terms =
-        case expr of
-          Number _ -> []
-          Chr _ -> []
-          Boolean _ -> []
-          Range _ _ -> []
-          Access _ _ -> []
-          Binop op e1 e2 -> case (op, extract' e1, extract' e2) of
-                              ("++", [s1], [s2]) -> [ s1 ++ s2 ]
-                              (_   , ss1 , ss2 ) -> ss1 ++ ss2
-          Lambda v e -> extract' e
-          App e1 e2 -> extract' e1 ++ extract' e2
-          If eb et ef -> extract' et ++ extract' ef
-          Lift f es -> extract' f ++ concatMap extract es
-          Fold e1 e2 e3 -> concatMap extract' [e1,e2,e3]
-          Async e -> extract' e
-          Input _ -> []
-          Let defs e -> concatMap (extract' . snd) defs ++ extract' e
-          Var _ -> []
-          Case e cases -> concatMap (extract' . snd) cases
-          Data _ _ -> [toString expr]
-
-toString (Data "Cons" [Chr c, t]) = c : toString t
-toString _ = []
-
-makeLinks (a:b:[]) = linkify a b
-makeLinks xs       = xs
-
-linkish s = not ("<a" `isPrefixOf` s) && notElem ' ' s && elem '/' s
-
-linkify a b
-    | linkish a = [ "<a href=\"" ++ a ++ "\">" ++ b ++ "</a>" ]
-    | linkish b = [ "<a href=\"" ++ b ++ "\">" ++ a ++ "</a>" ]
-    | otherwise = [a,b]
+extract' expr = 
+    let f = extract' in
+    case expr of
+      Str s -> [s]
+      Binop op e1 e2 -> case (op, f e1, f e2) of
+                          ("++", [s1], [s2]) -> [s1 ++ s2]
+                          (_   , ss1 , ss2 ) -> ss1 ++ ss2
+      Lambda v e -> f e
+      App (App (Var "link") src) txt ->
+          case (f src, f txt) of
+            ([s1],[s2]) -> [ "<a href=\"" ++ s1 ++ "\">" ++ s2 ++ "</a>" ]
+            ( ss1, ss2) -> ss1 ++ ss2
+      App e1 e2 -> f e1 ++ f e2
+      If eb et ef -> f et ++ f ef
+      Let defs e -> concatMap (f . snd) defs ++ f e
+      Var _ -> []
+      Case e cases -> concatMap (f . snd) cases
+      Data _ es -> concatMap f es
+      _ -> []

src/GenerateHtml.hs

@@ -1,33 +1,42 @@
-{-# LANGUAGE OverloadedStrings #-}
-module GenerateHtml (generateHtml) where
-
-import Text.Blaze (preEscapedToMarkup)
-import qualified Text.Blaze.Html5 as H
-import Text.Blaze.Html5 ((!))
-import qualified Text.Blaze.Html5.Attributes as A
-
-css = preEscapedToMarkup $
-      ("* { padding:0; margin:0; \
-       \hyphens: auto; -moz-hyphens: auto;\
-       \ -webkit-hyphens: auto; -ms-hyphens: auto; }\
-       \body { font-family: Arial; }\
-       \a:link {text-decoration: none}\
-       \a:visited {text-decoration: none}\
-       \a:active {text-decoration: none}\
-       \a:hover {text-decoration: underline; color: #ff8f12;}" :: String)
-
-makeScript :: String -> H.Html
-makeScript s = H.script ! A.type_ "text/javascript" ! A.src (H.toValue s) $ ""
-
-generateHtml libLoc title source =
-    H.docTypeHtml $ do 
-      H.head $ do
-        H.meta ! A.charset "UTF-8"
-        H.title . H.toHtml $ title
-        makeScript libLoc
-        (H.script ! A.type_ "text/javascript") . preEscapedToMarkup $ source
-        H.style ! A.type_ "text/css" $ css
-      H.body $ do
-        H.div ! A.id "widthChecker" ! A.style "width:100%; height:1px; position:absolute; top:-1px;" $ ""
-        H.span ! A.id "content" $ ""
-        H.script ! A.type_ "text/javascript" $ "Dispatcher.initialize()"
+{-# LANGUAGE OverloadedStrings #-}
+module GenerateHtml (generateHtml) where
+
+import Text.Blaze (preEscapedToMarkup)
+import qualified Text.Blaze.Html5 as H
+import Text.Blaze.Html5 ((!))
+import qualified Text.Blaze.Html5.Attributes as A
+
+import Initialize
+import CompileToJS
+import ExtractNoscript
+
+css = preEscapedToMarkup $
+      ("* { padding:0; margin:0; \
+       \hyphens: auto; -moz-hyphens: auto;\
+       \ -webkit-hyphens: auto; -ms-hyphens: auto; }\
+       \body { font-family: Arial; }\
+       \a:link {text-decoration: none}\
+       \a:visited {text-decoration: none}\
+       \a:active {text-decoration: none}\
+       \a:hover {text-decoration: underline; color: #ff8f12;}" :: String)
+
+makeScript :: String -> H.Html
+makeScript s = H.script ! A.type_ "text/javascript" ! A.src (H.toValue s) $ ""
+
+generateHtml libLoc title source =
+    let expr = initialize source
+        js = compileToJS expr
+        noscript = either id extract expr
+    in
+    H.docTypeHtml $ do 
+      H.head $ do
+        H.meta ! A.charset "UTF-8"
+        H.title . H.toHtml $ title
+        makeScript libLoc
+        H.script ! A.type_ "text/javascript" $ preEscapedToMarkup js
+        H.style ! A.type_ "text/css" $ css
+      H.body $ do
+        H.div ! A.id "widthChecker" ! A.style "width:100%; height:1px; position:absolute; top:-1px;" $ ""
+        H.span ! A.id "content" $ ""
+        H.script ! A.type_ "text/javascript" $ "Dispatcher.initialize()"
+        H.noscript $ preEscapedToMarkup noscript

src/Language/Elm.hs

@@ -1,10 +1,15 @@
 
 module Language.Elm where
 
-import CompileToJS
 import GenerateHtml
 import Text.Blaze.Html (Html)
 
+-- | The 'compileToHtml' function takes three string arguments: the
+-- location of the Elm runtime (elm-mini.js), the title to be used in
+-- the resulting HTML page, and the Elm source code. For example,
+-- 
+-- > compileToHtml "/elm-mini.js" "Hello, World!" "main = plainText \"Hello, World!\""
+
 compileToHtml :: String -> String -> String -> Html
 compileToHtml libLoc fileName source =
-    generateHtml libLoc fileName (compileToJS source)
+    generateHtml libLoc fileName source