packages feed

clippings 0.1.3 → 0.2.0

raw patch · 12 files changed

+194/−161 lines, 12 filesdep +functor-infix

Dependencies added: functor-infix

Files

clippings.cabal view
@@ -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 <me@vikramverma.com> maintainer:          Vikram Verma <me@vikramverma.com>-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:
+ examples/Clippings2TSV.hs view
@@ -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
− examples/clippings2tsv/Main.hs 
@@ -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
− src/Data/Functor/Extras.hs 
@@ -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
− src/Data/String/Extras.hs 
@@ -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
src/Text/Kindle/Clippings/Reader.hs view
@@ -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
src/Text/Kindle/Clippings/Types.hs view
@@ -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
src/Text/Kindle/Clippings/Writer.hs view
@@ -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"
src/Text/Parsec/Combinator/Extras.hs view
@@ -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))
tests/Reader.hs view
@@ -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)     ]
+ tests/fixtures/pw2clipping.txt view
@@ -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+==========
+ tests/fixtures/pw2pdfclipping.txt view
@@ -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+==========