1{-# LANGUAGE LambdaCase #-}2{-# LANGUAGE OverloadedStrings #-}34-- | This module implements a 'Formatter' for Scheme library definitions.5--6-- For example:7--8-- > (define-library (math arithmetic)9-- > (export my-proc)10-- >11-- > (begin12-- > (define (my-proc x)13-- > (* x 2))))14module SchemeDoc.Format.Library (15 Library (..),16 mkLibrary,17 name,18 externalId,19 exports,20 expand,21 ExportSpec (..),22 LibraryName,23)24where2526import Control.Monad (foldM)27import Data.List (find)2829import SchemeDoc.Error30import SchemeDoc.Format.Types31import SchemeDoc.Format.Util32import SchemeDoc.Parser.R7RS33import SchemeDoc.Types3435import qualified Data.Text as T36import Text.Blaze.Html37import qualified Text.Blaze.Html5 as H3839-- | An R7RS Scheme library as defined in Section 5.6 of the standard.40data Library = Library41 { ident :: LibraryName42 -- ^ Library name.43 , exported :: [ExportSpec]44 -- ^ Export declaration of the library.45 , decl :: [Sexp]46 -- ^ Declarations of the library.47 }48 deriving (Show)4950instance Formatable Library where51 fmt lib desc = mkDeclaration (name lib) desc $ \n ->52 do53 H.h1 $ toHtml n54 fromMkd desc5556-- | Parse a Scheme library definition.57--58-- > <library> → (define-library <library name>59-- > <library declaration>*)60--61-- where62--63-- > <library name part> → <identifier> | <uinteger 10>64-- > <library declaration> → (export <export spec>*)65-- > | <import declaration>66-- > | (begin <command or definition>*)67-- > | <includer>68-- > | (include-library-declarations <string>+)69-- > | (cond-expand <cond-expand clause>+)70-- > | (cond-expand <cond-expand clause>+71-- > (else <library declaration>*))72mkLibrary :: Sexp -> Either SyntaxError Library73mkLibrary (List ((Id "define-library") : libraryName : xs)) = do74 libraryName' <- case mkLibName libraryName of75 Right n -> pure n76 Left err -> Left err7778 exportSpec <- case findExport xs of79 Right e -> pure e80 Left err -> Left err8182 pure $ Library libraryName' exportSpec xs83-- TODO: Handling of cond-expand?!84mkLibrary e = makeErr e "found no library definition"8586-- | Name of the 'Library'. Multiple identifiers, within the library87-- name, are joined by a single @' '@ character.88name :: Library -> T.Text89name (Library{ident = n}) = name' n9091-- | Return the external identifier for the given internal identifier.92externalId :: Library -> T.Text -> Maybe T.Text93externalId lib n =94 external95 <$> find (\e -> internal e == n) (exported lib)9697-- | Whether the 'Library' exports the given **internal** identifier.98exports :: Library -> T.Text -> Bool99exports lib i =100 any (\Export{internal = i'} -> i == i') $101 exported lib102103-- Expand an include into a begin expression.104--105-- <includer> →106-- | (include <string>+)107-- | (include-ci <string>+)108--109-- TODO: Support include-ci110expandIncl :: Sexp -> IO Sexp111expandIncl (List ((Id "include") : fileNames)) = expandIncl' fileNames112expandIncl e@(List ((Id "include-ci") : _)) = throwSyntax e "include-ci currently not supported"113expandIncl e = throwSyntax e "not an include expression"114115expandIncl' :: [Sexp] -> IO Sexp116expandIncl' fileNames = do117 paths <-118 mapM119 ( \case120 Str s -> pure s121 e -> throwSyntax e "expected list of strings"122 )123 fileNames124125 exprs <- mapM (parseFromFile . T.unpack) paths126 pure $ List (Id "begin" : concat exprs)127128-- | Expand the library declaration. Returns all begin blocks, including129-- includer expressions as expanded begin blocks.130expand :: Library -> IO [Sexp]131expand (Library{decl = d}) = foldM expand' [] d132 where133 expand' :: [Sexp] -> Sexp -> IO [Sexp]134 expand' acc e@(List ((Id "begin") : _)) = pure $ e : acc135 expand' acc e@(List ((Id "include") : _)) = expandIncl e >>= (\x -> pure $ x : acc)136 expand' acc e@(List ((Id "include-ci") : _)) = expandIncl e >>= (\x -> pure $ x : acc)137 expand' acc _ = pure acc138139------------------------------------------------------------------------140141-- | Name of a R7RS Scheme library.142newtype LibraryName = LibName [T.Text]143144instance Show LibraryName where145 show = T.unpack . name'146147name' :: LibraryName -> T.Text148name' (LibName lst) = T.intercalate " " lst149150-- Parses a Scheme library name.151--152-- <library name part> → <identifier> | <uinteger 10>153--154mkLibName :: Sexp -> Either SyntaxError LibraryName155mkLibName (List exprs) =156 LibName157 <$> mapM158 ( \case159 Id i -> Right i160 -- TODO: Only allow <uinteger 10> in library name161 Number n -> Right $ T.pack (show n :: String)162 e -> makeErr e "expected identifier or uinteger"163 )164 exprs165mkLibName e = makeErr e "expected non-empty list"166167------------------------------------------------------------------------168169-- | Export specification with internal name and external name.170-- For exports which are not renamed both are the same.171data ExportSpec = Export {internal :: T.Text, external :: T.Text}172 deriving (Show)173174-- Export declaration for a library declaration.175--176-- <export spec> → <identifier>177-- | (rename <identifier> <identifier>)178--179exportDecl :: Sexp -> Either SyntaxError ExportSpec180exportDecl (List [Id "rename", Id i1, Id i2]) = Right $ Export i1 i2181exportDecl (Id i) = Right $ Export i i182exportDecl e = makeErr e "expected identifier or rename spec"183184-- Export expression as part of a library declaration.185--186-- <export expr> → (export <export spec>*)187--188mkExport :: Sexp -> Either SyntaxError [ExportSpec]189mkExport (List ((Id "export") : items)) =190 foldr191 ( \x acc -> case exportDecl x of192 Right e -> fmap (e :) acc193 Left e -> Left e194 )195 (Right [])196 items197mkExport e = makeErr e "expected export list"198199-- Find an export expression within a library declaration.200-- May return an empty list if no export declaration was found.201findExport :: [Sexp] -> Either SyntaxError [ExportSpec]202findExport (e@(List ((Id "export") : _)) : xs) = mkExport e >>= (\ex -> (++) ex <$> findExport xs)203findExport (_ : exprs) = findExport exprs204findExport [] = Right []