Automatically generate documentation from comments in R7RS Scheme code
git clone https://git.8pit.net/scmdoc.git
1{-# LANGUAGE LambdaCase #-} 2{-# LANGUAGE OverloadedStrings #-} 3 4-- | This is the high-level interface for rendering Scheme source 5-- documentation to a suitable output format. Currently, only HTML 6-- is supported as an output format. 7-- 8-- The API, provided by this module, is structured around R7RS 9-- Scheme 'L.Library' declarations and generates documentation 10-- for all exported identifiers of a Scheme library. 11module SchemeDoc (DocLib, findDocLibs, docDecls, docFmt, mkDoc, findUndocumented) 12where 13 14import SchemeDoc.Error 15import SchemeDoc.Format.Formatter 16import qualified SchemeDoc.Format.Library as L 17import qualified SchemeDoc.Format.Record as R 18import SchemeDoc.Format.Types 19import SchemeDoc.Types 20 21import qualified Data.Text as T 22import Text.Blaze.Html 23import Text.Blaze.Html.Renderer.String 24import qualified Text.Blaze.Html5 as H 25import qualified Text.Blaze.Html5.Attributes as A 26 27-- | A documented Scheme library, i.e. a Scheme 'L.Library' declaration 28-- which is proceded by a 'DocComment'. 29type DocLib = (T.Text, L.Library) 30 31-- | Find all documented Scheme 'L.Library' declarations in a Scheme source. 32findDocLibs :: [Sexp] -> Either SyntaxError [DocLib] 33findDocLibs exprs = foldr fn (Right []) (findDocumented exprs) 34 where 35 fn (s, e@(List ((Id "define-library") : _))) acc = 36 case L.mkLibrary e of 37 Right lib -> fmap ((s, lib) :) acc 38 Left err -> Left err 39 fn _ acc = acc 40 41-- | Find all documented 'Component's of a Scheme 'L.Library'. Performs 42-- file system access to expand includes and may return an 'ErrParser' 43-- exception. 44-- 45-- Returns the recognized Components and a list of S-expressions which 46-- were preceded by a 'DocComment' but for which no suitable 'Formatter' 47-- was found. 48docDecls :: DocLib -> IO ([Component], [Sexp]) 49docDecls (_, lib) = do 50 sexprs <- L.expand lib 51 pure $ findComponents defFormatter (findDocumented sexprs) 52 53-- | Format a documented 'L.Library', with regards to its 'Component's 54-- (obtained via 'docDecls') as an 'Html' document. 55docFmt :: DocLib -> [Component] -> Html 56docFmt (libDesc, lib) comps = 57 let html = format lib comps 58 in declFmt (fmt lib libDesc) Nothing >> html 59 60-- | Render an 'Html' document with the given title, stylesheet, and body. 61mkDoc :: String -> String -> Html -> String 62mkDoc title css hbody = renderHtml $ H.docTypeHtml $ do 63 H.head $ do 64 H.meta ! A.charset "UTF-8" 65 H.meta 66 ! A.name "viewport" 67 ! A.content "width=device-width, initial-scale=1" 68 69 H.link 70 ! A.rel "stylesheet" 71 ! A.href (stringValue css) 72 H.title $ toHtml title 73 H.body hbody 74 75-- | The name of all internal identifiers which are exported by the 76-- 'L.Library' but not documented, i.e. not preceded by a 'DocComment'. 77findUndocumented :: L.Library -> [Component] -> [T.Text] 78findUndocumented lib comps = 79 filter (\i -> not $ member i comps) $ 80 map L.internal (L.exported lib) 81 where 82 member :: T.Text -> [Component] -> Bool 83 member ident = 84 any 85 ( \case 86 D d -> declId d == ident 87 S _ -> False 88 ) 89 90------------------------------------------------------------------------ 91 92-- Filter out all non-documented S-expressions and attempt to perform 93-- pseudo macro expansion for documented S-expression. 94filterAndExpand :: [Sexp] -> [Sexp] 95filterAndExpand = snd . walk filterAndExpand' (False, []) 96 where 97 filterAndExpand' :: (Bool, [Sexp]) -> Sexp -> Walk (Bool, [Sexp]) 98 filterAndExpand' (False, acc) c@(DocComment _) = Recur (True, acc ++ [c]) 99 filterAndExpand' (True, acc) expr =100 -- Attempt to expand the expression. If expansion was successful101 -- strip the preceding DocComment from the accumulated value and102 -- filter the expanded S-expressions.103 --104 -- TODO: Generalize this and use it for Library expansion too.105 case R.expand expr of106 Just e -> Rise (False, init acc ++ filterAndExpand [e])107 Nothing -> Recur (False, acc ++ [expr])108 filterAndExpand' b _ = Recur b109110-- Find all S-expressions which are preceded by a documentation comment.111findDocumented :: [Sexp] -> [Documented]112findDocumented = toPairLst . filterAndExpand113 where114 toPairLst :: [Sexp] -> [Documented]115 toPairLst [] = []116 toPairLst ((DocComment s) : expr : xs) = (s, expr) : toPairLst xs117 toPairLst _ = error "unreachable"