anatomy 0.3 → 0.4
raw patch · 11 files changed
+489/−579 lines, 11 filesdep +blaze-htmldep +bytestringdep +highlighterdep ~atomo
Dependencies added: blaze-html, bytestring, highlighter, text
Dependency ranges changed: atomo
Files
- anatomy.cabal +11/−2
- lib/anatomy.css +61/−61
- lib/core.atomo +58/−36
- lib/highlight.css +60/−0
- lib/pretty.atomo +4/−295
- src/Anatomy/Atomo.hs +115/−11
- src/Anatomy/AutoFlow.hs +4/−4
- src/Anatomy/Builder.hs +59/−28
- src/Anatomy/Parser.hs +68/−139
- src/Anatomy/Scanner.hs +7/−1
- src/Anatomy/Types.hs +42/−2
anatomy.cabal view
@@ -1,5 +1,5 @@ name: anatomy-version: 0.3+version: 0.4 synopsis: Anatomy: Atomo documentation system description: A Scribble-like documentation language/builder for Atomo. homepage: http://atomo-lang.org/@@ -13,6 +13,7 @@ cabal-version: >= 1.6 data-files: lib/anatomy.css+ lib/highlight.css lib/*.atomo source-repository head@@ -24,17 +25,21 @@ build-depends: base >= 4 && < 5,- atomo >= 0.3,+ blaze-html,+ bytestring,+ atomo >= 0.4, containers, directory, filepath, hashable, haskeline,+ highlighter, mtl, parsec >= 3.0.0, pretty, pretty-show, tagsoup,+ text, time, vector @@ -60,15 +65,19 @@ build-depends: atomo >= 0.3, base >= 4,+ blaze-html,+ bytestring, containers, directory, filepath, hashable, haskeline,+ highlighter, mtl, parsec >= 3.0.0, pretty, pretty-show, tagsoup,+ text, time, vector
lib/anatomy.css view
@@ -17,7 +17,7 @@ } body {- font: normal 1.4em/1.6em 'Palatino Linotype', 'Book Antiqua', Palatino, Georgia, serif;+ font: normal 1.5em/1.46em 'Palatino Linotype', 'Book Antiqua', Palatino, FreeSerif, Georgia, serif; } pre, code {@@ -32,12 +32,15 @@ color: purple; } -ol {+ol, ul { margin-left: 2em; } ol li { list-style: decimal; }+ul li {+ list-style: square;+} strong { font-weight: bold } em { font-style: italic }@@ -51,6 +54,11 @@ font-size: 1.75em; margin-bottom: .5em; }+.section .section h2 {+ font-size: 1.4em;+ padding-bottom: .25em;+ border-bottom: 1px dotted #bbb;+} p { padding-bottom: 1em;@@ -61,7 +69,7 @@ } #sidebar {- background: #f0f0f0;+ background: rgba(0, 0, 0, .06); padding: 1em; width: 16em; height: 100%;@@ -80,6 +88,8 @@ #content { padding: 2em;+}+.with-sidebar #content { position: absolute; left: 0; right: 18em;@@ -92,6 +102,10 @@ padding: 1em 0; border-bottom: .1em dotted #000; }+.section .section {+ margin: 0;+ border: none;+} .definition { margin: 1em 0;@@ -104,18 +118,20 @@ margin-bottom: 1em; } -.verbatim, .interaction {+.verbatim, .interaction, .highlight { margin: 0 1em 1em; } pre a:link,-pre a:visited {- color: #000;+pre a:visited,+code a:link,+code a:visited {+ color: inherit; text-decoration: none; border-bottom: .1em solid #ddd;- font-weight: bold; }-pre a:hover {+pre a:hover,+code a:hover { border-bottom-color: #333; } @@ -131,65 +147,49 @@ color: #999; } -.list {- color: #000;- font-weight: normal;-}-.string {- color: #0086D2;- font-weight: bold;-}-.keyword {- color: #000;- font-weight: bold;-}-.integer {- color: #0086D2;- font-weight: bold;+.error-output {+ display: block;+ font-style: italic;+ background: #fee;+ color: #a33; }-.char {- color: #D20086;- font-weight: bold;++.annotated #content {+ position: static;+ padding: 0; }-.double {- color: #A640D2;- font-weight: bold;+.annotated #sidebar {+ z-index: 1;+ background: rgba(255, 255, 255, .5); }-.rational {- color: #26C052;- font-weight: bold;+.annotated-source {+ width: 100%; }-.particle {- color: #56B200;+.annotated-source thead h1 {+ line-height: 1em;+ margin: 1.2em 0 .39em 0; font-weight: bold; }-.internal {- font-style: italic;- color: #333;-}-.dispatch.single {- font-style: italic;- color: #000;- font-weight: normal;-}-.dispatch.single > a {- font-style: normal;-}-.dispatch.keyword {- color: inherit;- font-weight: inherit;-}-pre .dispatch.single {- font-style: normal;+.annotated-source .prose {+ background: #fff;+ width: 30em;+ max-width: 30em;+ min-width: 30em;+ padding: 1em 2em 0 3.5em;+ overflow-x: auto;+ vertical-align: top;+ text-align: left; }-pre .dispatch.single > a {- color: #000;- font-weight: bold;+.annotated-source .prose code,+.annotated-source .prose pre {+ background: #f8f8ff;+ border: .1em solid #dedede;+ padding: 0 0.2em;+ overflow-x: auto; }--.error-output {- display: block;- font-style: italic;- background: #fee;- color: #a33;+.annotated-source .code {+ background: #f5f5ff;+ border-left: .1em solid #e5e5e5;+ padding: 1.1em 2em 0em 1.5em;+ vertical-align: top; }
lib/core.atomo view
@@ -7,6 +7,7 @@ -- various semantic helpers A bold: s := s in-tag: "strong" A italic: s := s in-tag: "em"+A underline: s := s in-tag: "span style=\"text-decoration: underline\"" A code: (s: String) := s escape in-tag: "code" A list: s := s in-tag: "ul" A numbered-list: s := s in-tag: "ol"@@ -16,6 +17,19 @@ A verbatim: (s: String) := s escape in-tag: "pre class=\"verbatim\"" +-- annotated source code+(a: A) heading: (h: String) :=+ "<tr><th class=\"prose\"><h1>" .. h .. "</h1></th><th class=\"code\"></th></tr>"++(a: A) row: (s: String) :=+ "<tr><td class=\"prose\">" .. s .. "</td><td class=\"code\"></td></tr>"++(a: A) row: (s: String) is: (c: String) :=+ "<tr><td class=\"prose\">" .. s .. "</td><td class=\"code\">" .. (a atomo: c) .. "</td></tr>"++(a: A) row: (s: String) is: (c: String) on: target :=+ "<tr><td class=\"prose\">" .. s .. "</td><td class=\"code\">" .. (a atomo: c on: target) .. "</td></tr>"+ -- external link (a: A) link: name to: (url: Expression) := a link: name to: (a evaluate: url) (a: A) link: (name: Expression) to: url := a link: (a evaluate: name) to: url@@ -23,49 +37,44 @@ name in-tag: ("a href=\"" .. url .. "\" class=\"external\"") -- pretty-printing a single expr, inline-(a: A) atomo: (e: Expression) :=- (a pretty: e) in-tag: "code"---- pretty-printing a single expr, block-(a: A) atomo-line: (e: Expression) :=- (a pretty: e) in-tag: "pre class=\"verbatim\""+(a: A) hl: (e: Expression) :=+ a hl: (a evaluate: e)+(a: A) hl: (s: String) :=+ (a highlight: s) in-tag: "code" --- pretty-print a block of expressions-(a: A) atomo-segment: (e: Expression) :=- (a evaluate: e) contents (map: { c | a pretty: c }) (join: "\n")- in-tag: "pre class=\"verbatim\""+-- pretty-printing a block of code+(a: A) atomo: (s: String) on: (t: Expression) :=+ a atomo: s on: (a evaluate: t)+(a: A) atomo: (s: String) on: env :=+ { do-input: s in: env+ a atomo: s+ } call --- example code (unevaluated)-(a: A) example-segment: (e: Expression) :=- ("<em>Example:</em>" .. (a atomo-segment: e))+-- example interaction session+(a: A) example: (s: String) :=+ a example: s on: Lobby clone+(a: A) example: (s: String) on: (t: Expression) :=+ a example: s on: (a evaluate: t)+(a: A) example: (s: String) on: env :=+ ("<em>Example:</em>" .. (a interaction: s on: env)) in-tag: "div class=\"example\"" --- pretty-print a block of Atomo code, multiline-(a: A) atomo-block: (e: Expression) :=- a atomo-block: (a evaluate: e)-(a: A) atomo-block: (b: Block) :=- with: multiline-pretty? as: True do: {- b contents (map: { e | a atomo-line: e }) join- }- -- example interaction session-(a: A) example: (e: Expression) :=- ("<em>Example:</em>" .. (a interaction: e))+(a: A) example-segment: (s: String) :=+ ("<em>Example:</em>" .. (a atomo: s)) in-tag: "div class=\"example\"" -- a REPL simulator-(a: A) interaction: (e: Expression) :=- a interaction: (a evaluate: e) on: Lobby clone-(a: A) interaction: (b: Block) :=- a interaction: b on: Lobby clone+(a: A) interaction: (s: String) :=+ a interaction: s on: Lobby clone -- a REPL simulator locked into an environment-(a: A) interaction: (e: Expression) on: (t: Expression) :=- a interaction: (a evaluate: e) on: (a evaluate: t)-(a: A) interaction: (b: Block) on: env :=- { ("interaction: " .. b show) print+(a: A) interaction: (s: String) on: (t: Expression) :=+ a interaction: s on: (a evaluate: t)+(a: A) interaction: (s: String) on: env :=+ { ("interaction: " .. s show) print - log = b contents (map: { e |+ log = s lines (map: { e | output = String-Port new do: { display: s := { output contents = output contents .. s (as: String) escape@@ -76,7 +85,7 @@ error = String-Port new do: { display: s := { error contents = error contents .. (s as: String)- output contents = output contents .. (s (as: String) escape type: "error-output")+ output contents = output contents .. (s (as: String) escape type: "gr") s } call }@@ -87,16 +96,16 @@ *error-output* -> error ] do: { with-output-to: output do: {- a pretty: (env evaluate: e expand)+ a highlight: (do-input: e in: env) show } } } catch: { e |- (a pretty: e) type: "error"+ ("ERROR: " .. (a highlight: e show)) type: "gr" } [ ">" type: "caret" " "- a pretty: e+ a highlight: e "\n" output contents res@@ -106,3 +115,16 @@ log in-tag: "pre class=\"interaction\"" } call++evaluate-all: [] in: _ := error: @no-expressions+evaluate-all: [e] in: t := t evaluate: e+evaluate-all: (e . es) in: t :=+ { t evaluate: e+ evaluate-all: es in: t+ } call++do-input: (s: String) in: env :=+ s parse-expressions match: {+ [] -> @undefined+ es -> evaluate-all: (es map: @expand) in: env+ }
+ lib/highlight.css view
@@ -0,0 +1,60 @@+.hll { background-color: #ffffcc }+.c { color: #888888 } /* Comment */+.err { color: #a61717; background-color: #e3d2d2 } /* Error */+.k { color: #008800; font-weight: bold } /* Keyword */+.cm { color: #888888 } /* Comment.Multiline */+.cp { color: #cc0000; font-weight: bold } /* Comment.Preproc */+.c1 { color: #888888 } /* Comment.Single */+.cs { color: #cc0000; font-weight: bold; background-color: #fff0f0 } /* Comment.Special */+.gd { color: #000000; background-color: #ffdddd } /* Generic.Deleted */+.ge { font-style: italic } /* Generic.Emph */+.gr { color: #aa0000 } /* Generic.Error */+.gh { color: #303030 } /* Generic.Heading */+.gi { color: #000000; background-color: #ddffdd } /* Generic.Inserted */+.go { color: #888888 } /* Generic.Output */+.gp { color: #555555 } /* Generic.Prompt */+.gs { font-weight: bold } /* Generic.Strong */+.gu { color: #606060 } /* Generic.Subheading */+.gt { color: #aa0000 } /* Generic.Traceback */+.kc { color: #008800; font-weight: bold } /* Keyword.Constant */+.kd { color: #008800; font-weight: bold } /* Keyword.Declaration */+.kn { color: #008800; font-weight: bold } /* Keyword.Namespace */+.kp { color: #008800 } /* Keyword.Pseudo */+.kr { color: #008800; font-weight: bold } /* Keyword.Reserved */+.kt { color: #888888; font-weight: bold } /* Keyword.Type */+.m { color: #0000DD; font-weight: bold } /* Literal.Number */+.s { color: #dd2200; background-color: #fff0f0 } /* Literal.String */+.na { color: #336699 } /* Name.Attribute */+.nb { color: #003388 } /* Name.Builtin */+.nc { color: #bb0066; font-weight: bold } /* Name.Class */+.no { color: #003366; font-weight: bold } /* Name.Constant */+.nd { color: #555555 } /* Name.Decorator */+.ne { color: #bb0066; font-weight: bold } /* Name.Exception */+.nf { color: #0066bb; font-weight: bold } /* Name.Function */+.nl { color: #336699; font-style: italic } /* Name.Label */+.nn { color: #bb0066; font-weight: bold } /* Name.Namespace */+.py { color: #336699; font-weight: bold } /* Name.Property */+.nt { color: #bb0066; font-weight: bold } /* Name.Tag */+.nv { color: #336699 } /* Name.Variable */+.ow { color: #008800 } /* Operator.Word */+.w { color: #bbbbbb } /* Text.Whitespace */+.mf { color: #0000DD; font-weight: bold } /* Literal.Number.Float */+.mh { color: #0000DD; font-weight: bold } /* Literal.Number.Hex */+.mi { color: #0000DD; font-weight: bold } /* Literal.Number.Integer */+.mo { color: #0000DD; font-weight: bold } /* Literal.Number.Oct */+.sb { color: #dd2200; background-color: #fff0f0 } /* Literal.String.Backtick */+.sc { color: #dd2200; background-color: #fff0f0 } /* Literal.String.Char */+.sd { color: #dd2200; background-color: #fff0f0 } /* Literal.String.Doc */+.s2 { color: #dd2200; background-color: #fff0f0 } /* Literal.String.Double */+.se { color: #0044dd; background-color: #fff0f0 } /* Literal.String.Escape */+.sh { color: #dd2200; background-color: #fff0f0 } /* Literal.String.Heredoc */+.si { color: #3333bb; background-color: #fff0f0 } /* Literal.String.Interpol */+.sx { color: #22bb22; background-color: #f0fff0 } /* Literal.String.Other */+.sr { color: #008800; background-color: #fff0ff } /* Literal.String.Regex */+.s1 { color: #dd2200; background-color: #fff0f0 } /* Literal.String.Single */+.ss { color: #aa6600; background-color: #fff0f0 } /* Literal.String.Symbol */+.bp { color: #003388 } /* Name.Builtin.Pseudo */+.vc { color: #336699 } /* Name.Variable.Class */+.vg { color: #dd7700 } /* Name.Variable.Global */+.vi { color: #3333bb } /* Name.Variable.Instance */+.il { color: #0000DD; font-weight: bold } /* Literal.Number.Integer.Long */
lib/pretty.atomo view
@@ -24,304 +24,14 @@ -- default pretty-printer; just do @show-A pretty: o :=- { s = o show-- if: (s starts-with?: "<")- then: { s escape type: "internal" }- else: { s escape }- } call---- primitive pretty-printers-A pretty: (c: Char) := c show escape type: "char"-A pretty: (b: Boolean) := b show escape type: "keyword boolean"-A pretty: (d: Double) := d show escape type: "number double"-A pretty: (i: Integer) := i show escape type: "number integer"-A pretty: (r: Rational) := r show escape type: "number rational"-A pretty: (c: String) := c show escape type: "string"---- pattern pretty-printing; lop off "<pattern [...]>" normally-A pretty: (p: Pattern) :=- if: value-output?- then: { p show escape type: "internal" }- else: {- p show (drop: "<pattern " length) init escape- type: "pattern"- }---- pretty-print both sides of an Association-(a: A) pretty: (as: Association) :=- (a pretty: as from) .. " -> " escape .. (a pretty: as to)--(a: A) pretty: (p: Particle) :=- p type match: {- @single -> ("@" .. p name escape (type: "name")) type: "particle"- @keyword -> a pretty-particle: p- }--(a: A) pretty: (l: List) :=- ("[" .. l (map: { l | a pretty: l }) (join: ", ") .. "]") type: "list"--(a: A) pretty: (b: Block) :=- with: [- context -> @top- value-output? -> False- indent-level -> indent-level + 1- ] do: {- arguments = b arguments (map: { p | a pretty: p }) (join: " ")-- pretty-contents = b contents (map: { e | a pretty: e })-- contents =- if: multiline-pretty?- then: {- exprs = pretty-contents (map: { c | "\n" .. (indented: c) }) join strip-end- exprs .. unindent- }- else: { " " .. pretty-contents (join: "; ") .. " " }-- condition: {- contents strip empty? && b arguments empty? ->- "{ }" type: "block"-- contents strip empty? ->- ("{ " .. arguments .. " | }") type: "block"-- b arguments empty? ->- ("{" .. contents .. "}") type: "block"-- otherwise ->- ("{ " .. arguments .. " |" .. contents .. "}") type: "block"- }- }-+(a: A) pretty: o := a highlight: o show (a: A) pretty: (e: Expression) :=- { pretty = e type match: {- @(dispatch: type) ->- with: value-output? as: False do: {- a pretty-dispatch: e type: type- }-- @define ->- with: [- value-output? -> False- context -> @define- ] do: {- pat = a pretty: e pattern-- if: multiline-pretty?- then: {- with: [- indent-level -> indent-level + 1- context -> @define- ] do: {- expr = a pretty: e expression- pat .. " :=\n" .. (indented: expr) .. "\n"- }- }- else: {- with: context as: @define do: {- expr = a pretty: e expression- pat .. " := " .. expr- }- }- }-- @set ->- with: [- value-output? -> False- context -> @set- ] do: {- (a pretty: e pattern) .. " = " .. (a pretty: e expression)- }-- @list ->- with: [- value-output? -> False- context -> @list- ] do: {- "[" .. e contents (map: { l | a pretty: l }) (join: ", ") .. "]"- }-- @(particle: @single) -> a pretty: (a evaluate: e)-- @(particle: @keyword) ->- with: context as: @particle do: {- a pretty-particle: e- }-- @primitive ->- with: value-output? as: True do: {- a pretty: (a evaluate: e)- }-- @block ->- with: context as: @block do: {- a pretty: (a evaluate: e)- }-- @top -> "this" type: "keyword top"-- @macro ->- [ "macro" type: "keyword macro"- "(" .. (a pretty: e pattern) .. ")"- a pretty: e expression- ] unwords-- @operator ->- [ "operator" type: "keyword operator"- e associativity name- a pretty: e precedence- e operators- (map: { o | a linked: `~o as: o names head })- unwords- ] unwords-- @for-macro ->- [ "for-macro" type: "keyword for-macro"- a pretty: e expression- ] unwords-- @quote ->- with: [- value-output? -> False- context -> @quote- ] do: {- "`" .. (a pretty-segment: e expression)- }-- @unquote ->- with: [- value-output? -> False- context -> @unquote- ] do: {- "~" .. (a pretty-segment: e expression)- }-- x -> e show (drop: 2) init escape -- remove '( and )- }-- condition: {- value-output? not -> pretty-- e needs-parens? ->- "'(" .. pretty .. ")"-- otherwise -> "'" .. pretty- }- } call--(e: Expression) needs-parens? :=- e type match: {- @(dispatch: @single) ->- e target type /= @top-- x -> x in?: [@define, @set, @(dispatch: @keyword)]- }--(a: A) pretty-segment: (e: Expression) :=- if: e needs-parens?- then: { "(" .. (a pretty: e) .. ")" }- else: { a pretty: e }--(a: A) pretty-dispatch: e type: @single :=- with: context as: @single do: {- msg = (a linked: e as: e name) type: "dispatch single"-- if: (e target type == @top)- then: { msg }- else: { (a pretty: e target) .. " " .. msg }- }--(a: A) pretty-dispatch: e type: @keyword :=- condition: {- e targets empty? ->- (a linked: e as: e names (map: @keywordfy) join)- type: "dispatch keyword"-- e names == [":="] ->- with: context as: @define do: {- pat = a pretty: e targets head- exp = e targets (at: 1)- key = a linked: e as: ":="-- if: multiline-pretty?- then: {- modify: indent-level as: @(+ 1) do: {- expr = a pretty: exp- pat .. " " .. key .. "\n" .. (indented: expr) .. "\n"- }- } else: {- pat .. " " .. key .. " " .. (a pretty: exp)- }- }-- e names == ["="] ->- with: context as: @set do: {- pat = a pretty: e targets head- exp = e targets (at: 1)- key = a linked: e as: "="-- pat .. " " .. key .. " " .. (a pretty: exp)- }-- otherwise ->- { from = context-- with: context as: @keyword do: {- initial =- if: (e targets head type == @top)- then: { "" }- else: { (a pretty: e targets head) .. " " }-- rest =- (0 ... e names length) (map: { n |- name = e names (at: n)- value = a pretty: e targets (at: (n + 1))-- (a linked: e as: name keywordfy) .. " " .. value- }) join: " "-- (if: (from == @single || from == @keyword)- then: { "(" .. initial .. rest .. ")" }- else: { initial .. rest })- type: "dispatch keyword"- }- } call- }--(a: A) pretty-particle: p :=- if: p values (all?: @(== @none))- then: {- ("@" ..- p names- (map: { n | n keywordfy escape (type: "names") })- join- ) type: "particle"- }+ if: value-output?+ then: { a highlight: e show } else: {- initial =- p values head match: {- @none -> ""- @(ok: v) -> a pretty: v- }-- ks = (0 ... p names length) map:- { n |- name = p names (at: n)- value =- p values (at: (n + 1)) match: {- @none -> "_"- @(ok: v) -> a pretty: v- }-- name keywordfy escape (type: "names") .. " " .. value- }-- ("@(" .. initial .. ks (join: " ") .. ")") type: "particle"+ a highlight: e pretty-expression render } - -- find a url for an expression, and link it with t as the text (a: A) linked: (e: Expression) as: (t: String) := a (url-for: e) match: {@@ -329,4 +39,3 @@ @(ok: u) -> t escape in-tag: ("a href=\"" .. docs-root .. u .. "\"") }-
src/Anatomy/Atomo.hs view
@@ -1,9 +1,18 @@-{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE OverloadedStrings, QuasiQuotes #-} module Anatomy.Atomo where import Data.Dynamic+import Data.Text.Encoding+import Prelude hiding (div, span) import System.Directory import System.FilePath+import Text.Blaze.Html5 hiding (p, string)+import Text.Blaze.Html5.Attributes hiding (name, span)+import Text.Blaze.Renderer.String+import Text.Highlighter.Lexers.Atomo (lexer)+import qualified Data.ByteString as BS+import qualified Data.Text as T+import qualified Text.Highlighter as HL import Atomo import Atomo.Load@@ -35,25 +44,25 @@ [$p|(a: A) url-for: (e: Expression)|] =: do Expression ae <- here "e" >>= findExpression- Haskell a <- eval [$e|a state|]+ Haskell ds <- eval [$e|a state|] - let st = fromDyn a (error "hotlink A is invalid") :: Section+ let st = fromDyn ds (error "hotlink A is invalid") :: Section find <- case ae of- Dispatch { eMessage = Single { mName = n } } ->+ EDispatch { eMessage = Single { mName = n } } -> runAVM' (findBinding (SingleKey n) st) st- Dispatch { eMessage = Keyword { mNames = ns } } ->+ EDispatch { eMessage = Keyword { mNames = ns } } -> runAVM' (findBinding (KeywordKey ns) st) st - EParticle { eParticle = PMSingle n } ->+ EParticle { eParticle = Single { mName = n } } -> runAVM' (findBinding (SingleKey n) st) st- EParticle { eParticle = PMKeyword ns _ } ->+ EParticle { eParticle = Keyword { mNames = ns } } -> runAVM' (findBinding (KeywordKey ns) st) st - Primitive { eValue = Particle (PMSingle n) } ->+ EPrimitive { eValue = Particle (Single { mName = n }) } -> runAVM' (findBinding (SingleKey n) st) st- Primitive { eValue = Particle (PMKeyword ns _) } ->+ EPrimitive { eValue = Particle (Keyword { mNames = ns }) } -> runAVM' (findBinding (KeywordKey ns) st) st _ -> raise ["no-url-for"] [Expression ae]@@ -65,9 +74,9 @@ [$p|(a: A) reference: (s: String)|] =: do n <- getString [$e|s|]- Haskell a <- eval [$e|a state|]+ Haskell ds <- eval [$e|a state|] - let st = fromDyn a (error "hotlink A is invalid") :: Section+ let st = fromDyn ds (error "hotlink A is invalid") :: Section flip runAVM' st $ do ms <- findSection n st@@ -77,3 +86,98 @@ url <- sectionURL s name <- buildForString' (titleText (sectionTitle s)) return (string $ "<a href=\"" ++ url ++ "\">" ++ name ++ "</a>")++ [$p|(a: A) atomo: (s: String)|] =: do+ s <- getText [$e|s|]+ Haskell ds <- eval [$e|a state|]++ let st = fromDyn ds (error "hotlink A is invalid") :: Section++ case HL.runLexer lexer (encodeUtf8 s) of+ Left err ->+ error ("lexing of Atomo source failed: " ++ show (s, err))+ Right ts ->+ liftM (string . renderHtml . (div ! class_ (stringValue "highlight")) . pre) (runAVM' (autoLink ts) st)++ [$p|(a: A) highlight: (s: String)|] =: do+ s <- getText [$e|s|]+ Haskell ds <- eval [$e|a state|]++ let st = fromDyn ds (error "hotlink A is invalid") :: Section++ case HL.runLexer lexer (encodeUtf8 s) of+ Left err ->+ error ("lexing of Atomo source failed: " ++ show (s, err))+ Right ts ->+ liftM (string . renderHtml) (runAVM' (autoLink ts) st)++++-- Format lexed source, auto-linking dispatches to their definitions.+autoLink :: [HL.Token] -> AVM Html+autoLink = autoLink' ([], "")+ where+ autoLink' _ [] = return (return ())+ autoLink' cks (HL.Token HL.Name s:ts) = do+ st <- get+ mu <- findBinding (SingleKey (fromBS s)) st+ case mu of+ Nothing -> do+ rest <- autoLink' cks ts+ return $ (span ! class_ (stringValue "n") $ bs s) >> rest+ Just u -> do+ rest <- autoLink' cks ts+ return $ (span ! class_ (stringValue "n") $ a ! href (stringValue u) $ bs s) >> rest+ autoLink' cks (HL.Token HL.Operator s:ts) = do+ st <- get+ mu <- findBinding (KeywordKey [fromBS s]) st+ case mu of+ Nothing -> do+ rest <- autoLink' cks ts+ return $ (span ! class_ (stringValue "o") $ bs s) >> rest+ Just u -> do+ rest <- autoLink' cks ts+ return $ (span ! class_ (stringValue "o") $ a ! href (stringValue u) $ bs s) >> rest+ autoLink' ([], _) (HL.Token (HL.Name HL.:. HL.Function) s:ts) = do+ st <- get+ let full = init (fromBS s) : restOf ts+ mu <- findBinding (KeywordKey full) st+ case mu of+ Nothing -> do+ rest <- autoLink' (tail full, "") ts+ return $ (span ! class_ "nf" $ bs s) >> rest+ Just u -> do+ rest <- autoLink' (tail full, u) ts+ return $ (span ! class_ "nf" $ a ! href (stringValue u) $ bs s) >> rest+ autoLink' (cks, u) (HL.Token (HL.Name HL.:. HL.Function) s:ts) = do+ rest <- autoLink' (tail cks, u) ts+ if not (null u)+ then return $ (span ! class_ "nf" $ a ! href (stringValue u) $ bs s) >> rest+ else return $ (span ! class_ "nf" $ bs s) >> rest+ autoLink' cks (HL.Token t s:ts) = do+ rest <- autoLink' cks ts+ return $ (span ! class_ (stringValue $ HL.shortName t) $ bs s) >> rest++-- Retrieve the rest of a keyword message name from a list of tokens.+restOf :: [HL.Token] -> [String]+restOf [] = []+restOf (HL.Token _ "(":ts) =+ restOf (drop 1 $ dropWhile ((/= "(") . HL.tText) $ ts)+restOf (HL.Token _ "{":ts) =+ restOf (drop 1 $ dropWhile ((/= "}") . HL.tText) $ ts)+restOf (HL.Token _ "[":ts) =+ restOf (drop 1 $ dropWhile ((/= "]") . HL.tText) $ ts)+restOf (HL.Token _ ")":_) = []+restOf (HL.Token _ "}":_) = []+restOf (HL.Token _ "]":_) = []+restOf (HL.Token (HL.Name HL.:. HL.Function) n:ts) =+ init (fromBS n) : restOf ts+restOf (HL.Token HL.Text x:_)+ | toEnum (fromEnum '\n') `BS.elem` x = []+restOf (_:ts) = restOf ts++bs :: BS.ByteString -> Html+bs = text . decodeUtf8++fromBS :: BS.ByteString -> String+fromBS = T.unpack . decodeUtf8
src/Anatomy/AutoFlow.hs view
@@ -15,7 +15,7 @@ -- inline element, not in a <p>; start a <p> | isPhrasing n = TagOpen "p" [] : o : autoFlow' True ts- + -- opening a block element; </p> | open = TagClose "p" : autoFlow' False (o:ts) @@ -41,7 +41,7 @@ | open = thisPara : autoFlow' True rest -- text, pop it in a <p>- | otherwise = TagOpen "p" [] : t : autoFlow' True ts+ | otherwise = TagOpen "p" [] : thisPara : autoFlow' True rest where thisPara = TagText (takeWhile (/= '\n') c) rest@@ -59,14 +59,14 @@ -- flow content, excluding phrasing isBlock :: String -> Bool isBlock = flip elem . words $- "article aside blockquote details div dl fieldset figure footer form h1 h2 h3 h4 h5 h6 header hgroup hr menu nav ol p pre section style table ul"+ "article aside blockquote details div dl fieldset figure footer form h1 h2 h3 h4 h5 h6 header hgroup hr menu nav ol p pre section style table tr td ul li" isFlow :: String -> Bool isFlow x = isPhrasing x || isBlock x isFlowable :: String -> Bool isFlowable = flip elem . words $- "article aside blockquote dd div dl footer header section"+ "article aside blockquote dd div dl footer header section table tr td ul ol li" getTagContent :: String -> [Tag String] -> [Tag String] getTagContent n ts' = getTagContent' 0 [] ts'
src/Anatomy/Builder.hs view
@@ -4,6 +4,7 @@ import Data.Char import Data.Dynamic import Data.IORef+import Data.Maybe (isJust) import System.Directory import System.FilePath import Text.HTML.TagSoup@@ -16,7 +17,6 @@ import Atomo.Environment import Atomo.Run-import Atomo.PrettyVM import Atomo.Types import Atomo.Parser.Expand (macroExpand) @@ -39,17 +39,12 @@ return (fromText $ fromString res) build (Atomo e) = do env <- gets sectionA >>= lift . dispatch . single "environment"- e' <- lift (macroExpand e)- r <- lift (liftM show $ withTop env (eval e') >>= prettyVM)-- case e' of- Set {} -> return ""- Define {} -> return ""- _ -> return r+ lift (macroExpand e >>= withTop env . eval)+ return "" build (Nested ss) = fmap concat $ mapM build ss build (SectionReference n) = do style <- gets sectionStyle- if style == TOC+ if styleMatch TOC style then return "" else do @@ -143,8 +138,13 @@ buildFile :: FilePath -> FilePath -> IO () buildFile fn o = do+ createDirectoryIfMissing True o+ css <- getDataFileName "lib/anatomy.css" >>= readFile+ hl <- getDataFileName "lib/highlight.css" >>= readFile+ writeFile (o </> "anatomy.css") css+ writeFile (o </> "highlight.css") hl path <- fmap takeDirectory $ canonicalizePath fn @@ -169,7 +169,7 @@ liftIO . print . titleText $ sectionTitle s - when (sectionStyle s == TOC) $ do+ when (styleMatch TOC $ sectionStyle s) $ do liftIO (putStrLn "building subsections first for table of contents") mapM_ (runAVM (buildDocument o)) (subSections s) @@ -180,7 +180,16 @@ title <- build . titleText . sectionTitle $ s liftIO (putStrLn "building body")- body <- fmap concat $ mapM build (sectionBody s)+ body <- fmap concat $ forM (sectionBody s) $ \b -> do+ case b of+ SectionReference n | and+ [ not (styleMatch TOC (sectionStyle s))+ , styleMatch TOC (sectionStyle $ subSections s !! n)+ ] -> do+ let c = subSections s !! n+ runAVM (buildDocument o) c+ return ""+ _ -> build b liftIO (putStrLn "getting parent") parent <-@@ -194,35 +203,57 @@ fn <- sectionURL s liftIO (putStrLn fn) - liftIO . writeFile (o </> fn) $- format toc title body parent+ let showTOC = isJust parent || not (null (subSections s))+ classes | showTOC = "with-sidebar " ++ styleToClass (sectionStyle s)+ | otherwise = styleToClass (sectionStyle s) - return (particle "done")- where- format toc t b mp = unlines+ liftIO . writeFile (o </> fn) . unlines $ [ "<!DOCTYPE html>" , "<html>" , " <head>" , " <meta http-equiv=\"content-type\" content=\"text/html; charset=utf-8\" />"- , " <title>" ++ stripTags t ++ "</title>"+ , " <title>" ++ stripTags title ++ "</title>" , " <link rel=\"stylesheet\" type=\"text/css\" href=\"anatomy.css\" />"+ , " <link rel=\"stylesheet\" type=\"text/css\" href=\"highlight.css\" />" , " </head>"- , " <body>"- , " <div id=\"sidebar\">"- , " <h4>On this page:</h4>"- , toc- , case mp of- Nothing -> ""- Just p -> "<h4>Up one level:</h4>" ++ p- , " </div>"+ , " <body class=\"" ++ classes ++ "\">"++ , if showTOC+ then unlines+ [ " <div id=\"sidebar\">"+ , " <h4>On this page:</h4>"+ , toc+ , case parent of+ Nothing -> ""+ Just p -> "<h4>Up one level:</h4>" ++ p+ , " </div>"+ ]+ else ""+ , " <div id=\"content\">"- , " <h1>" ++ t ++ "</h1>"- , autoFlow b+ , contentFor (sectionStyle s) title (autoFlow body) , " </div>" , " </body>" , "</html>" ] + return (particle "done")++contentFor :: Style -> String -> String -> String+contentFor s t b+ | styleMatch Annotated s =+ concat+ [ "<table class=\"annotated-source\">"+ , "<thead><tr><th class=\"prose\"><h1>" ++ t ++ "</h1></th><th class=\"code\"></th></tr></thead>"+ , b+ , "</table>"+ ]+ | otherwise =+ concat+ [ "<h1>" ++ t ++ "</h1>"+ , b+ ]+ getAObject :: AVM Value getAObject = do s <- get@@ -305,7 +336,7 @@ pageURL s sectionURL s@(Section { sectionParent = Just sr }) = do p <- liftIO (readIORef sr)- if sectionStyle p == TOC+ if styleMatch TOC (sectionStyle p) then pageURL s else do st <- buildForString' (tagOrTitle s)
src/Anatomy/Parser.hs view
@@ -1,118 +1,97 @@ module Anatomy.Parser (parseFile, parseDefinition) where import Control.Monad.Error-import Data.Char (isSpace)-import Data.List (intercalate) import Text.Parsec hiding (parse) import Atomo.Parser (continue)-import Atomo.Parser.Base (Parser)+import Atomo.Lexer.Base (TaggedToken) import Atomo.Parser.Expand import Atomo.Parser.Expr hiding (parser) import qualified Atomo.Types as AT-import qualified Atomo.Parser.Base as AB+import qualified Atomo.Parser.Base as AP -import Anatomy.Debug+import Anatomy.Lexer (lexer, defLexer, tagged)+import Anatomy.Parser.Base import Anatomy.Types -special :: Char-special = '#'--nested :: Parser [Segment]-nested = do- ps <- getState+pNested :: Parser Segment+pNested = do pos <- getPosition- block <- balancedBetween '{' '}'- res <- lift $ runParserT parser ps (show pos) (cleanup block)- case res of+ s <- getState+ ts <- nested+ case runParser p s (show pos) ts of Left e -> fail ("nested: " ++ show e)- Right ok -> return ok+ Right (r, s') -> do+ putState s'+ return (Nested r) where- cleanup s = intercalate "\n" . map (drop indentLevel) $ ls- where- ls = dropWhile null . lines $ s- indentLevel = length . takeWhile isSpace $ head ls---chunk :: Parser Segment-chunk = do- c <- satisfy (/= special)- cs <- anyToken `manyTill` (eof <|> lookAhead (char special >> return ()))- dump ("got chunk", c:cs)- return (Chunk (c:cs))--keyword :: Parser Segment-keyword = do- char special- ks <- many1 . try $ do- name <- AB.anyIdent- char ':'- val <- choice- [ fmap Nested nested- , try $ fmap Atomo . choice $- -- literal value- [ unlexeme pLiteral-- -- arbitrary expr- , try . between (char '(') (char ')') $- pExpr- ]-- -- operator reference- , try $ fmap (\x -> Atomo $ AT.Dispatch Nothing (AT.keyword [x] [])) $- between (char '(') (char ')')- (many1 (satisfy AB.isOpLetter))-- -- keyword reference- , try $ fmap (\ks -> Atomo $ AT.Dispatch Nothing (AT.keyword ks [])) $- between (char '(') (char ')')- (many1 (AB.identifier >>= \n -> char ':' >> return n))-- -- single reference; trailing punctuation is ignored- , do- ident <- AB.anyIdent+ p = do+ r <- parser+ s <- getState+ return (r, s) - let punct = reverse . takeWhile AB.isOpLetter . reverse $ ident- sane = reverse . dropWhile AB.isOpLetter . reverse $ ident+subParse :: [TaggedAToken] -> Parser [Segment]+subParse ts = do+ pos <- getPosition+ s <- getState+ case runParser p s (show pos) ts of+ Left e -> fail ("sub: " ++ show e)+ Right (r, s') -> do+ putState s'+ return r+ where+ p = do+ r <- parser+ s <- getState+ return (r, s) - getInput >>= setInput . (punct ++)+pChunk :: Parser Segment+pChunk = do+ c <- chunk+ return (Chunk c) - return . Atomo . AT.Dispatch Nothing $ AT.single sane (AT.ETop Nothing)- ]- dump ("got value", val)- return (name, val)+pKeyword :: Parser Segment+pKeyword = do+ (ns, ts) <- keyword+ ss <- subParse ts+ return (KeywordDispatch ns ss) - let (ns, vs) = unzip ks+pSingle :: Parser Segment+pSingle = fmap SingleDispatch single - return (KeywordDispatch ns vs)+pAtomo :: Parser Segment+pAtomo = do+ ts <- atomo+ fmap Atomo (subAtomo pExpr ts) -single :: Parser Segment-single = fmap (debug "single") $ do- char special- name <- AB.identifier- notFollowedBy (char ':')- dump ("got single identifier", name)- return (SingleDispatch name)+subAtomo :: AP.Parser a -> [TaggedToken] -> Parser a+subAtomo p ts = do+ pos <- getPosition+ s <- getState+ case runParser p s (show pos) ts of+ Left e -> fail ("atomo: " ++ show e)+ Right ok -> return ok -atomo :: Parser Segment-atomo = fmap (debug "atomo") $ do- char special- fmap Atomo (between (char '(') (char ')') pExpr)+pDefinition :: Parser Definition+pDefinition = do+ (t, cs, r) <- definition+ nt <- subAtomo pDispatch t+ ncs <- mapM (subAtomo pDispatch) cs+ nr <- subAtomo pDispatch r+ return (Definition nt ncs nr) parser :: Parser [Segment] parser = do ss <- many $ choice- [ try keyword- , try single- , try atomo- , chunk+ [ pKeyword+ , pSingle+ , pAtomo+ , pNested+ , pChunk ] eof return ss -parseFile :: String -> AT.VM [Segment]-parseFile fn = liftIO (readFile fn) >>= continue parser fn >>= mapM expandSegment- expandSegment :: Segment -> AT.VM Segment expandSegment (Atomo e) = liftM Atomo (macroExpand e) expandSegment (Nested ss) =@@ -121,61 +100,11 @@ liftM (InlineDefinition d . Just) (expandSegment s) expandSegment s = return s -defParser :: Parser Definition-defParser = do- thumb <- pDispatch-- AB.whiteSpace-- cs <- many . try $ do- AB.symbol "|"- d <- pDispatch- AB.whiteSpace- return d-- AB.whiteSpace-- ret <- AB.symbol ">" >> pDispatch-- return Definition- { defThumb = thumb- , defContracts = cs- , defReturn = ret- }---- restore the whitespace that a lexeme parser nom'd up-unlexeme :: Parser a -> Parser a-unlexeme p = do- before <- getInput- r <- p- after <- getInput- backtrack before after- return r- where- backtrack b a = setInput (trailing ++ a)- where- trailing- = reverse- . takeWhile isSpace- . reverse- . take (length b - length a)- $ b---- grab text between characters, balanced-balancedBetween :: Char -> Char -> Parser String-balancedBetween o c = try $ do- char o- raw <- many . choice $- [ many1 $ noneOf [o, c]- , do- res <- balancedBetween o c- return $ o : res ++ [c]- ]- char c- return $ concat raw+parseFile :: String -> AT.VM [Segment]+parseFile fn = liftIO (readFile fn) >>= continue lexer parser fn >>= mapM expandSegment parseDefinition :: String -> AT.VM Definition parseDefinition = continue- (do { r <- defParser; eof; return r })+ (fmap (:[]) $ tagged defLexer)+ (do { r <- pDefinition; eof; return r }) "<definition>"-
src/Anatomy/Scanner.hs view
@@ -87,8 +87,14 @@ liftIO (putStrLn "table of contents") scan' (acc- { sectionStyle = TOC+ { sectionStyle = addStyle TOC (sectionStyle acc) , sectionBody = sectionBody acc ++ [TableOfContents]+ }) ss+ scan' acc (SingleDispatch "annotated-source":ss) = do+ liftIO (putStrLn "annotated source")++ scan' (acc+ { sectionStyle = addStyle Annotated (sectionStyle acc) }) ss scan' acc (s:ss) = scan' (acc { sectionBody = sectionBody acc ++ [s] }) ss
src/Anatomy/Types.hs view
@@ -4,7 +4,9 @@ import Control.Monad.State import Data.IORef import Data.Typeable+import Text.Parsec (SourcePos) +import Atomo.Lexer.Base (TaggedToken) import qualified Atomo.Types as AT data Title =@@ -19,6 +21,8 @@ = None | TOC | Unnumbered+ | Annotated+ | Class String | Styles [Style] deriving (Eq, Show, Typeable) @@ -75,11 +79,47 @@ | Branch String String [TOCTree] deriving Show +data AToken+ = ATokChunk String+ | ATokKeyword [String] [TaggedAToken]+ | ATokSingle String+ | ATokAtomo [TaggedToken]+ | ATokNested [TaggedAToken]+ | ATokDefinition [TaggedToken] [[TaggedToken]] [TaggedToken]+ deriving Show++data TaggedAToken =+ TaggedAToken+ { taToken :: AToken+ , taLocation :: SourcePos+ }+ deriving Show++styleToClass :: Style -> String+styleToClass (Class s) = s+styleToClass TOC = "table-of-contents"+styleToClass Unnumbered = "unnumbered"+styleToClass Annotated = "annotated"+styleToClass None = "normal"+styleToClass (Styles ss) = unwords (map styleToClass ss)++addStyle :: Style -> Style -> Style+addStyle a None = a+addStyle (Styles a) (Styles b) = Styles (a ++ b)+addStyle a (Styles b) = Styles (a:b)+addStyle (Styles a) b = Styles (a ++ [b])+addStyle a b = Styles [a, b]++styleMatch :: Style -> Style -> Bool+styleMatch a b | a == b = True+styleMatch a (Styles b) = any (styleMatch a) b+styleMatch _ _ = False+ defKey :: Definition -> BindingKey defKey d = case defThumb d of- AT.Dispatch { AT.eMessage = AT.Keyword { AT.mNames = ns } } -> KeywordKey ns- AT.Dispatch { AT.eMessage = AT.Single { AT.mName = n } } -> SingleKey n+ AT.EDispatch { AT.eMessage = AT.Keyword { AT.mNames = ns } } -> KeywordKey ns+ AT.EDispatch { AT.eMessage = AT.Single { AT.mName = n } } -> SingleKey n _ -> error $ "no defKey for: " ++ show (defThumb d) bindingID :: BindingKey -> String