@@ -53,6 +53,35 @@ import qualified Data.Map as M
5353import Data.Maybe ( fromMaybe, isNothing )
5454import Network.HTTP ( urlEncode )
5555
56+--
57+-- Org headers
58+--
59+newtype Tag = Tag { fromTag :: String }
60+ deriving (Show, Eq)
61+
62+-- | Create a tag containing the given string.
63+toTag :: String -> Tag
64+toTag = Tag
65+
66+-- | The key (also called name or type) of a property.
67+newtype PropertyKey = PropertyKey { fromKey :: String }
68+ deriving (Show, Eq, Ord)
69+
70+-- | Create a property key containing the given string. Org mode keys are
71+-- case insensitive and are hence converted to lower case.
72+toPropertyKey :: String -> PropertyKey
73+toPropertyKey = PropertyKey . map toLower
74+
75+-- | The value assigned to a property.
76+newtype PropertyValue = PropertyValue { fromValue :: String }
77+
78+-- | Create a property value containing the given string.
79+toPropertyValue :: String -> PropertyValue
80+toPropertyValue = PropertyValue
81+
82+-- | Key/value pairs from a PROPERTIES drawer
83+type Properties = [(PropertyKey, PropertyValue)]
84+
5685
5786--
5887-- parsing blocks
@@ -381,30 +410,22 @@ drawerEnd = try $
381410
382411-- | Read a :PROPERTIES: drawer and return the key/value pairs contained
383412-- within.
384−propertiesDrawer :: OrgParser [(String, String)]
413+propertiesDrawer :: OrgParser Properties
385414propertiesDrawer = try $ do
386415 drawerType <- drawerStart
387416 guard $ map toUpper drawerType == "PROPERTIES"
388417 manyTill property (try drawerEnd)
389418 where
390− property :: OrgParser (String, String)
419+ property :: OrgParser (PropertyKey, PropertyValue)
391420 property = try $ (,) <$> key <*> value
392421
393− key :: OrgParser String
394− key = try $ skipSpaces *> char ':' *> many1Till nonspaceChar (char ':')
422+ key :: OrgParser PropertyKey
423+ key = fmap toPropertyKey . try $
424+ skipSpaces *> char ':' *> many1Till nonspaceChar (char ':')
395425
396− value :: OrgParser String
397− value = try $ skipSpaces *> manyTill anyChar (try $ skipSpaces *> newline)
398−
399−keyValuesToAttr :: [(String, String)] -> Attr
400−keyValuesToAttr kvs =
401− let
402− lowerKvs = map (\(k, v) -> (map toLower k, v)) kvs
403− id' = fromMaybe mempty . lookup "custom_id" $ lowerKvs
404− cls = fromMaybe mempty . lookup "class" $ lowerKvs
405− kvs' = filter (flip notElem ["custom_id", "class"] . fst) lowerKvs
406− in
407− (id', words cls, kvs')
426+ value :: OrgParser PropertyValue
427+ value = fmap toPropertyValue . try $
428+ skipSpaces *> manyTill anyChar (try $ skipSpaces *> newline)
408429
409430
410431--
@@ -624,23 +645,34 @@ header = try $ do
624645 tags <- option [] headerTags
625646 newline
626647 let text = tagTitle title tags
627− propAttr <- option nullAttr (keyValuesToAttr <$> propertiesDrawer)
648+ propAttr <- option nullAttr (propertiesToAttr <$> propertiesDrawer)
628649 attr <- registerHeader propAttr (runF text def)
629650 return (B.headerWith attr level <$> text)
630651 where
631− tagTitle :: [F Inlines] -> [String] -> F Inlines
652+ tagTitle :: [F Inlines] -> [Tag] -> F Inlines
632653 tagTitle title tags = trimInlinesF . mconcat $ title <> map tagToInlineF tags
633654
634− tagToInlineF :: String -> F Inlines
635− tagToInlineF t = return $ B.spanWith ("", ["tag"], [("data-tag-name", t)]) mempty
655+ tagToInlineF :: Tag -> F Inlines
656+ tagToInlineF t =
657+ return $ B.spanWith ("", ["tag"], [("data-tag-name", fromTag t)]) mempty
636658
637− headerTags :: OrgParser [String]
659+ headerTags :: OrgParser [Tag]
638660 headerTags = try $
639661 let tag = many1 (alphaNum <|> oneOf "@%#_") <* char ':'
640− in skipSpaces
641− *> char ':'
642− *> many1 tag
643− <* skipSpaces
662+ in map toTag <$> (skipSpaces *> char ':' *> many1 tag <* skipSpaces)
663+
664+propertiesToAttr :: Properties -> Attr
665+propertiesToAttr properties =
666+ let
667+ toStringPair prop = (fromKey (fst prop), fromValue (snd prop))
668+ customIdKey = toPropertyKey "custom_id"
669+ classKey = toPropertyKey "class"
670+ id' = fromMaybe mempty . fmap fromValue . lookup customIdKey $ properties
671+ cls = fromMaybe mempty . fmap fromValue . lookup classKey $ properties
672+ kvs' = map toStringPair . filter ((`notElem` [customIdKey, classKey]) . fst)
673+ $ properties
674+ in
675+ (id', words cls, kvs')
644676
645677
646678--