Enable generation of noscript tags.
For better indexing (for Google! Bing is actually fine...)
This commit is contained in:
parent
4546c0b6e8
commit
89605b15aa
4 changed files with 70 additions and 73 deletions
|
@ -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 = ("("++) . (++")")
|
||||
|
|
|
@ -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 =
|
||||
extract' expr =
|
||||
let f = extract' in
|
||||
case expr of
|
||||
Number _ -> []
|
||||
Chr _ -> []
|
||||
Boolean _ -> []
|
||||
Range _ _ -> []
|
||||
Access _ _ -> []
|
||||
Binop op e1 e2 -> case (op, extract' e1, extract' e2) 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 -> 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
|
||||
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 (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]
|
||||
Case e cases -> concatMap (f . snd) cases
|
||||
Data _ es -> concatMap f es
|
||||
_ -> []
|
|
@ -6,6 +6,10 @@ 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;\
|
||||
|
@ -20,14 +24,19 @@ 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 $ source
|
||||
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
|
||||
|
|
|
@ -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
|
Loading…
Reference in a new issue