Builder.hs

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