2013-06-14 05:45:08 +00:00
|
|
|
module Generate.Noscript (noscript) where
|
2012-04-19 06:32:10 +00:00
|
|
|
|
2013-06-14 05:45:08 +00:00
|
|
|
import Data.List (isInfixOf)
|
|
|
|
import SourceSyntax.Everything
|
2012-09-02 05:26:35 +00:00
|
|
|
import qualified Text.Pandoc as Pan
|
2012-04-19 06:32:10 +00:00
|
|
|
|
2013-06-14 05:45:08 +00:00
|
|
|
noscript :: Module t v -> String
|
|
|
|
noscript modul = concat (extract modul)
|
2012-05-27 21:10:10 +00:00
|
|
|
|
2012-11-23 03:48:54 +00:00
|
|
|
class Extract a where
|
|
|
|
extract :: a -> [String]
|
|
|
|
|
2013-06-14 05:45:08 +00:00
|
|
|
instance Extract (Module t v) where
|
2012-11-23 03:48:54 +00:00
|
|
|
extract (Module _ _ _ stmts) =
|
|
|
|
map (\s -> "<p>" ++ s ++ "</p>") (concatMap extract stmts)
|
|
|
|
|
2013-06-14 05:45:08 +00:00
|
|
|
instance Extract (Declaration t v) where
|
2012-11-23 03:48:54 +00:00
|
|
|
extract (Definition d) = extract d
|
|
|
|
extract _ = []
|
|
|
|
|
2013-06-14 05:45:08 +00:00
|
|
|
instance Extract (Def t v) where
|
2013-07-04 15:31:22 +00:00
|
|
|
extract (Def _ e) = extract e
|
2013-06-03 07:44:45 +00:00
|
|
|
extract _ = []
|
2012-11-23 03:48:54 +00:00
|
|
|
|
2013-05-29 23:20:38 +00:00
|
|
|
instance Extract e => Extract (Located e) where
|
|
|
|
extract (L _ _ e) = extract e
|
2012-12-25 08:39:18 +00:00
|
|
|
|
2013-06-14 05:45:08 +00:00
|
|
|
instance Extract (Expr t v) where
|
2012-11-23 03:48:54 +00:00
|
|
|
extract expr =
|
|
|
|
let f = extract in
|
2012-05-27 21:10:10 +00:00
|
|
|
case expr of
|
2013-06-14 05:45:08 +00:00
|
|
|
Literal (Str s) -> [s]
|
2012-05-27 21:10:10 +00:00
|
|
|
Binop op e1 e2 -> case (op, f e1, f e2) of
|
|
|
|
("++", [s1], [s2]) -> [s1 ++ s2]
|
|
|
|
(_ , ss1 , ss2 ) -> ss1 ++ ss2
|
|
|
|
Lambda v e -> f e
|
2013-06-14 05:45:08 +00:00
|
|
|
App (L _ _ (App (L _ _ (App (L _ _ (Var func)) w)) h)) src
|
|
|
|
| "image" `isInfixOf` func -> extractImage src
|
|
|
|
App (L _ _ (App (L _ _ (Var func)) src)) txt
|
|
|
|
| "link" `isInfixOf` func -> extractLink src txt
|
|
|
|
App (L _ _ (Var func)) e
|
|
|
|
| "header" `isInfixOf` func -> tag "h1" e
|
|
|
|
| "bold" `isInfixOf` func -> tag "b" e
|
|
|
|
| "italic" `isInfixOf` func -> tag "i" e
|
|
|
|
| "monospace" `isInfixOf` func -> tag "code" e
|
2012-05-27 21:10:10 +00:00
|
|
|
App e1 e2 -> f e1 ++ f e2
|
2012-11-23 03:48:54 +00:00
|
|
|
Let defs e -> concatMap extract defs ++ f e
|
2012-05-27 21:10:10 +00:00
|
|
|
Var _ -> []
|
|
|
|
Case e cases -> concatMap (f . snd) cases
|
|
|
|
Data _ es -> concatMap f es
|
2013-06-13 23:01:35 +00:00
|
|
|
MultiIf es -> concatMap (f . snd) es
|
2013-01-25 10:31:41 +00:00
|
|
|
Markdown doc -> [ Pan.writeHtmlString Pan.def doc ]
|
2012-06-12 06:28:45 +00:00
|
|
|
_ -> []
|
|
|
|
|
2013-06-14 05:45:08 +00:00
|
|
|
extractLink src txt =
|
2012-11-23 03:48:54 +00:00
|
|
|
case (extract src, extract txt) of
|
|
|
|
([s1],[s2]) -> [ "<a href=\"" ++ s1 ++ "\">" ++ s2 ++ "</a>" ]
|
|
|
|
( ss1, ss2) -> ss1 ++ ss2
|
|
|
|
|
2013-06-14 05:45:08 +00:00
|
|
|
extractImage src =
|
|
|
|
case extract src of
|
|
|
|
[s] -> ["<img src=\"" ++ s ++ "\">"]
|
|
|
|
ss -> ss
|
2012-11-23 03:48:54 +00:00
|
|
|
|
|
|
|
tag t e = map (\s -> concat [ "<", t, ">", s, "</", t, ">" ]) (extract e)
|