diff --git a/filter/with-glossary.hs b/filter/with-glossary.hs index 9664fd168c17c6be17998eabd299130b647d1b30..452d0db044982b91a9f8bffd5f9c38fda0b6619d 100644 --- a/filter/with-glossary.hs +++ b/filter/with-glossary.hs @@ -4,10 +4,10 @@ import Control.Monad.Reader (MonadReader(..), ReaderT(..), asks, runReaderT) import Control.Monad.State (MonadState(..), gets, modify, runStateT) import Control.Monad.IO.Class (MonadIO(..)) import Data.Attoparsec.Text (char, inClass, parseOnly, string, takeWhile1) -import Data.Char (isAlphaNum, isUpper, toLower) +import Data.Char as Char (isAlphaNum, isUpper, toLower) import Data.Default (def) -import Data.Map as Map (Map, insert, member, toList) -import Data.Text as Text (Text, concat, map, toTitle, unpack) +import Data.Map as Map (Map, insert, elems, member) +import Data.Text as Text (Text, concat, map, toLower, toTitle, unpack) import Data.Text.IO as Text (readFile) import System.Exit (die) import System.FilePath ((</>), (<.>)) @@ -22,7 +22,10 @@ import Text.Read (readMaybe) main :: IO () main = toJSONFilter withGlossary -type Glossary = Map Text [Block] +data Entry = Entry + { headword :: Text + , definition :: [Block] } +type Glossary = Map Text Entry data KnownFormat = Latex | Html deriving (Read, Show) type RawMaker = (Text, KnownFormat -> [Text]) -> Inline data Config = Config @@ -69,16 +72,20 @@ findDefinitions i = pure i loadDef :: (MonadIO m, MonadReader Config m, MonadState Glossary m) => Text -> Bool -> m Inline -loadDef t True = raw link t -loadDef t _ = do - Pandoc _ definition <- getDocument =<< asks ((</> unpack t <.> "md") . root) - modify $ insert t [] -- set a (temporary) empty definition for the term to avoid loops - modify . insert t =<< walkM findDefinitions definition - loadDef t True +loadDef headword True = raw link headword +loadDef headword _ = do + Pandoc _ definitionBody <- getDocument =<< asks definitionPath + store empty -- set a (temporary) empty definition for the term to avoid loops + definition <- walkM findDefinitions definitionBody + store $ Entry {headword, definition} + loadDef headword True where + definitionPath = ((</> unpack headword <.> "md") . root) getDocument path = liftIO (Text.readFile path >>= runIOorExplode . readMarkdown options) options = def { readerExtensions = pandocExtensions } + empty = Entry {headword = "", definition = []} + store = modify . insert (Text.toLower headword) addGlossarySection :: MonadReader Config m => ([Block], Glossary) -> m [Block] addGlossarySection (blocks, definitions) @@ -88,14 +95,15 @@ addGlossarySection (blocks, definitions) header (Config {level, title}) = Header level ("glossary", ["unnumbered"], []) [Str title] chaptermark = Plain . pure <$> (raw sectionTitle =<< asks title) - body = DefinitionList <$> (mapM entryOf $ Map.toList definitions) - entryOf (key, definition) = (,[definition]) <$> sequence [raw target key] + body = DefinitionList <$> (mapM item $ Map.elems definitions) + item (Entry {headword, definition}) = + (,[definition]) <$> sequence [raw target headword] labelFor :: Text -> Text labelFor t = "glossary-" <> Text.map normalize t where normalize c - | isUpper c = toLower c + | isUpper c = Char.toLower c | isAlphaNum c = c | otherwise = '_'