<commit_before>module Anatomy.Builder where

import Control.Monad.State
import Data.Char
import Data.Dynamic
import Data.IORef
import Data.Maybe (isJust)
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.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"
    lift (macroExpand e >>= withTop env . eval)
    return ""
build (Nested ss) = fmap concat $ mapM build ss
build (SectionReference n) = do
    style <- gets sectionStyle
    if styleMatch TOC style
        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
    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 $
        [ "<!DOCTYPE html>"
        , "<html>"
        , "  <head>"
        , "    <meta http-equiv=\"content-type\" content=\"text/html; charset=utf-8\" />"
        , "    <title>" ++ stripTags title ++ "</title>"
        , "    <link rel=\"stylesheet\" type=\"text/css\" href=\"anatomy.css\" />"
        , "    <link rel=\"stylesheet\" type=\"text/css\" href=\"highlight.css\" />"
        , "  </head>"
        , "  <body class=\"" ++ classes ++ "\">"

        , if showTOC
            then unlines
                [ "    <div id=\"sidebar\">"
                , "       <h4>On this page:</h4>"
                , toc
                , case parent of
                    Nothing -> ""
                    Just p -> "<h4>Up one level:</h4>" ++ p
                , "    </div>"
                ]
            else ""

        , "    <div id=\"content\">"
        , contentFor (sectionStyle s) title (autoFlow body)
        , "    </div>"
        , "  </body>"
        , "</html>"
        ]

    return (particle "done")

contentFor :: Style -> String -> String -> String
contentFor s t b
    | styleMatch Annotated s =
        concat
            [ "<table class=\"annotated-source\">"
            , "<thead><tr><th class=\"prose\"><h1>" ++ t ++ "</h1></th><th class=\"code\"></th></tr></thead>"
            , b
            , "</table>"
            ]
    | otherwise =
        concat
            [ "<h1>" ++ t ++ "</h1>"
            , 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)<commit_msg>search tag generation based on title, tags, and bindings<commit_after>module Anatomy.Builder where

import Control.Monad.State
import Data.Char
import Data.Dynamic
import Data.IORef
import Data.List (intercalate)
import Data.Maybe (fromJust, isJust)
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.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"
    lift (macroExpand e >>= withTop env . eval)
    return ""
build (Nested ss) = fmap concat $ mapM build ss
build (SectionReference n) = do
    style <- gets sectionStyle
    if styleMatch TOC style
        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
    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 (putStrLn "generating search tags")
    ts <- searchTags s
    liftIO . writeFile (o </> "tags.js") . concat $
        [ "var SEARCH_TAGS = {\n  "
        , intercalate ",\n  " $
            map (\(k, v) -> show k ++ ": " ++ show v) ts
        , "\n};"
        ]

    liftIO . writeFile (o </> fn) . unlines $
        [ "<!DOCTYPE html>"
        , "<html>"
        , "  <head>"
        , "    <meta http-equiv=\"content-type\" content=\"text/html; charset=utf-8\" />"
        , "    <title>" ++ stripTags title ++ "</title>"
        , "    <link rel=\"stylesheet\" type=\"text/css\" href=\"anatomy.css\" />"
        , "    <link rel=\"stylesheet\" type=\"text/css\" href=\"highlight.css\" />"
        , "  </head>"
        , "  <body class=\"" ++ classes ++ "\">"

        , if showTOC
            then unlines
                [ "    <div id=\"sidebar\">"
                , "       <h4>On this page:</h4>"
                , toc
                , case parent of
                    Nothing -> ""
                    Just p -> "<h4>Up one level:</h4>" ++ p
                , "    </div>"
                ]
            else ""

        , "    <div id=\"content\">"
        , contentFor (sectionStyle s) title (autoFlow body)
        , "    </div>"
        , "  </body>"
        , "</html>"
        ]

    return (particle "done")

contentFor :: Style -> String -> String -> String
contentFor s t b
    | styleMatch Annotated s =
        concat
            [ "<table class=\"annotated-source\">"
            , "<thead><tr><th class=\"prose\"><h1>" ++ t ++ "</h1></th><th class=\"code\"></th></tr></thead>"
            , b
            , "</table>"
            ]
    | otherwise =
        concat
            [ "<h1>" ++ t ++ "</h1>"
            , b
            ]

getAObject :: AVM Value
getAObject = do
    s <- get

    lift $ defineOn (sectionA s)
        (Slot (single "state" PThis) (Haskell (toDyn s)))

    return (sectionA s)

searchTags :: Section -> AVM [(String, String)]
searchTags s = do
    t <- liftM stripTags $ build (titleText (sectionTitle s))
    u <- sectionURL s

    tag <-
        case titleTag (sectionTitle s) of
            Nothing -> return []
            Just s -> do
                x <- liftM stripTags $ buildForString' s
                if null x
                    then return []
                    else return [(x, u)]

    bs <- forM (sectionBindings s) $ \b -> do
        u <- findBinding b s
        case b of
            SingleKey s -> return (s, fromJust u)
            KeywordKey ss -> return (concat (map (++ ":") ss), fromJust u)

    subts <- mapM searchTags (subSections s)
    return ([(t, u)] ++ tag ++ bs ++ concat subts)

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)
{'fraction_non_alphanumeric': 0.14004858482571605, 'fraction_numerical': 0.001355855601378453, 'mean_word_length': 1.7881556150574893, 'pattern_counts': {'":': 2, '<': 212, '<?xml version=': 0, '>': 233, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '6237319', 'n_tokens_mistral': 5515, 'n_tokens_neox': 5216, 'n_words': 1672}