diff --git a/clippings.cabal b/clippings.cabal --- a/clippings.cabal +++ b/clippings.cabal @@ -1,10 +1,15 @@ name: clippings -version: 0.1.3 +version: 0.2.0 license: MIT synopsis: A parser/generator for Kindle-format clipping files (`My Clippings.txt`), author: Vikram Verma maintainer: Vikram Verma -data-files: tests/fixtures/brackets.txt, tests/fixtures/clipping.txt, tests/fixtures/nested_brackets.txt +data-files: + tests/fixtures/brackets.txt, + tests/fixtures/clipping.txt, + tests/fixtures/nested_brackets.txt, + tests/fixtures/pw2clipping.txt, + tests/fixtures/pw2pdfclipping.txt category: Text build-type: Simple cabal-version: >=1.10 @@ -16,19 +21,17 @@ Text.Kindle.Clippings.Writer Text.Kindle.Clippings.Types other-modules: - Data.Functor.Extras, - Data.String.Extras, Text.Parsec.Combinator.Extras hs-source-dirs: src build-depends: base, - bifunctors, time, parsec, old-locale, strptime, - data-default + data-default, + functor-infix default-language: Haskell2010 ghc-options: @@ -59,9 +62,9 @@ executable clippings2tsv main-is: - Main.hs + Clippings2TSV.hs hs-source-dirs: - examples/clippings2tsv + examples/ build-depends: base == 4.*, bifunctors, @@ -69,7 +72,8 @@ cassava, parsec, bytestring, - safecopy + safecopy, + functor-infix default-language: Haskell2010 ghc-options: diff --git a/examples/Clippings2TSV.hs b/examples/Clippings2TSV.hs new file mode 100644 --- /dev/null +++ b/examples/Clippings2TSV.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE RecordWildCards, LambdaCase #-} + +module Main where + +import Prelude hiding (putStr) +import Control.Applicative ((<$>)) +import Data.Bifunctor (Bifunctor(bimap)) +import Data.ByteString.Lazy (ByteString) +import Data.ByteString.Lazy.Char8 (putStr) +import Data.Char (ord) +import Data.Csv (ToRecord(..), EncodeOptions(..), encodeWith, defaultEncodeOptions, toField, record) +import Data.Functor.Infix ((<$$>)) +import Data.Maybe (fromMaybe, catMaybes) +import Data.Monoid ((<>)) +import System.Environment (getArgs) +import System.Exit (exitSuccess, exitFailure) +import System.IO (hPutStr, stderr) +import Text.Kindle.Clippings (Clipping(..), Document(..), Content(..), readClippings) +import Text.Parsec (parse) + +data Card = Card { question :: String, answer :: String } + +instance ToRecord Card where + toRecord (Card q a) = record $ map toField [q,a] + +class ToCard a where + toCard :: a -> Maybe Card + +instance ToCard Clipping where + toCard c@Clipping{..} + | not (isHighlight c) = Nothing + | null (show content) = Nothing + | otherwise = Just $ Card content' author' + where author' = fromMaybe "[clippings2tsv]" $ (" - " <>) <$> author document + content' = \case { '\n' -> ' '; chr -> chr; } <$> show content + +isHighlight :: Clipping -> Bool +isHighlight Clipping{..} = case content of + Highlight _ -> True + _ -> False + +getClippings :: String -> Either String [Clipping] +getClippings = bimap show catMaybes + . parse readClippings [] + +encodeTabDelimited :: ToRecord a => [a] -> ByteString +encodeTabDelimited = encodeWith $ defaultEncodeOptions + { encDelimiter = fromIntegral $ ord '\t' } + +renderClippings :: [Clipping] -> ByteString +renderClippings = encodeTabDelimited . catMaybes . fmap toCard + +main :: IO () +main = head <$> getArgs >>= getClippings <$$> readFile >>= \case + Left err -> hPutStr stderr err >> exitFailure + Right cs -> putStr (renderClippings cs) >> exitSuccess diff --git a/examples/clippings2tsv/Main.hs b/examples/clippings2tsv/Main.hs deleted file mode 100644 --- a/examples/clippings2tsv/Main.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE RecordWildCards, LambdaCase #-} - -module Main where - -import Prelude hiding (putStr) -import Control.Applicative ((<$>)) -import Control.Applicative.Extras ((<$$>)) -import Data.Bifunctor (Bifunctor(bimap)) -import Data.ByteString.Lazy (ByteString) -import Data.ByteString.Lazy.Char8 (putStr) -import Data.Card (Card(..), ToCard(..)) -import Data.Csv.Extras (encodeTabDelimited) -import Data.List.Extras (substitute) -import Data.Maybe (fromMaybe, catMaybes) -import Data.Monoid ((<>)) -import System.Environment (getArgs) -import System.Exit (exitSuccess, exitFailure) -import System.IO (hPutStr, stderr) -import Text.Kindle.Clippings (Clipping(..), Document(..), Content(..), readClippings) -import Text.Parsec (parse) - -instance ToCard Clipping where - toCard c@Clipping{..} - | not (isHighlight c) = Nothing - | null (show content) = Nothing - | otherwise = Just $ Card content' author' - where author' = fromMaybe "[clippings2tsv]" $ (" - " <>) <$> author document - content' = substitute '\n' ' ' $ show content - -isHighlight :: Clipping -> Bool -isHighlight Clipping{..} = case content of - Highlight _ -> True - _ -> False - -getClippings :: String -> Either String [Clipping] -getClippings = bimap show catMaybes - . parse readClippings [] - -renderClippings :: [Clipping] -> ByteString -renderClippings = encodeTabDelimited . catMaybes . fmap toCard - -main :: IO () -main = head <$> getArgs >>= getClippings <$$> readFile >>= \case - Left err -> hPutStr stderr err >> exitFailure - Right cs -> putStr (renderClippings cs) >> exitSuccess diff --git a/src/Data/Functor/Extras.hs b/src/Data/Functor/Extras.hs deleted file mode 100644 --- a/src/Data/Functor/Extras.hs +++ /dev/null @@ -1,10 +0,0 @@ -module Data.Functor.Extras ( - (<$$>), - for -) where - -(<$$>) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b) -(<$$>) = fmap fmap fmap - -for :: Functor f => f a -> (a -> b) -> f b -for = flip fmap diff --git a/src/Data/String/Extras.hs b/src/Data/String/Extras.hs deleted file mode 100644 --- a/src/Data/String/Extras.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Data.String.Extras (pad, chomp) where - -import Data.Char (isSpace) - -pad :: (String,String) -> (String,String) -pad (s0,s1) = (s0, pr++s1) - where pr = take (length s0 - length s1) s0 - -chomp :: String -> String -chomp = rstrip . lstrip - where lstrip = dropWhile isSpace - rstrip = reverse . lstrip . reverse diff --git a/src/Text/Kindle/Clippings/Reader.hs b/src/Text/Kindle/Clippings/Reader.hs --- a/src/Text/Kindle/Clippings/Reader.hs +++ b/src/Text/Kindle/Clippings/Reader.hs @@ -1,89 +1,112 @@ -module Text.Kindle.Clippings.Reader where +module Text.Kindle.Clippings.Reader +( readClipping +, readClippings +) where -import Control.Applicative ((<$>), (<*>), (*>), (<*), (<|>)) -import Data.Bifunctor (bimap) -import Data.Functor.Extras ((<$$>),for) +import Control.Applicative ((<$>), (<*>), (*>), (<*), (<|>), liftA2) +import Control.Monad (join) +import Data.Functor.Infix ((<$$>)) import Data.List (find) -import Data.Maybe (fromJust, isJust) -import Data.String.Extras (pad, chomp) +import Data.Maybe (isJust, fromMaybe) import Data.Time.LocalTime (LocalTime) import Data.Time.Parse (strptime) -import Text.Kindle.Clippings.Types (Clipping(..),Location(..),Document(..),Position(..),Content(..)) -import Text.Parsec (many1, digit, alphaNum, string, skipMany, oneOf, try, char, manyTill, anyToken) +import Text.Kindle.Clippings.Types (Clipping(..),Interval(..),Document(..),Position(..),Content(..)) +import Text.Parsec (many1, digit, string, oneOf, try, char, manyTill, anyToken, lookAhead, many, noneOf, between) import Text.Parsec.String (Parser) -import Text.Parsec.Combinator.Extras (but, tryBut1, tryMaybe, tryString) +import Text.Parsec.Combinator.Extras (optional, but, tryString, stringCI) -eol :: Parser () -eol = skipMany $ oneOf "\n\r" +data Tree = Leaf String | Node [Tree] -eor :: Parser String -eor = string "==========" +brackets :: Parser Tree +brackets = Node <$> between + (char '(') (char ')') + (many (brackets <|> (Leaf <$> many1 (noneOf "()")))) +instance Show Tree where + show (Leaf x) = x + show (Node xs) = "(" ++ concatMap show xs ++ ")" + +node :: a -> ([Tree] -> a) -> (Tree -> a) +node _ fun (Node xs) = fun xs +node def _ _ = def + +-- N.B. +-- The document parser (i.e. 'author' + 'title') is known to fail where +-- the author component includes unmatched parentheses, however this case +-- appears ambiguous in the grammar. + +space :: Parser String +space = string " " + +eol :: Parser String +eol = many1 $ oneOf "\n\r" + readTitle :: Parser String -readTitle = chomp . concat <$> textAndBrackets - where brackets = (\a b c -> a:(concat b)++c) <$> char '(' <*> textAndBrackets <*> string ") " - textAndBrackets = many1 (tryBut1 "(\r\n)" <|> try brackets) +readTitle = manyTill anyToken (lookAhead . try $ space *> (try brackets <|> (Leaf <$> space)) *> eol) -readAuthor :: Parser (Maybe String) -readAuthor = tryMaybe $ init - <$> (char '(' *> but "\n\r") +readAuthor :: Parser String +readAuthor = node (error "The impossible happened!") (concatMap show) <$> brackets readContentType :: Parser String readContentType = (tryString "- Your " <|> string "- ") *> but " " - <* (tryString " on " <|> many1 (char ' ')) + <* (tryString " on " <|> tryString " at " <|> many1 (char ' ')) -readPageNumber :: Parser (Maybe Int) -readPageNumber = tryMaybe $ read - <$> (string "Page " *> many1 alphaNum <* string " | ") +parseSingletonInterval :: Parser Interval +parseSingletonInterval = Singleton . read <$> many1 digit -readLocation :: Parser (Maybe Location) -readLocation = tryMaybe - $ (tryString "Loc. " <|> string "Location ") - *> (try readLocationRegion <|> readLocationInt) - <* but "|" <* char '|' <* many1 (char ' ') +-- Early Kindle models sometimes described intervals of locations +-- with the prefix of the second part removed; e.g. ("1109", "12"). +-- this padding will normalise this to (1109, 1112). +normaliseRegion :: String -> String -> (Int, Int) +normaliseRegion s0 s1 = (read s0, read $ take (length s0 - length s1) s0++s1) -readLocationInt :: Parser Location -readLocationInt = Location . read <$> many1 digit +parseProperInterval :: Parser Interval +parseProperInterval = (uncurry Proper <$$> normaliseRegion) <$> many1 digit <*> (char '-' *> many1 digit) -readLocationRegion :: Parser Location -readLocationRegion = parseRegion - <$$> (,) - <$> many1 digit - <*> (char '-' *> many1 digit) +parseInterval :: Parser Interval +parseInterval = try parseProperInterval <|> parseSingletonInterval -parseRegion :: (String, String) -> Location -parseRegion = Region . bimap read read . pad +readPage :: Parser Interval +readPage = stringCI "Page " *> parseInterval <* string " | " +readLocation :: Parser Interval +readLocation = (tryString "Loc. " <|> stringCI "Location ") + *> parseInterval + <* many1 (oneOf " |") + parseDate :: String -> LocalTime -parseDate = fst . fromJust . fromJust {-[^1]-} . find isJust . for formats . flip strptime - where formats = - [ "%A, %d %B %y %X" - , "%A, %B %d, %Y %r" - , "" - ] --- [^1]: This is safe: `strptime x ""` is `Just` for all `x`. +parseDate raw = fromMaybe defaultLocalTime . join . find isJust . map (fst <$$> flip strptime raw) $ + [ "%A, %d %B %y %X" -- Thursday, 01 January 70 12:00:00 AM + , "%A, %B %d, %Y %r" -- Thursday, January 01, 1970 12:00:00 AM + ] +defaultLocalTime :: LocalTime +Just (defaultLocalTime, _) = strptime "" "" + readDate :: Parser LocalTime -readDate = parseDate <$> (string "Added on " *> but "\n\r") +readDate = string "Added on " *> (parseDate <$> but "\n\r") +eor :: Parser String +eor = string "==========" + readContent :: Parser String -readContent = chomp <$> manyTill anyToken (try eor) +readContent = manyTill anyToken (try $ many1 (oneOf "\n\r ") *> eor) readClipping :: Parser (Maybe Clipping) readClipping = clipping - <$> (Document <$> readTitle <*> readAuthor <* eol) + <$> liftA2 Document readTitle (many1 space *> optional readAuthor) <* eol <*> readContentType - <*> (Position <$> readPageNumber <*> readLocation) + <*> liftA2 Position (optional readPage) (optional readLocation) <*> readDate <* eol <*> readContent <* eol clipping :: Document -> String -> Position -> LocalTime -> String -> Maybe Clipping clipping d t p l c - |(==) t "Highlight" = Just $ Clipping d p l $ Highlight c - |(==) t "Note" = Just $ Clipping d p l $ Annotation c - |(==) t "Bookmark" = Just $ Clipping d p l Bookmark - |otherwise = Nothing + | (==) t "Highlight" = Just . Clipping d p l $ Highlight c + | (==) t "Note" = Just . Clipping d p l $ Annotation c + | (==) t "Bookmark" = Just . Clipping d p l $ Bookmark + | otherwise = Nothing readClippings :: Parser [Maybe Clipping] readClippings = many1 readClipping diff --git a/src/Text/Kindle/Clippings/Types.hs b/src/Text/Kindle/Clippings/Types.hs --- a/src/Text/Kindle/Clippings/Types.hs +++ b/src/Text/Kindle/Clippings/Types.hs @@ -2,7 +2,7 @@ ( Clipping (..) , Document (..) , Position (..) -, Location (..) +, Interval (..) , Content (..) ) where @@ -22,17 +22,12 @@ , author :: Maybe String -- Not always present, e.g. "Oxford Dictionary of English\n". } deriving (Eq) +data Interval = Singleton Int | Proper Int Int deriving (Eq) + data Position = Position - { page :: Maybe Int - , location :: Maybe Location -- PDFs don't get these. + { page :: Maybe Interval + , location :: Maybe Interval } deriving (Eq) - -data Location = Location Int | Region (Int,Int) - -instance Eq Location where - Location a == Location b = a==b - Region a == Region b = a==b - _ == _ = False data Content = Bookmark | Highlight String | Annotation String diff --git a/src/Text/Kindle/Clippings/Writer.hs b/src/Text/Kindle/Clippings/Writer.hs --- a/src/Text/Kindle/Clippings/Writer.hs +++ b/src/Text/Kindle/Clippings/Writer.hs @@ -6,26 +6,26 @@ import Data.Time.Format (formatTime) import Data.Time.LocalTime (LocalTime) import System.Locale (defaultTimeLocale) -import Text.Kindle.Clippings.Types (Clipping(..), Document(..), Position(..), Content(..), Location(..)) +import Text.Kindle.Clippings.Types (Clipping(..), Document(..), Position(..), Content(..), Interval(..)) instance Show Document where show (Document t (Just a)) = t ++ " (" ++ a ++ ")" show (Document t Nothing) = t +instance Show Interval where + show (Singleton i) = show i + show (Proper i0 i1) = show i0 ++ "-" ++ show i1 + instance Show Position where - show (Position Nothing (Just l)) = show l - show (Position Nothing Nothing) = "" - show (Position (Just p) (Just l)) = "on Page " ++ show p ++ " | " ++ show l - show (Position (Just p) Nothing) = "on Page " ++ show p + show (Position Nothing (Just l)) = "Loc. " ++ show l + show (Position (Just p) Nothing) = "on Page " ++ show p + show (Position p@(Just _) l@(Just _)) = show (Position p Nothing) ++ " | " ++ show (Position Nothing l) + show (Position Nothing Nothing) = "" instance Show Content where show (Highlight s) = s show (Annotation s) = s show (Bookmark) = "" - -instance Show Location where - show (Location i) = "Loc. " ++ show i - show (Region (l1,l2)) = "Loc. " ++ show l1 ++ "-" ++ show l2 showContentType :: Content -> String showContentType (Highlight _) = "Highlight" diff --git a/src/Text/Parsec/Combinator/Extras.hs b/src/Text/Parsec/Combinator/Extras.hs --- a/src/Text/Parsec/Combinator/Extras.hs +++ b/src/Text/Parsec/Combinator/Extras.hs @@ -1,21 +1,23 @@ module Text.Parsec.Combinator.Extras ( + optional, but, - tryBut1, - tryMaybe, - tryString + tryString, + stringCI ) where +import Control.Applicative ((<|>)) +import Data.Char (toLower, toUpper) import Text.Parsec.String (Parser) -import Text.Parsec (many, many1, noneOf, try, optionMaybe, string) +import Text.Parsec (many, noneOf, try, optionMaybe, string, char) +optional :: Parser a -> Parser (Maybe a) +optional = optionMaybe . try + but :: String -> Parser String but = many . noneOf -tryBut1 :: String -> Parser String -tryBut1 = try . many1 . noneOf - -tryMaybe :: Parser a -> Parser (Maybe a) -tryMaybe = optionMaybe . try - tryString :: String -> Parser String tryString = try . string + +stringCI :: String -> Parser String +stringCI = mapM (\c -> char (toUpper c) <|> char (toLower c)) diff --git a/tests/Reader.hs b/tests/Reader.hs --- a/tests/Reader.hs +++ b/tests/Reader.hs @@ -6,7 +6,7 @@ import Paths_clippings (getDataFileName) import Test.Assert (runAssertions) import Text.Kindle.Clippings.Reader (readClipping) -import Text.Kindle.Clippings.Types (Clipping(..),Location(..),Document(..),Position(..),Content(..)) +import Text.Kindle.Clippings.Types (Clipping(..),Interval(..),Document(..),Position(..),Content(..)) import Text.Kindle.Clippings.Writer () import Text.Parsec (parse) @@ -23,7 +23,7 @@ inFixture = Clipping { date = LocalTime (fromGregorian 2013 06 10) (TimeOfDay 6 58 17) , document = Document "Haskell Monoids and their Uses" (Just "sigfpe") - , position = Position Nothing . Just $ Region (3,4) + , position = Position Nothing . Just $ Proper 3 4 , content = Highlight "Haskell is a great language for constructing code modularly from small but orthogonal building blocks." } @@ -31,10 +31,18 @@ inPw2Fixture = Clipping { date = LocalTime (fromGregorian 2014 06 08) (TimeOfDay 20 36 53) , document = Document "Stand on Zanzibar" (Just "John Brunner") - , position = Position Nothing . Just $ Region (4607, 4607) + , position = Position Nothing . Just $ Proper 4607 4607 , content = Highlight "Shinka will" } +inPw2pdfFixture :: Clipping +inPw2pdfFixture = Clipping + { date = LocalTime (fromGregorian 2014 07 29) (TimeOfDay 07 53 28) + , document = Document "Tyler Cowen-Creative Destruction_ How Globalization Is Changing the World's Cultures-Princeton University Press (2002)_k2opt" Nothing + , position = Position (Just $ Proper 303 303) Nothing + , content = Highlight "The fundamental story about consumer taste, in modern times, is not one of dumbing down or of producers seeking to satisfy a homogeneous least common denominator at the expense of quality. Rather, the basic trend is of increasing variety and diversity, at all levels of quality, high and low" + } + getTitle :: Clipping -> String getTitle = title . document @@ -43,15 +51,17 @@ main :: IO () main = do - [clipping, brackets, nested, pw2] <- mapM (readFile <=< getDataFileName) + [clipping, brackets, nested, pw2, pw2pdf] <- mapM (readFile <=< getDataFileName) [ "tests/fixtures/clipping.txt" , "tests/fixtures/brackets.txt" , "tests/fixtures/nested_brackets.txt" , "tests/fixtures/pw2clipping.txt" + , "tests/fixtures/pw2pdfclipping.txt" ] runAssertions $ [ ("Fixture should parse to sigfpe clipping.", getClipping clipping == inFixture) , ("Brackets in clippings' titles should be preserved." , getTitle (getClipping brackets) == "An Introduction to Statistical Learning: with Applications in R (Springer Texts in Statistics)") , ("Nested brackets in clippings' authors should be preserved.", getAuthor (getClipping nested) == Just "G. K. (Gilbert Keith) Chesterton") , ("Pw2Fixture should parse to Zanzibar clipping", getClipping pw2 == inPw2Fixture) + , ("Pw2pdfFixture should parse to Tyler clipping", getClipping pw2pdf == inPw2pdfFixture) ] diff --git a/tests/fixtures/pw2clipping.txt b/tests/fixtures/pw2clipping.txt new file mode 100644 --- /dev/null +++ b/tests/fixtures/pw2clipping.txt @@ -0,0 +1,5 @@ +Stand on Zanzibar (John Brunner) +- Your Highlight on Location 4607-4607 | Added on Friday, June 8, 2014 8:36:53 PM + +Shinka will +========== diff --git a/tests/fixtures/pw2pdfclipping.txt b/tests/fixtures/pw2pdfclipping.txt new file mode 100644 --- /dev/null +++ b/tests/fixtures/pw2pdfclipping.txt @@ -0,0 +1,5 @@ +Tyler Cowen-Creative Destruction_ How Globalization Is Changing the World's Cultures-Princeton University Press (2002)_k2opt +- Your Highlight on page 303-303 | Added on Tuesday, July 29, 2014 7:53:28 AM + +The fundamental story about consumer taste, in modern times, is not one of dumbing down or of producers seeking to satisfy a homogeneous least common denominator at the expense of quality. Rather, the basic trend is of increasing variety and diversity, at all levels of quality, high and low +==========