"
]
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) =
"
"
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
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 (styleMatch TOC $ sectionStyle s) $ 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 $ 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 <-
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)
let showTOC = isJust parent || not (null (subSections s))
classes | showTOC = "with-sidebar " ++ styleToClass (sectionStyle s)
| otherwise = styleToClass (sectionStyle s)
liftIO . writeFile (o > fn) . unlines $
[ ""
, ""
, " "
, " "
, " " ++ stripTags title ++ ""
, " "
, " "
, " "
, " "
, if showTOC
then unlines
[ "
"
, "
On this page:
"
, toc
, case parent of
Nothing -> ""
Just p -> "
Up one level:
" ++ p
, "
"
]
else ""
, "
"
, 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
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 styleMatch TOC (sectionStyle p)
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