2f8d675 · typeable/pandoc

git.iko.soy/typeable/pandoc

on master help sign in

Org reader: improve tag and properties type safety

2f8d675Albert Krewinkel10 years ago

src/Text/Pandoc/Readers/Org/Blocks.hs+57−25

compare with master

unifiedsplit

@@ -53,6 +53,35 @@ import qualified Data.Map as M

53import Data.Maybe ( fromMaybe, isNothing )

54import Network.HTTP ( urlEncode )

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+

57--

86--

58-- parsing blocks

87-- parsing blocks

@@ -381,30 +410,22 @@ drawerEnd = try $

381

410

382-- | Read a :PROPERTIES: drawer and return the key/value pairs contained

411-- | Read a :PROPERTIES: drawer and return the key/value pairs contained

383-- within.

412-- within.

384−propertiesDrawer :: OrgParser [(String, String)]

413+propertiesDrawer :: OrgParser Properties

385propertiesDrawer = try $ do

414propertiesDrawer = try $ do

386 drawerType <- drawerStart

415 drawerType <- drawerStart

387 guard $ map toUpper drawerType == "PROPERTIES"

416 guard $ map toUpper drawerType == "PROPERTIES"

388 manyTill property (try drawerEnd)

417 manyTill property (try drawerEnd)

389 where

418 where

390− property :: OrgParser (String, String)

419+ property :: OrgParser (PropertyKey, PropertyValue)

391 property = try $ (,) <$> key <*> value

420 property = try $ (,) <$> key <*> value

392

421

393− key :: OrgParser String

422+ key :: OrgParser PropertyKey

423+ key = fmap toPropertyKey . try $

394− key = try $ skipSpaces *> char ':' *> many1Till nonspaceChar (char ':')

424+ skipSpaces *> char ':' *> many1Till nonspaceChar (char ':')

395

425

396− value :: OrgParser String

426+ value :: OrgParser PropertyValue

427+ value = fmap toPropertyValue . try $

397− value = try $ skipSpaces *> manyTill anyChar (try $ skipSpaces *> newline)

428+ 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')

408

429

409

430

410--

431--

@@ -624,23 +645,34 @@ header = try $ do

624 tags <- option [] headerTags

645 tags <- option [] headerTags

625 newline

646 newline

626 let text = tagTitle title tags

647 let text = tagTitle title tags

627− propAttr <- option nullAttr (keyValuesToAttr <$> propertiesDrawer)

648+ propAttr <- option nullAttr (propertiesToAttr <$> propertiesDrawer)

628 attr <- registerHeader propAttr (runF text def)

649 attr <- registerHeader propAttr (runF text def)

629 return (B.headerWith attr level <$> text)

650 return (B.headerWith attr level <$> text)

630 where

651 where

631− tagTitle :: [F Inlines] -> [String] -> F Inlines

652+ tagTitle :: [F Inlines] -> [Tag] -> F Inlines

632 tagTitle title tags = trimInlinesF . mconcat $ title <> map tagToInlineF tags

653 tagTitle title tags = trimInlinesF . mconcat $ title <> map tagToInlineF tags

633

654

634− tagToInlineF :: String -> F Inlines

655+ tagToInlineF :: Tag -> F Inlines

656+ tagToInlineF t =

635− tagToInlineF t = return $ B.spanWith ("", ["tag"], [("data-tag-name", t)]) mempty

657+ return $ B.spanWith ("", ["tag"], [("data-tag-name", fromTag t)]) mempty

636

658

637− headerTags :: OrgParser [String]

659+ headerTags :: OrgParser [Tag]

638 headerTags = try $

660 headerTags = try $

639 let tag = many1 (alphaNum <|> oneOf "@%#_") <* char ':'

661 let tag = many1 (alphaNum <|> oneOf "@%#_") <* char ':'

640− in skipSpaces

662+ in map toTag <$> (skipSpaces *> char ':' *> many1 tag <* skipSpaces)

641− *> char ':'

663+

642− *> many1 tag

664+propertiesToAttr :: Properties -> Attr

643− <* skipSpaces

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')

644

676

645

677

646--

678--