packages feed

anatomy (empty) → 0.3

raw patch · 16 files changed

+1743/−0 lines, 16 filesdep +atomodep +basedep +containerssetup-changed

Dependencies added: atomo, base, containers, directory, filepath, hashable, haskeline, mtl, parsec, pretty, pretty-show, tagsoup, time, vector

Files

+ COPYING view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ anatomy.cabal view
@@ -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
+ lib/anatomy.css view
@@ -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;+}
+ lib/core.atomo view
@@ -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) :=+  ("<em>Example:</em>" .. (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) :=+  ("<em>Example:</em>" .. (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"+      }++      [ "&gt;" type: "caret"+        " "+        a pretty: e+        "\n"+        output contents+        res+        "\n"+      ] join+    }) join++    log in-tag: "pre class=\"interaction\""+  } call
+ lib/pretty.atomo view
@@ -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. <expression 1 + 1> 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 "<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: (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 .. "\"")+  }+
+ lib/util.atomo view
@@ -0,0 +1,22 @@+(e: Expression) in-tag: t := (evaluate: e) (as: String) in-tag: t+(s: String) in-tag: t := "<" .. t .. ">" .. s .. "</" .. t words head .. ">"++(s: String) operator? :=+  s head in?: "~!@#$%^&*-_=+./\\|<>?:"++(s: String) type: (c: String) :=+  s in-tag: ("span class=\"" .. c .. "\"")++(s: String) escape :=+  s match: {+    "" -> ""+    $< . ss -> "&lt;" .. ss escape+    $> . ss -> "&gt;" .. ss escape+    $& . ss -> "&amp;" .. ss escape+    s . ss -> s . ss escape+  }++(s: String) keywordfy :=+  if: s operator?+    then: { s }+    else: { s .. ":" }
+ src/Anatomy/Atomo.hs view
@@ -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 $ "<a href=\"" ++ url ++ "\">" ++ name ++ "</a>")
+ src/Anatomy/Atomo.hs-boot view
@@ -0,0 +1,5 @@+module Anatomy.Atomo where++import Atomo.Types++load :: VM ()
+ src/Anatomy/AutoFlow.hs view
@@ -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 <p>; carry on+        | isPhrasing n && open = o : autoFlow' open ts++        -- 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)++        -- a block that can contain <p>+        | isFlowable n = o : autoFlow' False tagContents ++ [TagClose n] ++ autoFlow' False rest++        -- not <p>-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 <p>+        | 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
+ src/Anatomy/Builder.hs view
@@ -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 $+            [ "<div class=\"section\">"+            , "  " ++ concat+                [ "<" ++ header ++ " class=\"section-header\" id=\"section_"+                    ++ sanitize u ++ "\">"+                , t+                , "</" ++ header ++ ">"+                ]+            , "  " ++ concat b+            , "</div>"+            ]+build TableOfContents =+    liftM printTOC (get >>= buildTOC)+build FullTableOfContents =+    liftM printFullTOC (get >>= buildTOC)+build (InlineDefinition d b) = do+    a <- getAObject++    thumb <- liftM (fromText . fromString) . lift $+        dispatch (keyword ["pretty"] [a, Expression (defThumb d)])++    pr <- liftM (fromText . fromString) . lift $+        dispatch (keyword ["pretty"] [a, Expression (defReturn d)])++    pcs <- lift $ mapM (\c -> liftM (fromText . fromString) $+        dispatch (keyword ["pretty"] [a, Expression c])) (defContracts d)++    body <- maybe (return "") (fmap (++ "\n\n") . build) b+    return . unlines $+        [ "<div class=\"definition\" id=\"" ++ bindingID (defKey d) ++ "\">"+        , "  <pre class=\"thumb\">" ++ concat+            [ thumb+            , " <span class=\"definition-result-arrow\">&rarr;</span> "+            , pr+            , concatMap ("\n  | " ++) pcs+            ] ++ "</pre>"+        , body+        , ""+        , "</div>"+        ]++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 ->+            "<ol class=\"toc\">" ++ concatMap printTOC' ss ++ "</ol>"+        _ ->+            "<ol class=\"toc\">" ++ printTOC' t ++ "</ol>"++printFullTOC :: TOCTree -> String+printFullTOC t = "<ol class=\"toc\">" ++ printTOC' t ++ "</ol>"++printTOC' :: TOCTree -> String+printTOC' (Node u n) =+    "<li><a href=\"" ++ u ++ "\">" ++ n ++ "</a></li>"+printTOC' (Branch u n ss) =+    "<li><a href=\"" ++ u ++ "\">" ++ n ++ "</a><ol>"+        ++ concatMap printTOC' ss ++ "</ol></li>"++buildFile :: FilePath -> FilePath -> IO ()+buildFile fn o = do+    css <- getDataFileName "lib/anatomy.css" >>= readFile+    writeFile (o </> "anatomy.css") css++    path <- fmap takeDirectory $ canonicalizePath fn++    exec $ do+        A.load++        ast <- parseFile fn++        start <- scan 0 1 path ast++        liftIO (putStrLn "scanned document")++        runAVM' (buildDocument o) start++        return (particle "ok")++buildDocument :: FilePath -> AVM Value+buildDocument o = do+    liftIO (putStrLn ("building document to: " ++ o))++    s <- get++    liftIO . print . titleText $ sectionTitle s++    when (sectionStyle s == TOC) $ do+        liftIO (putStrLn "building subsections first for table of contents")+        mapM_ (runAVM (buildDocument o)) (subSections s)++    liftIO (putStrLn "building table of contents")+    toc <- build TableOfContents++    liftIO (putStrLn "building title")+    title <- build . titleText . sectionTitle $ s++    liftIO (putStrLn "building body")+    body <- fmap concat $ mapM build (sectionBody s)++    liftIO (putStrLn "getting parent")+    parent <-+        case sectionParent s of+            Nothing -> return Nothing+            Just p ->+                liftM Just $ liftIO (readIORef p)+                    >>= runAVM (build FullTableOfContents)++    liftIO (putStr "writing document to...")+    fn <- sectionURL s+    liftIO (putStrLn fn)++    liftIO . writeFile (o </> fn) $+        format toc title body parent++    return (particle "done")+  where+    format toc t b mp = unlines+        [ "<!DOCTYPE html>"+        , "<html>"+        , "  <head>"+        , "    <meta http-equiv=\"content-type\" content=\"text/html; charset=utf-8\" />"+        , "    <title>" ++ stripTags t ++ "</title>"+        , "    <link rel=\"stylesheet\" type=\"text/css\" href=\"anatomy.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>"+        , "    <div id=\"content\">"+        , "      <h1>" ++ t ++ "</h1>"+        , autoFlow b+        , "    </div>"+        , "  </body>"+        , "</html>"+        ]++getAObject :: AVM Value+getAObject = do+    s <- get++    lift $ defineOn (sectionA s)+        (Slot (single "state" PThis) (Haskell (toDyn s)))++    return (sectionA s)++findSection :: String -> Section -> AVM (Maybe Section)+findSection n s = do+    tag <-+        case titleTag (sectionTitle s) of+            Nothing -> return Nothing+            Just t -> fmap Just $ buildForString' t+    title <- build (titleText (sectionTitle s))+    if n == title || Just n == tag+        then return (Just s)+        else do++    kids <- findFirstSection n (subSections s)+    case (kids, sectionParent s) of+        (Just k, _) -> return (Just k)+        (Nothing, Nothing) -> return Nothing+        (Nothing, Just pr) -> do+            p <- liftIO (readIORef pr)+            findSection n p++findSectionDownward :: String -> Section -> AVM (Maybe Section)+findSectionDownward n s = do+    tag <-+        case titleTag (sectionTitle s) of+            Nothing -> return Nothing+            Just t -> fmap Just $ buildForString' t++    title <- build (titleText (sectionTitle s))+    if n == title || Just n == tag+        then return (Just s)+        else findFirstSection n (subSections s)++findFirstSection :: String -> [Section] -> AVM (Maybe Section)+findFirstSection _ [] = return Nothing+findFirstSection k (s:ss) = do+    f <- findSectionDownward k s+    maybe (findFirstSection k ss) (return . Just) f++findBinding :: BindingKey -> Section -> AVM (Maybe String)+findBinding k s =+    if k `elem` sectionBindings s+        then fmap Just (bindingURL s k)+        else do++    kids <- findFirstBinding k (subSections s)+    case (kids, sectionParent s) of+        (Just b, _) -> return (Just b)+        (Nothing, Nothing) -> return Nothing+        (Nothing, Just pr) -> do+            p <- liftIO (readIORef pr)+            findBinding k p++findBindingDownward :: BindingKey -> Section -> AVM (Maybe String)+findBindingDownward k s =+    if k `elem` sectionBindings s+        then fmap Just (bindingURL s k)+        else findFirstBinding k (subSections s)++findFirstBinding :: BindingKey -> [Section] -> AVM (Maybe String)+findFirstBinding _ [] = return Nothing+findFirstBinding k (s:ss) = do+    f <- findBindingDownward k s+    maybe (findFirstBinding k ss) (return . Just) f++bindingURL :: Section -> BindingKey -> AVM String+bindingURL s k =+    sectionURL s+        >>= \u -> return $ trimFragment u ++ "#" ++ bindingID k++sectionURL :: Section -> AVM String+sectionURL s@(Section { sectionParent = Nothing }) =+    pageURL s+sectionURL s@(Section { sectionParent = Just sr }) = do+    p <- liftIO (readIORef sr)+    if sectionStyle p == TOC+        then pageURL s+        else do+            st <- buildForString' (tagOrTitle s)+            purl <- sectionURL p+            return (trimFragment purl ++ "#section_" ++ sanitize st)++pageURL :: Section -> AVM String+pageURL s = fmap ((<.> "html") . sanitize) (buildForString' (tagOrTitle s))++tagOrTitle :: Section -> Segment+tagOrTitle (Section { sectionTitle = Title { titleTag = Just t } }) =+    t+tagOrTitle s = titleText (sectionTitle s)++sanitize :: String -> String+sanitize "" = ""+sanitize (' ':ss) = '_' : sanitize ss+sanitize ('.':ss) = ".." ++ sanitize ss+sanitize ('<':ss) = sanitize (tail $ dropWhile (/= '>') ss)+sanitize (s:ss)+    | isUpper s = '.' : s : sanitize ss+    | isAlphaNum s || s `elem` "_-" = s : sanitize ss+    | otherwise = '_' : sanitize ss++buildForString' :: Segment -> AVM String+buildForString' (Atomo e) = lift (liftM (fromText . fromString) (macroExpand e >>= eval))+buildForString' x = build x++trimFragment :: String -> String+trimFragment = takeWhile (/= '#')++stripTags :: String -> String+stripTags = innerText . parseTags
+ src/Anatomy/Debug.hs view
@@ -0,0 +1,21 @@+module Anatomy.Debug where++import Debug.Trace+import Text.Show.Pretty+++debugging :: Bool+debugging = False++debug :: (Show a, Show b) => b -> a -> a+debug s v+    | debugging = trace (prettyShow s ++ ": " ++ prettyShow v) v+    | otherwise = v++dump :: (Monad m, Show a) => a -> m ()+dump x+    | debugging = trace (prettyShow x) (return ())+    | otherwise = return ()++prettyShow :: Show a => a -> String+prettyShow = ppShow
+ src/Anatomy/Parser.hs view
@@ -0,0 +1,181 @@+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.Parser.Expand+import Atomo.Parser.Expr hiding (parser)+import qualified Atomo.Types as AT+import qualified Atomo.Parser.Base as AB++import Anatomy.Debug+import Anatomy.Types+++special :: Char+special = '#'++nested :: Parser [Segment]+nested = do+    ps <- getState+    pos <- getPosition+    block <- balancedBetween '{' '}'+    res <- lift $ runParserT parser ps (show pos) (cleanup block)+    case res of+        Left e -> fail ("nested: " ++ show e)+        Right ok -> return ok+  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++                let punct = reverse . takeWhile AB.isOpLetter . reverse $ ident+                    sane = reverse . dropWhile AB.isOpLetter . reverse $ ident++                getInput >>= setInput . (punct ++)++                return . Atomo . AT.Dispatch Nothing $ AT.single sane (AT.ETop Nothing)+            ]+        dump ("got value", val)+        return (name, val)++    let (ns, vs) = unzip ks++    return (KeywordDispatch ns vs)++single :: Parser Segment+single = fmap (debug "single") $ do+    char special+    name <- AB.identifier+    notFollowedBy (char ':')+    dump ("got single identifier", name)+    return (SingleDispatch name)++atomo :: Parser Segment+atomo = fmap (debug "atomo") $ do+    char special+    fmap Atomo (between (char '(') (char ')') pExpr)++parser :: Parser [Segment]+parser = do+    ss <- many $ choice+        [ try keyword+        , try single+        , try atomo+        , chunk+        ]+    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) =+  liftM Nested (mapM expandSegment ss)+expandSegment (InlineDefinition d (Just s)) =+  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++parseDefinition :: String -> AT.VM Definition+parseDefinition = continue+    (do { r <- defParser; eof; return r })+    "<definition>"+
+ src/Anatomy/Scanner.hs view
@@ -0,0 +1,123 @@+module Anatomy.Scanner where++import Control.Monad.State+import Data.IORef+import System.Directory+import System.FilePath++import Anatomy.Parser+import Anatomy.Types++import Atomo.Environment+import Atomo.Helpers+import Atomo.Types+import Atomo.Parser.Expand (macroExpand)+++-- scan through everything and build up the initial state for generation+scan :: Int -> Int -> FilePath -> [Segment] -> VM Section+scan depth num path ss' = do+    a <- here "A" >>= dispatch . single "clone"+    env <- here "Lobby" >>= dispatch . single "clone"+    defineOn a (Slot (single "environment" PThis) env)++    sec <- liftIO . newSection $ \s -> s+        { sectionDepth = depth+        , sectionNumber = num+        , sectionPath = path+        , sectionA = a+        }++    st <- scan' sec ss'+    liftIO (writeIORef (sectionID st) st)+    return st+  where+    scan' acc [] = return acc+    scan' acc (KeywordDispatch ["title"] [s]:ss) =+        scan' (acc { sectionTitle = Title s Nothing Nothing }) ss+    scan' acc (KeywordDispatch ["title", "tag"] [s, t]:ss) =+        scan' (acc { sectionTitle = Title s (Just t) Nothing }) ss+    scan' acc (KeywordDispatch ["title", "tag", "version"] [s, t, v]:ss) =+        scan' (acc { sectionTitle = Title s (Just t) (Just v) }) ss+    scan' acc (KeywordDispatch ["include-section"] [sfn]:ss) = do+        cfn <- buildForString sfn+        fn <- findFile [sectionPath acc, ""] cfn+        liftIO (putStrLn ("including section: " ++ fn))++        ast <- parseFile fn+        sec <- fmap (\s -> s { sectionParent = Just (sectionID acc) }) $+            scan (depth + 1) (length (subSections acc) + 1) (takeDirectory fn) ast++        liftIO (writeIORef (sectionID sec) sec)++        scan' (acc+            { sectionBody = sectionBody acc +++                [SectionReference (length (subSections acc))]+            , subSections = subSections acc ++ [sec]+            }) ss+      where+        findFile [] fn = throwError (FileNotFound fn)+        findFile (p:ps) fn = do+            check <- liftIO . doesFileExist $ p </> fn++            if check+                then liftIO (canonicalizePath (p </> fn))+                else findFile ps fn++    scan' acc (KeywordDispatch ["section", "tag"] [s, t]:ss) = do+        subsection acc s (Just t) ss+    scan' acc (KeywordDispatch ["section"] [s]:ss) =+        subsection acc s Nothing ss+    scan' acc (KeywordDispatch ["define"] [sb]:ss) = do+        body <- buildForString sb++        def <- parseDefinition body+        scan' (acc+            { sectionBody = sectionBody acc ++ [InlineDefinition def Nothing]+            , sectionBindings = defKey def : sectionBindings acc+            }) ss+    scan' acc (KeywordDispatch ["define", "body"] [sd, sb]:ss) = do+        body <- buildForString sd+        def <- parseDefinition body+        scan' (acc+            { sectionBody = sectionBody acc ++ [InlineDefinition def (Just sb)]+            , sectionBindings = defKey def : sectionBindings acc+            }) ss+    scan' acc (SingleDispatch "table-of-contents":ss) = do+        liftIO (putStrLn "table of contents")++        scan' (acc+            { sectionStyle = TOC+            , sectionBody = sectionBody acc ++ [TableOfContents]+            }) ss+    scan' acc (s:ss) =+        scan' (acc { sectionBody = sectionBody acc ++ [s] }) ss++    subsection acc s t ss = do+        liftIO (putStrLn ("subsection: " ++ show s))++        sec <- fmap (\sec -> sec+            { sectionTitle = Title s t Nothing+            , sectionParent = Just (sectionID acc)+            }) $ scan (depth + 1) (length (subSections acc) + 1) "" sb++        liftIO (writeIORef (sectionID sec) sec)++        scan' (acc+            { sectionBody = sectionBody acc +++                [SectionReference (length (subSections acc))]+            , subSections = subSections acc ++ [sec]+            }) rest+      where+        (sb, rest) = span (\sec ->+            case sec of+                KeywordDispatch ["section"] _ -> False+                KeywordDispatch ["section", "tag"] _ -> False+                _ -> True) ss+++buildForString :: Segment -> VM String+buildForString (Atomo e) = liftM (fromText . fromString) (macroExpand e >>= eval)+buildForString (Chunk s) = return s -- TODO: escaping+buildForString (Nested ns) = fmap concat (mapM buildForString ns)+buildForString x = error $ "cannot be built into a string: " ++ show x
+ src/Anatomy/Types.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE DeriveDataTypeable, TypeSynonymInstances #-}+module Anatomy.Types where++import Control.Monad.State+import Data.IORef+import Data.Typeable++import qualified Atomo.Types as AT++data Title =+    Title+        { titleText :: Segment+        , titleTag :: Maybe Segment+        , titleVersion :: Maybe Segment+        }+    deriving (Show, Typeable)++data Style+    = None+    | TOC+    | Unnumbered+    | Styles [Style]+    deriving (Eq, Show, Typeable)++data BindingKey+    = KeywordKey [String]+    | SingleKey String+    deriving (Eq, Ord, Show, Typeable)++data Definition =+    Definition+        { defThumb :: AT.Expr+        , defContracts :: [AT.Expr]+        , defReturn :: AT.Expr+        }+    deriving Show++data Section =+    Section+        { sectionID :: SectionRef+        , sectionTitle :: Title+        , sectionStyle :: Style    -- style flags (e.g. TOC)+        , sectionBody :: [Segment] -- un-built content with parts from step 1 removed+        , sectionBindings :: [BindingKey]+        , sectionParent :: Maybe SectionRef+        , subSections :: [Section] -- included sections+        , sectionDepth :: Int+        , sectionNumber :: Int+        , sectionPath :: FilePath+        , sectionA :: AT.Value+        }+    deriving (Show, Typeable)++type SectionRef = IORef Section++instance Show SectionRef where+    show _ = "SectionRef"++type AVM = StateT Section AT.VM++data Segment+    = Chunk String+    | KeywordDispatch [String] [Segment]+    | SingleDispatch String+    | Atomo AT.Expr+    | Nested [Segment]+    | SectionReference Int+    | TableOfContents+    | FullTableOfContents+    | InlineDefinition Definition (Maybe Segment)+    deriving Show++data TOCTree+    = Node String String+    | Branch String String [TOCTree]+    deriving Show++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+        _ -> error $ "no defKey for: " ++ show (defThumb d)++bindingID :: BindingKey -> String+bindingID (KeywordKey ns) = "definition_" ++ concatMap (++ ":") ns+bindingID (SingleKey n) = "definition_" ++ n++runAVM :: AVM a -> Section -> AVM a+runAVM a s = lift (evalStateT a s)++runAVM' :: AVM a -> Section -> AT.VM a+runAVM' = evalStateT++newSection :: (Section -> Section) -> IO Section+newSection f = do+    r <- newIORef undefined+    writeIORef r (sec r)+    return (sec r)+  where+    sec r = f Section+        { sectionID = r+        , sectionTitle = Title (Chunk "Untitled") Nothing Nothing+        , sectionStyle = None+        , sectionBody = []+        , sectionBindings = []+        , sectionParent = Nothing+        , subSections = []+        , sectionDepth = 0+        , sectionNumber = 1+        , sectionPath = ""+        , sectionA = error "no section anatomy"+        }++
+ src/Main.hs view
@@ -0,0 +1,19 @@+module Main where++import System.Environment (getArgs)++import Anatomy.Builder+++main :: IO ()+main = do+    args <- getArgs++    case args of+        [fn, "-o", out] -> buildFile fn out+        [fn] -> buildFile fn "."+        _ -> putStrLn . unlines $+            [ "usage:"+            , "anatomy FILENAME\t\tbuild FILENAME, outputting documents to ."+            , "anatomy FILENAME -o DIRNAME\tbuild FILENAME, outputting documents to DIRNAME"+            ]