diff --git a/COPYING b/COPYING
new file mode 100644
--- /dev/null
+++ b/COPYING
@@ -0,0 +1,30 @@
+Copyright (c)2010, Alex Suraci
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Alex Suraci nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/anatomy.cabal b/anatomy.cabal
new file mode 100644
--- /dev/null
+++ b/anatomy.cabal
@@ -0,0 +1,74 @@
+name: anatomy
+version: 0.3
+synopsis: Anatomy: Atomo documentation system
+description: A Scribble-like documentation language/builder for Atomo.
+homepage: http://atomo-lang.org/
+license: BSD3
+license-file: COPYING
+author: Alex Suraci
+maintainer: i.am@toogeneric.com
+category: Development
+build-type: Simple
+
+cabal-version: >= 1.6
+
+data-files: lib/anatomy.css
+ lib/*.atomo
+
+source-repository head
+ type: hg
+ location: http://bitbucket.org/alex/anatomy
+
+library
+ hs-source-dirs: src
+
+ build-depends:
+ base >= 4 && < 5,
+ atomo >= 0.3,
+ containers,
+ directory,
+ filepath,
+ hashable,
+ haskeline,
+ mtl,
+ parsec >= 3.0.0,
+ pretty,
+ pretty-show,
+ tagsoup,
+ time,
+ vector
+
+ exposed-modules:
+ Anatomy.Atomo,
+ Anatomy.AutoFlow,
+ Anatomy.Builder,
+ Anatomy.Parser,
+ Anatomy.Scanner,
+ Anatomy.Types
+
+ other-modules:
+ Anatomy.Debug,
+ Paths_anatomy
+
+executable anatomy
+ hs-source-dirs: src
+ main-is: Main.hs
+
+ ghc-prof-options: -prof -auto-all -caf-all
+ ghc-options: -Wall -threaded -fno-warn-unused-do-bind
+
+ build-depends:
+ atomo >= 0.3,
+ base >= 4,
+ containers,
+ directory,
+ filepath,
+ hashable,
+ haskeline,
+ mtl,
+ parsec >= 3.0.0,
+ pretty,
+ pretty-show,
+ tagsoup,
+ time,
+ vector
diff --git a/lib/anatomy.css b/lib/anatomy.css
new file mode 100644
--- /dev/null
+++ b/lib/anatomy.css
@@ -0,0 +1,195 @@
+body,div,dl,dt,dd,ul,ol,li,h1,h2,h3,h4,h5,h6,pre,code,form,fieldset,legend,input,textarea,p,blockquote,th,td { margin: 0; padding: 0; }
+table { border-collapse: collapse; border-spacing: 0; }
+fieldset,img { border: 0; }
+address,caption,cite,code,dfn,em,strong,th,var { font-style: normal; font-weight: normal; }
+li { list-style: none; }
+caption,th { text-align: left; }
+h1,h2,h3,h4,h5,h6 { font-size: 100%; font-weight: normal; }
+abbr,acronym { border: 0; font-variant: normal; }
+input,textarea,select { font-family: inherit; font-size: inherit; font-weight: inherit; }
+a { text-decoration: none; color: inherit; }
+
+html {
+ font-size: 62.5%;
+ height: 100%;
+ background-color: #fff;
+ color: #000;
+}
+
+body {
+ font: normal 1.4em/1.6em 'Palatino Linotype', 'Book Antiqua', Palatino, Georgia, serif;
+}
+
+pre, code {
+ font-size: 1.1em;
+}
+
+a:link {
+ text-decoration: underline;
+ color: blue;
+}
+a:visited {
+ color: purple;
+}
+
+ol {
+ margin-left: 2em;
+}
+ol li {
+ list-style: decimal;
+}
+
+strong { font-weight: bold }
+em { font-style: italic }
+
+h1 {
+ line-height: 1.4em;
+ font-size: 2em;
+ margin-bottom: .5em;
+}
+h2 {
+ font-size: 1.75em;
+ margin-bottom: .5em;
+}
+
+p {
+ padding-bottom: 1em;
+}
+
+dd {
+ margin: 0 0 1em 2em;
+}
+
+#sidebar {
+ background: #f0f0f0;
+ padding: 1em;
+ width: 16em;
+ height: 100%;
+ overflow: auto;
+ position: fixed;
+ right: 0;
+ top: 0;
+ bottom: 0;
+}
+#sidebar h4 {
+ font-style: italic;
+}
+#sidebar .toc {
+ margin-bottom: 2em;
+}
+
+#content {
+ padding: 2em;
+ position: absolute;
+ left: 0;
+ right: 18em;
+ top: 0;
+ bottom: 0;
+}
+
+.section {
+ margin: 1em 0;
+ padding: 1em 0;
+ border-bottom: .1em dotted #000;
+}
+
+.definition {
+ margin: 1em 0;
+ padding: 2em 0 0;
+ border-top: .1em dotted #ddd;
+}
+.definition pre.thumb {
+ background: #f5f5f5;
+ padding: .6em .75em;
+ margin-bottom: 1em;
+}
+
+.verbatim, .interaction {
+ margin: 0 1em 1em;
+}
+
+pre a:link,
+pre a:visited {
+ color: #000;
+ text-decoration: none;
+ border-bottom: .1em solid #ddd;
+ font-weight: bold;
+}
+pre a:hover {
+ border-bottom-color: #333;
+}
+
+.interaction .error:before {
+ content: "error: ";
+}
+.interaction .error {
+ font-style: italic;
+ color: red;
+}
+.interaction .caret {
+ font-weight: bold;
+ 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;
+}
+.char {
+ color: #D20086;
+ font-weight: bold;
+}
+.double {
+ color: #A640D2;
+ font-weight: bold;
+}
+.rational {
+ color: #26C052;
+ font-weight: bold;
+}
+.particle {
+ color: #56B200;
+ 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;
+}
+pre .dispatch.single > a {
+ color: #000;
+ font-weight: bold;
+}
+
+.error-output {
+ display: block;
+ font-style: italic;
+ background: #fee;
+ color: #a33;
+}
diff --git a/lib/core.atomo b/lib/core.atomo
new file mode 100644
--- /dev/null
+++ b/lib/core.atomo
@@ -0,0 +1,108 @@
+require: "pretty.atomo"
+require: "util.atomo"
+
+(a: A) evaluate: (e: Expression) :=
+ a environment evaluate: e
+
+-- various semantic helpers
+A bold: s := s in-tag: "strong"
+A italic: s := s in-tag: "em"
+A code: (s: String) := s escape in-tag: "code"
+A list: s := s in-tag: "ul"
+A numbered-list: s := s in-tag: "ol"
+A item: s := s in-tag: "li"
+A definitions: s := s in-tag: "dl"
+A item: s is: v := (s in-tag: "dt") .. (v in-tag: "dd")
+A verbatim: (s: String) :=
+ s escape in-tag: "pre class=\"verbatim\""
+
+-- 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
+A link: (name: String) to: (url: String) :=
+ 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\""
+
+-- 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\""
+
+-- example code (unevaluated)
+(a: A) example-segment: (e: Expression) :=
+ ("Example:" .. (a atomo-segment: e))
+ 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) :=
+ ("Example:" .. (a interaction: e))
+ 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 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
+
+ log = b contents (map: { e |
+ output = String-Port new do: {
+ display: s :=
+ { output contents = output contents .. s (as: String) escape
+ s
+ } call
+ }
+
+ 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")
+ s
+ } call
+ }
+
+ res = {
+ with: [
+ value-output? -> True
+ *error-output* -> error
+ ] do: {
+ with-output-to: output do: {
+ a pretty: (env evaluate: e expand)
+ }
+ }
+ } catch: { e |
+ (a pretty: e) type: "error"
+ }
+
+ [ ">" type: "caret"
+ " "
+ a pretty: e
+ "\n"
+ output contents
+ res
+ "\n"
+ ] join
+ }) join
+
+ log in-tag: "pre class=\"interaction\""
+ } call
diff --git a/lib/pretty.atomo b/lib/pretty.atomo
new file mode 100644
--- /dev/null
+++ b/lib/pretty.atomo
@@ -0,0 +1,332 @@
+-- root URL for links
+define: docs-root as: ""
+
+-- current pretty-printer indentation level
+define: indent-level as: 0
+
+-- allow multiline pretty-printing
+define: multiline-pretty? as: False
+
+-- context for a pretty-print
+define: context as: @top
+
+-- output as values? (i.e. instead of 1 + 1)
+define: value-output? as: False
+
+
+-- indent s up to the current indentation level
+indented: (s: String) :=
+ ($ repeat: (indent-level * 2)) .. s
+
+-- an empty line, followed by (indentation - 1) indentation
+unindent :=
+ "\n" .. ($ repeat: ((indent-level - 1) * 2))
+
+
+-- 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 "" normally
+A pretty: (p: Pattern) :=
+ if: value-output?
+ then: { p show escape type: "internal" }
+ else: {
+ p show (drop: " " 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: (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"
+ }
+ 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"
+ }
+
+
+-- 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: {
+ @none -> t escape
+ @(ok: u) ->
+ t escape in-tag: ("a href=\"" .. docs-root .. u .. "\"")
+ }
+
diff --git a/lib/util.atomo b/lib/util.atomo
new file mode 100644
--- /dev/null
+++ b/lib/util.atomo
@@ -0,0 +1,22 @@
+(e: Expression) in-tag: t := (evaluate: e) (as: String) in-tag: t
+(s: String) in-tag: t := "<" .. t .. ">" .. s .. ""
+
+(s: String) operator? :=
+ s head in?: "~!@#$%^&*-_=+./\\|<>?:"
+
+(s: String) type: (c: String) :=
+ s in-tag: ("span class=\"" .. c .. "\"")
+
+(s: String) escape :=
+ s match: {
+ "" -> ""
+ $< . ss -> "<" .. ss escape
+ $> . ss -> ">" .. ss escape
+ $& . ss -> "&" .. ss escape
+ s . ss -> s . ss escape
+ }
+
+(s: String) keywordfy :=
+ if: s operator?
+ then: { s }
+ else: { s .. ":" }
diff --git a/src/Anatomy/Atomo.hs b/src/Anatomy/Atomo.hs
new file mode 100644
--- /dev/null
+++ b/src/Anatomy/Atomo.hs
@@ -0,0 +1,79 @@
+{-# LANGUAGE QuasiQuotes #-}
+module Anatomy.Atomo where
+
+import Data.Dynamic
+import System.Directory
+import System.FilePath
+
+import Atomo
+import Atomo.Load
+
+import Anatomy.Builder
+import Anatomy.Parser
+import Anatomy.Scanner
+import Anatomy.Types
+
+import Paths_anatomy
+
+
+load :: VM ()
+load = do
+ ([$p|A|] =::) =<< eval [$e|Object clone|]
+
+ liftIO (getDataFileName "lib/core.atomo") >>= loadFile
+
+ [$p|(a: A) new: (fn: String)|] =: do
+ fn <- getString [$e|fn|]
+
+ path <- fmap takeDirectory . liftIO $ canonicalizePath fn
+
+ liftIO (putStrLn ("path: " ++ path))
+ ast <- parseFile fn
+ sec <- scan 0 1 path ast
+ [$p|a state|] =:: Haskell (toDyn sec)
+ here "a"
+
+ [$p|(a: A) url-for: (e: Expression)|] =: do
+ Expression ae <- here "e" >>= findExpression
+ Haskell a <- eval [$e|a state|]
+
+ let st = fromDyn a (error "hotlink A is invalid") :: Section
+
+ find <-
+ case ae of
+ Dispatch { eMessage = Single { mName = n } } ->
+ runAVM' (findBinding (SingleKey n) st) st
+ Dispatch { eMessage = Keyword { mNames = ns } } ->
+ runAVM' (findBinding (KeywordKey ns) st) st
+
+ EParticle { eParticle = PMSingle n } ->
+ runAVM' (findBinding (SingleKey n) st) st
+ EParticle { eParticle = PMKeyword ns _ } ->
+ runAVM' (findBinding (KeywordKey ns) st) st
+
+ Primitive { eValue = Particle (PMSingle n) } ->
+ runAVM' (findBinding (SingleKey n) st) st
+ Primitive { eValue = Particle (PMKeyword ns _) } ->
+ runAVM' (findBinding (KeywordKey ns) st) st
+
+ _ -> raise ["no-url-for"] [Expression ae]
+
+ case find of
+ Nothing -> return (particle "none")
+ Just u ->
+ return (keyParticle ["ok"] [Nothing, Just (string u)])
+
+ [$p|(a: A) reference: (s: String)|] =: do
+ n <- getString [$e|s|]
+ Haskell a <- eval [$e|a state|]
+
+ let st = fromDyn a (error "hotlink A is invalid") :: Section
+
+ flip runAVM' st $ do
+ ms <- findSection n st
+ case ms of
+ Nothing -> return (string n)
+ Just s -> do
+ url <- sectionURL s
+ name <- buildForString' (titleText (sectionTitle s))
+ return (string $ "" ++ name ++ "")
diff --git a/src/Anatomy/Atomo.hs-boot b/src/Anatomy/Atomo.hs-boot
new file mode 100644
--- /dev/null
+++ b/src/Anatomy/Atomo.hs-boot
@@ -0,0 +1,5 @@
+module Anatomy.Atomo where
+
+import Atomo.Types
+
+load :: VM ()
diff --git a/src/Anatomy/AutoFlow.hs b/src/Anatomy/AutoFlow.hs
new file mode 100644
--- /dev/null
+++ b/src/Anatomy/AutoFlow.hs
@@ -0,0 +1,96 @@
+module Anatomy.AutoFlow where
+
+import Data.Char (isSpace)
+import Text.HTML.TagSoup
+
+autoFlow :: String -> String
+autoFlow = renderTags . autoFlow' False . canonicalizeTags . parseTags
+ where
+ autoFlow' open []
+ | open = [TagClose "p"]
+ | otherwise = []
+ autoFlow' open (o@(TagOpen n _):ts)
+ -- inline element, already in a
; carry on
+ | isPhrasing n && open = o : autoFlow' open ts
+
+ -- inline element, not in a
; start a
+ | isPhrasing n = TagOpen "p" [] : o : autoFlow' True ts
+
+ -- opening a block element;
+ | open = TagClose "p" : autoFlow' False (o:ts)
+
+ -- a block that can contain
+ | isFlowable n = o : autoFlow' False tagContents ++ [TagClose n] ++ autoFlow' False rest
+
+ -- not
-able; leave it alone
+ | otherwise = o : tagContents ++ [TagClose n] ++ autoFlow' False rest
+ where
+ tagContents = getTagContent n (o:ts)
+ rest = drop (length tagContents + 1) ts
+ autoFlow' open (t@(TagText c):ts)
+ -- skip whitespace
+ | all isSpace c = t : autoFlow' open ts
+
+ -- a new paragraph, indicated by a linebreak
+ | open && head c == '\n' = TagClose "p" : autoFlow' False (t:ts)
+
+ -- a new paragraph, indicated by a linebreak
+ | head c == '\n' = TagOpen "p" [] : autoFlow' True (TagText (dropWhile (== '\n') c) : ts)
+
+ -- already open; carry on
+ | open = thisPara : autoFlow' True rest
+
+ -- text, pop it in a
+ | otherwise = TagOpen "p" [] : t : autoFlow' True ts
+ where
+ thisPara = TagText (takeWhile (/= '\n') c)
+ rest
+ | thisPara == t = ts
+ | otherwise = TagText (dropWhile (/= '\n') c) : ts
+ autoFlow' True (t@(TagClose n):ts)
+ | isBlock n =
+ TagClose "p" : t : autoFlow' False ts
+ autoFlow' open (t:ts) = t : autoFlow' open ts
+
+isPhrasing :: String -> Bool
+isPhrasing = flip elem . words $
+ "a abbr area audio b bdo br button canvas cite code command datelist del dfn em embed i iframe img input ins kbd keygen label link map mark math meta meter noscript object output progress q ruby samp script select small span strong sub sup svg textarea time var video wbr"
+
+-- 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"
+
+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"
+
+getTagContent :: String -> [Tag String] -> [Tag String]
+getTagContent n ts' = getTagContent' 0 [] ts'
+ where
+ getTagContent' :: Int -> [Tag String] -> [Tag String] -> [Tag String]
+ -- error: reached the end with an unclosed tag
+ getTagContent' _ _ [] = error $ "unmatched tag " ++ n ++ " in: " ++ show ts'
+
+ -- final closing tag
+ getTagContent' 1 acc (TagClose tn:_) | tn == n =
+ reverse acc
+
+ -- initial opening tag
+ getTagContent' 0 acc (TagOpen tn _:ts) | tn == n =
+ getTagContent' 1 acc ts
+
+ -- nested open tag
+ getTagContent' d acc (TagOpen tn as:ts) | tn == n =
+ getTagContent' (d + 1) (TagOpen tn as:acc) ts
+
+ -- nested close tag
+ getTagContent' d acc (TagClose tn:ts) | tn == n =
+ getTagContent' (d - 1) (TagClose tn:acc) ts
+
+ -- content
+ getTagContent' d acc (t:ts) =
+ getTagContent' d (t:acc) ts
diff --git a/src/Anatomy/Builder.hs b/src/Anatomy/Builder.hs
new file mode 100644
--- /dev/null
+++ b/src/Anatomy/Builder.hs
@@ -0,0 +1,341 @@
+module Anatomy.Builder where
+
+import Control.Monad.State
+import Data.Char
+import Data.Dynamic
+import Data.IORef
+import System.Directory
+import System.FilePath
+import Text.HTML.TagSoup
+
+import {-# SOURCE #-} qualified Anatomy.Atomo as A
+import Anatomy.AutoFlow
+import Anatomy.Parser
+import Anatomy.Scanner
+import Anatomy.Types
+
+import Atomo.Environment
+import Atomo.Run
+import Atomo.PrettyVM
+import Atomo.Types
+import Atomo.Parser.Expand (macroExpand)
+
+import Paths_anatomy
+
+
+build :: Segment -> AVM String
+build (Chunk s) = return s
+build (KeywordDispatch ns ss) = do
+ vs <- forM ss $ \s ->
+ case s of
+ Atomo e -> return (Expression e)
+ _ -> fmap string (build s)
+
+ a <- getAObject
+ liftM (fromText . fromString) $ lift (dispatch (keyword ns (a:vs)))
+build (SingleDispatch n) = do
+ s <- getAObject
+ res <- lift (dispatch (single n s))
+ 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
+build (Nested ss) = fmap concat $ mapM build ss
+build (SectionReference n) = do
+ style <- gets sectionStyle
+ if style == TOC
+ then return ""
+ else do
+
+ sec <- gets ((!! n) . subSections)
+ flip runAVM sec $ do
+ depth <- do
+ myd <- gets sectionDepth
+ mp <- gets sectionParent
+ case mp of
+ Nothing -> return myd
+ Just p -> do
+ pd <- fmap sectionDepth $ liftIO (readIORef p)
+ return (myd - pd)
+
+ u <- get >>= buildForString' . tagOrTitle
+ t <- gets (titleText . sectionTitle) >>= buildForString'
+ b <- mapM build (sectionBody sec)
+
+ let header = 'h' : show (depth + 1)
+ return . unlines $
+ [ "
"
+ ]
+
+buildTOC :: Section -> AVM TOCTree
+buildTOC s
+ | null (subSections s) = do
+ u <- sectionURL s
+ fmap (Node u) $ build (titleText (sectionTitle s))
+ | otherwise = do
+ t <- build (titleText (sectionTitle s))
+ u <- sectionURL s
+ ts <- mapM buildTOC (subSections s)
+ return (Branch u t ts)
+
+-- print a table of contents; skip the first node if it's
+-- a branch (since we should already be on that page)
+printTOC :: TOCTree -> String
+printTOC t =
+ case t of
+ Branch _ _ ss ->
+ "" ++ concatMap printTOC' ss ++ ""
+ _ ->
+ "" ++ printTOC' t ++ ""
+
+printFullTOC :: TOCTree -> String
+printFullTOC t = "" ++ printTOC' t ++ ""
+
+printTOC' :: TOCTree -> String
+printTOC' (Node u n) =
+ "