" 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 .. "\"")
}
-
diff --git a/src/Anatomy/Atomo.hs b/src/Anatomy/Atomo.hs
--- a/src/Anatomy/Atomo.hs
+++ b/src/Anatomy/Atomo.hs
@@ -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 $ "" ++ name ++ "")
+
+ [$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
diff --git a/src/Anatomy/AutoFlow.hs b/src/Anatomy/AutoFlow.hs
--- a/src/Anatomy/AutoFlow.hs
+++ b/src/Anatomy/AutoFlow.hs
@@ -15,7 +15,7 @@
-- 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)
@@ -41,7 +41,7 @@
| open = thisPara : autoFlow' True rest
-- text, pop it in a
- | 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'
diff --git a/src/Anatomy/Builder.hs b/src/Anatomy/Builder.hs
--- a/src/Anatomy/Builder.hs
+++ b/src/Anatomy/Builder.hs
@@ -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 $
[ ""
, ""
, "
"
, " "
- , " " ++ stripTags t ++ ""
+ , " " ++ stripTags title ++ ""
, " "
+ , " "
, " "
- , " "
- , " "
+ , " "
+
+ , if showTOC
+ then unlines
+ [ " "
+ ]
+ else ""
+
, " "
- , "
" ++ t ++ "
"
- , autoFlow b
+ , contentFor (sectionStyle s) title (autoFlow body)
, " "
, " "
, ""
]
+ return (particle "done")
+
+contentFor :: Style -> String -> String -> String
+contentFor s t b
+ | styleMatch Annotated s =
+ concat
+ [ ""
+ , "" ++ t ++ " | |
|---|
"
+ , b
+ , "
"
+ ]
+ | otherwise =
+ concat
+ [ "" ++ t ++ "
"
+ , 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)
diff --git a/src/Anatomy/Parser.hs b/src/Anatomy/Parser.hs
--- a/src/Anatomy/Parser.hs
+++ b/src/Anatomy/Parser.hs
@@ -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 })
""
-
diff --git a/src/Anatomy/Scanner.hs b/src/Anatomy/Scanner.hs
--- a/src/Anatomy/Scanner.hs
+++ b/src/Anatomy/Scanner.hs
@@ -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
diff --git a/src/Anatomy/Types.hs b/src/Anatomy/Types.hs
--- a/src/Anatomy/Types.hs
+++ b/src/Anatomy/Types.hs
@@ -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