diff --git a/Text/PrettyPrint/Compact.hs b/Text/PrettyPrint/Compact.hs
--- a/Text/PrettyPrint/Compact.hs
+++ b/Text/PrettyPrint/Compact.hs
@@ -1,5 +1,65 @@
 {-# LANGUAGE OverloadedStrings #-}
-
+-- | Compact pretty-printer.
+--
+-- == Examples
+--
+-- Assume that we want to pretty print S-Expressions, which can either be atom or a list of S-Expressions.
+--
+-- >>> data SExpr = SExpr [SExpr] | Atom String deriving Show
+-- >>> let pretty :: SExpr -> Doc (); pretty (Atom s) = text s; pretty (SExpr xs) = text "(" <> (sep $ map pretty xs) <> text ")"
+--
+-- Using the above representation, the S-Expression @(a b c d)@ has the following encoding:
+--
+-- >>> let abcd = SExpr [Atom "a",Atom "b",Atom "c",Atom "d"]
+--
+-- The legible layouts of the @abcd@ S-Expression defined above would be either
+--
+-- >>> putStrLn $ render $ pretty abcd
+-- (a b c d)
+--
+-- or
+--
+-- >>> putStrLn $ renderWith defaultOptions { optsPageWidth = 5 } $ pretty abcd
+-- (a
+--  b
+--  c
+--  d)
+--
+-- The @testData@ S-Expression is specially crafted to
+-- demonstrate general shortcomings of both Hughes and Wadler libraries.
+--
+-- >>> let abcd4 = SExpr [abcd,abcd,abcd,abcd]
+-- >>> let testData = SExpr [ SExpr [Atom "abcde", abcd4], SExpr [Atom "abcdefgh", abcd4]]
+-- >>> putStrLn $ render $ pretty testData
+-- ((abcde ((a b c d) (a b c d) (a b c d) (a b c d)))
+--  (abcdefgh ((a b c d) (a b c d) (a b c d) (a b c d))))
+--
+-- on 20-column-wide page
+--
+-- >>> putStrLn $ renderWith defaultOptions { optsPageWidth = 20 } $ pretty testData
+-- ((abcde ((a b c d)
+--          (a b c d)
+--          (a b c d)
+--          (a b c d)))
+--  (abcdefgh
+--   ((a b c d)
+--    (a b c d)
+--    (a b c d)
+--    (a b c d))))
+--
+-- Yet, neither Hughes' nor Wadler's library can deliver those results.
+--
+-- === Annotations
+--
+-- For example we can annotate every /car/ element of S-Expressions,
+-- and in the rendering phase emphasise them by rendering them in uppercase.
+--
+-- >>> let pretty' :: SExpr -> Doc Any; pretty' (Atom s) = text s; pretty' (SExpr []) = text "()"; pretty' (SExpr (x:xs)) = text "(" <> (sep $ annotate (Any True) (pretty' x) : map pretty' xs) <> text ")"
+-- >>> let render' = renderWith defaultOptions { optsAnnotate  = \a x -> if a == Any True then map toUpper x else x }
+-- >>> putStrLn $ render' $ pretty' testData
+-- ((ABCDE ((A B C D) (A B C D) (A B C D) (A B C D)))
+--  (ABCDEFGH ((A B C D) (A b c d) (A b c d) (A b c d))))
+--
 module Text.PrettyPrint.Compact (
    -- * Documents
    Doc,
@@ -10,11 +70,14 @@
    hang, encloseSep, list, tupled, semiBraces,
 
    -- * Operators
-   (<+>), ($$),
+   (<+>), ($$), (</>), (<//>), (<$$>), (<|>),
 
    -- * List combinators
    hsep, sep, hcat, vcat, cat, punctuate,
 
+   -- * Fill combiantors
+   fillSep, fillCat,
+
    -- * Bracketing combinators
    enclose, squotes, dquotes, parens, angles, braces, brackets,
 
@@ -27,28 +90,47 @@
    bool,
 
    -- * Rendering
+   renderWith,
    render,
+   Options(..),
+   defaultOptions,
 
+   -- * Annotations
+   annotate,
+
    -- * Undocumented
    -- column, nesting, width
    ) where
 
 import Data.Monoid
+import Data.List (intersperse)
 
 import Text.PrettyPrint.Compact.Core as Text.PrettyPrint.Compact
+import Text.PrettyPrint.Compact.Core (singleLine)
 
+
+-- | Render the 'Doc' into 'String' omitting all annotations.
+render :: Annotation a => Doc a -> String
+render = renderWith defaultOptions
+
+defaultOptions :: Options a String
+defaultOptions = Options
+    { optsAnnotate = \_ s -> s
+    , optsPageWidth = 80
+    }
+
 -- | The document @(list xs)@ comma separates the documents @xs@ and
 -- encloses them in square brackets. The documents are rendered
 -- horizontally if that fits the page. Otherwise they are aligned
 -- vertically. All comma separators are put in front of the elements.
-list :: [Doc] -> Doc
+list :: Annotation a => [Doc a] -> Doc a
 list            = encloseSep lbracket rbracket comma
 
 -- | The document @(tupled xs)@ comma separates the documents @xs@ and
 -- encloses them in parenthesis. The documents are rendered
 -- horizontally if that fits the page. Otherwise they are aligned
 -- vertically. All comma separators are put in front of the elements.
-tupled :: [Doc] -> Doc
+tupled :: Annotation a => [Doc a] -> Doc a
 tupled          = encloseSep lparen   rparen  comma
 
 
@@ -56,7 +138,7 @@
 -- semi colons and encloses them in braces. The documents are rendered
 -- horizontally if that fits the page. Otherwise they are aligned
 -- vertically. All semi colons are put in front of the elements.
-semiBraces :: [Doc] -> Doc
+semiBraces :: Annotation a => [Doc a] -> Doc a
 semiBraces      = encloseSep lbrace   rbrace  semi
 
 -- | The document @(enclosure l r sep xs)@ concatenates the documents
@@ -82,12 +164,12 @@
 --      ,200
 --      ,3000]
 -- @
-encloseSep :: Doc -> Doc -> Doc -> [Doc] -> Doc
+encloseSep :: Annotation a => Doc a -> Doc a -> Doc a -> [Doc a] -> Doc a
 encloseSep left right sep ds
-    = case ds of
-        []  -> left <> right
-        [d] -> left <> d <> right
-        _   -> cat (zipWith (<>) (left : repeat sep) ds) <> right
+    = (\mid -> mid <> right) $ case ds of
+        []  -> left <> mempty
+        [d] -> left <> d
+        (d:ds') -> hcat (left:intersperse (sep<>text " ") ds) <|> vcat (left <> d:map (sep <>) ds')
 
 -----------------------------------------------------------
 -- punctuate p [d1,d2,...,dn] => [d1 <> p,d2 <> p, ... ,dn]
@@ -117,7 +199,7 @@
 --
 -- (If you want put the commas in front of their elements instead of
 -- at the end, you should use 'tupled' or, in general, 'encloseSep'.)
-punctuate :: Doc -> [Doc] -> [Doc]
+punctuate :: Annotation a => Doc a -> [Doc a] -> [Doc a]
 punctuate p []      = []
 punctuate p [d]     = [d]
 punctuate p (d:ds)  = (d <> p) : punctuate p ds
@@ -132,8 +214,9 @@
 -- horizontally with @(\<+\>)@, if it fits the page, or vertically with
 -- @(\<$\>)@.
 --
-sep :: [Doc] -> Doc
+sep :: Annotation a => [Doc a] -> Doc a
 sep [] = mempty
+sep [x] = x
 sep xs = hsep xs <|> vcat xs
 
 
@@ -143,157 +226,168 @@
 -- @xs@.
 --
 -- > fillSep xs  = foldr (\<\/\>) empty xs
-fillSep :: [Doc] -> Doc
+fillSep :: Annotation a => [Doc a] -> Doc a
 fillSep         = foldDoc (</>)
 
 -- | The document @(hsep xs)@ concatenates all documents @xs@
 -- horizontally with @(\<+\>)@.
-hsep :: [Doc] -> Doc
-hsep            = foldDoc (<+>)
-
-
+hsep :: Annotation a => [Doc a] -> Doc a
+hsep            = foldDoc (<-+>)
 
 -- | The document @(cat xs)@ concatenates all documents @xs@ either
 -- horizontally with @(\<\>)@, if it fits the page, or vertically with
 -- @(\<$$\>)@.
 --
 -- > cat xs  = group (vcat xs)
-cat :: [Doc] -> Doc
+cat :: Annotation a => [Doc a] -> Doc a
 cat [] =  mempty
-cat xs = hcat xs <> vcat xs
+cat [x] = x
+cat xs = hcat xs <|> vcat xs
 
 -- | The document @(fillCat xs)@ concatenates documents @xs@
 -- horizontally with @(\<\>)@ as long as its fits the page, than inserts
 -- a @linebreak@ and continues doing that for all documents in @xs@.
 --
 -- > fillCat xs  = foldr (\<\/\/\>) empty xs
-fillCat :: [Doc] -> Doc
+fillCat :: Annotation a => [Doc a] -> Doc a
 fillCat         = foldDoc (<//>)
 
 -- | The document @(hcat xs)@ concatenates all documents @xs@
--- horizontally with @(\<\>)@.
-hcat :: [Doc] -> Doc
-hcat            = foldDoc (<>)
+-- horizontally with @(\<-\>)@.
+hcat :: Annotation a => [Doc a] -> Doc a
+hcat            = foldDoc (<->)
 
 -- | The document @(vcat xs)@ concatenates all documents @xs@
 -- vertically with @($$)@.
-vcat :: [Doc] -> Doc
+vcat :: Annotation a => [Doc a] -> Doc a
 vcat            = foldDoc ($$)
 
-foldDoc :: (Doc -> Doc -> Doc) -> [Doc] -> Doc
+foldDoc :: Annotation a => (Doc a -> Doc a -> Doc a) -> [Doc a] -> Doc a
 foldDoc _ []       = mempty
 foldDoc f ds       = foldr1 f ds
 
+-- | The document @(x \<-\> y)@ concatenates document @x@ and @y@, if
+-- @x@ fits on a single line, and fails otherwise.
+(<->) :: Annotation a => Doc a -> Doc a -> Doc a
+x <-> y         = singleLine x <> y
+
 -- | The document @(x \<+\> y)@ concatenates document @x@ and @y@ with a
 -- @space@ in between.  (infixr 6)
-(<+>) :: Doc -> Doc -> Doc
+(<+>) :: Annotation a => Doc a -> Doc a -> Doc a
 x <+> y         = x <> space <> y
 
+-- | The document @(x \<-+\> y)@ concatenates document @x@ and @y@
+-- with a @space@ in between, if @x@ fits on a single line, and fails
+-- otherwise.  (infixr 6)
+(<-+>) :: Annotation a => Doc a -> Doc a -> Doc a
+x <-+> y         = (singleLine x <> space <> y)
+
 -- | The document @(x \<\/\> y)@ puts @x@ and @y@ either next to each other
--- (with a @space@ in between) or underneath each other. (infixr 5)
-(</>) :: Doc -> Doc -> Doc
-x </> y         = ((x <> space) <|> flush x) <> y
+-- (with a @space@ in between) if @x@ fits on a single line, or underneath each other. (infixr 5)
+(</>) :: Annotation a => Doc a -> Doc a -> Doc a
+x </> y         = ((singleLine x <> space) <|> flush x) <> y
 
--- | The document @(x \<\/\/\> y)@ puts @x@ and @y@ either right next to each
--- other or underneath each other. (infixr 5)
-(<//>) :: Doc -> Doc -> Doc
-x <//> y        = (x <|> flush x) <> y
+-- | The document @(x \<\/\/\> y)@ puts @x@ and @y@ either right next
+-- to each other (if @x@ fits on a single line) or underneath each
+-- other. (infixr 5)
+(<//>) :: Annotation a => Doc a -> Doc a -> Doc a
+x <//> y        = (singleLine x <|> flush x) <> y
 
 
 -- | The document @(x \<$$\> y)@ concatenates document @x@ and @y@ with
 -- a linebreak in between. (infixr 5)
-(<$$>) :: Doc -> Doc -> Doc
+(<$$>) :: Annotation a => Doc a -> Doc a -> Doc a
 x <$$> y = flush x <> y
 
 
 -- | Document @(squotes x)@ encloses document @x@ with single quotes
 -- \"'\".
-squotes :: Doc -> Doc
+squotes :: Annotation a => Doc a -> Doc a
 squotes         = enclose squote squote
 
 -- | Document @(dquotes x)@ encloses document @x@ with double quotes
 -- '\"'.
-dquotes :: Doc -> Doc
+dquotes :: Annotation a => Doc a -> Doc a
 dquotes         = enclose dquote dquote
 
 -- | Document @(braces x)@ encloses document @x@ in braces, \"{\" and
 -- \"}\".
-braces :: Doc -> Doc
+braces :: Annotation a => Doc a -> Doc a
 braces          = enclose lbrace rbrace
 
 -- | Document @(parens x)@ encloses document @x@ in parenthesis, \"(\"
 -- and \")\".
-parens :: Doc -> Doc
+parens :: Annotation a => Doc a -> Doc a
 parens          = enclose lparen rparen
 
 -- | Document @(angles x)@ encloses document @x@ in angles, \"\<\" and
 -- \"\>\".
-angles :: Doc -> Doc
+angles :: Annotation a => Doc a -> Doc a
 angles          = enclose langle rangle
 
 -- | Document @(brackets x)@ encloses document @x@ in square brackets,
 -- \"[\" and \"]\".
-brackets :: Doc -> Doc
+brackets :: Annotation a => Doc a -> Doc a
 brackets        = enclose lbracket rbracket
 
 -- | The document @(enclose l r x)@ encloses document @x@ between
 -- documents @l@ and @r@ using @(\<\>)@.
-enclose :: Doc -> Doc -> Doc -> Doc
+enclose :: Annotation a => Doc a -> Doc a -> Doc a -> Doc a
 enclose l r x   = l <> x <> r
 
-char :: Char -> Doc
+char :: Annotation a => Char -> Doc a
 char x = text [x]
 
 -- | The document @lparen@ contains a left parenthesis, \"(\".
-lparen :: Doc
+lparen :: Annotation a => Doc a
 lparen          = char '('
 -- | The document @rparen@ contains a right parenthesis, \")\".
-rparen :: Doc
+rparen :: Annotation a => Doc a
 rparen          = char ')'
 -- | The document @langle@ contains a left angle, \"\<\".
-langle :: Doc
+langle :: Annotation a => Doc a
 langle          = char '<'
 -- | The document @rangle@ contains a right angle, \">\".
-rangle :: Doc
+rangle :: Annotation a => Doc a
 rangle          = char '>'
 -- | The document @lbrace@ contains a left brace, \"{\".
-lbrace :: Doc
+lbrace :: Annotation a => Doc a
 lbrace          = char '{'
 -- | The document @rbrace@ contains a right brace, \"}\".
-rbrace :: Doc
+rbrace :: Annotation a => Doc a
 rbrace          = char '}'
 -- | The document @lbracket@ contains a left square bracket, \"[\".
-lbracket :: Doc
+lbracket :: Annotation a => Doc a
 lbracket        = char '['
 -- | The document @rbracket@ contains a right square bracket, \"]\".
-rbracket :: Doc
+rbracket :: Annotation a => Doc a
 rbracket        = char ']'
 
 
 -- | The document @squote@ contains a single quote, \"'\".
-squote :: Doc
+squote :: Annotation a => Doc a
 squote          = char '\''
 -- | The document @dquote@ contains a double quote, '\"'.
-dquote :: Doc
+dquote :: Annotation a => Doc a
 dquote          = char '"'
 -- | The document @semi@ contains a semi colon, \";\".
-semi :: Doc
+semi :: Annotation a => Doc a
 semi            = char ';'
 -- | The document @colon@ contains a colon, \":\".
-colon :: Doc
+colon :: Annotation a => Doc a
 colon           = char ':'
 -- | The document @comma@ contains a comma, \",\".
-comma :: Doc
+comma :: Annotation a => Doc a
 comma           = char ','
 
 -- | The document @dot@ contains a single dot, \".\".
-dot :: Doc
+dot :: Annotation a => Doc a
 dot             = char '.'
 -- | The document @backslash@ contains a back slash, \"\\\".
-backslash :: Doc
+backslash :: Annotation a => Doc a
 backslash       = char '\\'
 -- | The document @equals@ contains an equal sign, \"=\".
-equals :: Doc
+equals :: Annotation a => Doc a
 equals          = char '='
 
 -----------------------------------------------------------
@@ -306,35 +400,35 @@
 -- using @line@ for newline characters and @char@ for all other
 -- characters. It is used instead of 'text' whenever the text contains
 -- newline characters.
-string :: String -> Doc
+string :: Annotation a => String -> Doc a
 string = vcat . map text . lines
 
-bool :: Bool -> Doc
+bool :: Annotation a => Bool -> Doc a
 bool b          = text (show b)
 
 -- | The document @(int i)@ shows the literal integer @i@ using
 -- 'text'.
-int :: Int -> Doc
+int :: Annotation a => Int -> Doc a
 int i           = text (show i)
 
 -- | The document @(integer i)@ shows the literal integer @i@ using
 -- 'text'.
-integer :: Integer -> Doc
+integer :: Annotation a => Integer -> Doc a
 integer i       = text (show i)
 
 -- | The document @(float f)@ shows the literal float @f@ using
 -- 'text'.
-float :: Float -> Doc
+float :: Annotation a => Float -> Doc a
 float f         = text (show f)
 
 -- | The document @(double d)@ shows the literal double @d@ using
 -- 'text'.
-double :: Double -> Doc
+double :: Annotation a => Double -> Doc a
 double d        = text (show d)
 
 -- | The document @(rational r)@ shows the literal rational @r@ using
 -- 'text'.
-rational :: Rational -> Doc
+rational :: Annotation a => Rational -> Doc a
 rational r      = text (show r)
 
 
@@ -358,10 +452,9 @@
 -- The @hang@ combinator is implemented as:
 --
 -- > hang i x  = align (nest i x)
-hang :: Int -> Doc -> Doc -> Doc
+hang :: Annotation a => Int -> Doc a -> Doc a -> Doc a
 hang n x y = (x <+> y) <|> (x $$ nest' n y)
 
-
 -- | The document @(nest i x)@ renders document @x@ with the current
 -- indentation level increased by i (See also 'hang', 'align' and
 -- 'indent').
@@ -377,13 +470,21 @@
 -- @
 
 
+space :: Annotation a => Doc a
 space = text " "
 
 
+nest' :: Annotation a => Int -> Doc a -> Doc a
 nest' n x = spaces n <> x
 
-spaces :: Int -> Doc
+spaces :: Annotation a => Int -> Doc a
 spaces n = text $ replicate n ' '
 
-($$) :: Doc -> Doc -> Doc
-a $$ b = flush a <> b
+-- | The document @(x \<$$\> y)@ concatenates document @x@ and @y@ with
+-- a linebreak in between. (infixr 5)
+($$) :: Annotation a => Doc a -> Doc a -> Doc a
+($$)  = (<$$>)
+
+-- $setup
+-- >>> import Data.Monoid
+-- >>> import Data.Char
diff --git a/Text/PrettyPrint/Compact/Core.hs b/Text/PrettyPrint/Compact/Core.hs
--- a/Text/PrettyPrint/Compact/Core.hs
+++ b/Text/PrettyPrint/Compact/Core.hs
@@ -1,124 +1,286 @@
-{-# LANGUAGE ScopedTypeVariables, TypeSynonymInstances, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, ViewPatterns #-}
-module Text.PrettyPrint.Compact.Core(Layout(..),Document(..),Doc) where
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables, TypeSynonymInstances, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, ViewPatterns, DeriveFunctor, DeriveFoldable, DeriveTraversable, LambdaCase #-}
+module Text.PrettyPrint.Compact.Core(Annotation,Layout(..),renderWith,Options(..),Document(..),Doc,singleLine) where
 
-import Data.List (intercalate,sort,groupBy)
+import Prelude ()
+import Prelude.Compat as P
+
+import Data.List.Compat (sortOn,groupBy,minimumBy)
 import Data.Function (on)
-import Data.Monoid
-import Data.Sequence (singleton, Seq, viewl, viewr, ViewL(..), ViewR(..))
-import qualified Data.Sequence as S
+import Data.Semigroup
+import Data.Sequence (singleton, Seq, viewl, viewr, ViewL(..), ViewR(..), (|>))
+import Data.String
+import Data.Foldable (toList)
 
+-- | Annotated string, which consists of segments with separate (or no) annotations.
+--
+-- We keep annotated segments in a container (list).
+-- The annotation is @Maybe a@, because the no-annotation case is common.
+--
+-- /Note:/ with @Last x@ annotation, the 'annotate' will overwrite all annotations.
+--
+-- /Note:/ if the list is changed into `Seq` or similar structure
+-- allowing fast viewr and viewl, then we can impose an additional
+-- invariant that there aren't two consequtive non-annotated segments;
+-- yet there is no performance reason to do so.
+--
+data AS a = AS !Int [(a, String)]
+  deriving (Eq,Ord,Show,Functor,Foldable,Traversable)
 
+-- | Tests the invariants of 'AS'
+_validAs :: AS a -> Bool
+_validAs (AS i s) = lengthInvariant && noNewlineInvariant
+  where
+    lengthInvariant = i == sum (map (length . snd) s)
+    noNewlineInvariant = all (notElem '\n' . snd) s
 
-newtype L = L (Seq String) -- non-empty sequence
-  deriving (Eq,Ord)
+asLength :: AS a -> Int
+asLength (AS l _) = l
 
-instance Monoid L where
-   mempty = L (singleton "")
-   L (viewr -> xs :> x) `mappend` L (viewl -> y :< ys) = L (xs <> singleton (x ++ y) <> fmap (indent ++) ys)
-      where n = length x
-            indent = Prelude.replicate n ' '
+-- | Make a non-annotated 'AS'.
+mkAS :: Monoid a => String -> AS a
+mkAS s = AS (length s) [(mempty, s)]
 
-newtype N = N {fromN :: String}
-instance Monoid N where
-  mempty = N ""
-  mappend (N x) (N y) = N (x ++ "\n" ++ y)
+instance Semigroup (AS a) where
+  AS i xs <> AS j ys = AS (i + j) (xs <> ys)
+
+newtype L a = L (Seq (AS a)) -- non-empty sequence
+  deriving (Eq,Ord,Show,Functor,Foldable,Traversable)
+
+instance Monoid a => Semigroup (L a) where
+  L (viewr -> xs :> x) <> L (viewl -> y :< ys) = L (xs <> singleton (x <> y) <> fmap (indent <>) ys)
+      where n = asLength x
+            indent = mkAS (P.replicate n ' ')
+  L _ <> L _ = error "<> @L: invariant violated, Seq is empty"
+
+instance Monoid a => Monoid (L a) where
+   mempty = L (singleton (mkAS ""))
+   mappend = (<>)
+
 instance Layout L where
-   render (L xs) = fromN $ foldMap N xs
-   text = L . singleton
-   flush (L xs) = L (xs <> singleton "")
+   text = L . singleton . mkAS
+   flush (L xs) = L (xs |> mkAS "")
+   annotate a (L s') = L (fmap annotateAS s')
+      where annotateAS (AS i s) = AS i (fmap annotatePart s)
+            annotatePart (b, s) = (b `mappend` a, s)
 
 
-class Monoid d => Layout d where
-  text :: String -> d
-  flush :: d -> d
-  render :: d -> String
+renderWithL :: (Monoid a, Monoid r) => Options a r -> L a -> r
+renderWithL opts (L xs) = intercalate (toList xs)
+  where
+    f = optsAnnotate opts
+    f' (AS _ s) = foldMap (uncurry f) s
+    sep = f mempty "\n"
 
+    intercalate []     = mempty
+    intercalate (y:ys) = f' y `mappend` foldMap (mappend sep . f') ys
+
+data Options a r = Options
+    { optsPageWidth :: !Int              -- ^ maximum page width
+    , optsAnnotate  :: a -> String -> r  -- ^ how to annotate the string. /Note:/ the annotation should preserve the visible length of the string.
+    }
+
+class Layout d where
+  text :: Monoid a => String -> d a
+  flush :: Monoid a => d a -> d a
+  -- | `<>` new annotation to the 'Doc'.
+  --
+  -- Example: 'Any True' annotation will transform the rendered 'Doc' into uppercase:
+  --
+  -- >>> let r = putStrLn . renderWith defaultOptions { optsAnnotate = \a x -> if a == Any True then map toUpper x else x }
+  -- >>> r $ text "hello" <$$> annotate (Any True) (text "world")
+  -- hello
+  -- WORLD
+  --
+  annotate :: forall a. Monoid a => a -> d a -> d a
+
 class Layout d => Document d where
-  (<|>) :: d -> d -> d
+  (<|>) :: Eq a => d a -> d a -> d a
+  empty :: d a
 
-data M = M {height    :: Int,
-            lastWidth :: Int,
-            maxWidth  :: Int
-            }
-  deriving (Show,Eq,Ord)
+-- | type parameter is phantom.
+data M a = M {height    :: Int,
+              lastWidth :: Int,
+              maxWidth  :: Int
+              }
+  deriving (Show,Eq,Ord,Functor,Foldable,Traversable)
 
-instance Monoid M where
-  mempty = text ""
-  a `mappend` b =
+instance Semigroup (M a) where
+  a <> b =
     M {maxWidth = max (maxWidth a) (maxWidth b + lastWidth a),
        height = height a + height b,
        lastWidth = lastWidth a + lastWidth b}
 
+instance Monoid a => Monoid (M a) where
+  mempty = text ""
+  mappend = (<>)
+
 instance Layout M where
   text s = M {height = 0, maxWidth = length s, lastWidth = length s}
   flush a = M {maxWidth = maxWidth a,
                height = height a + 1,
                lastWidth = 0}
-  render = error "don't use this render"
-
-fits :: M -> Bool
-fits x = maxWidth x <= 80
-
+  annotate _ M{..} = M{..}
 class Poset a where
   (≺) :: a -> a -> Bool
 
 
-instance Poset M where
+instance Poset (M a) where
   M c1 l1 s1 ≺ M c2 l2 s2 = c1 <= c2 && l1 <= l2 && s1 <= s2
 
+mergeOn :: Ord b => (a -> b) -> [a] -> [a] -> [a]
+mergeOn m = go
+  where
+    go [] xs = xs
+    go xs [] = xs
+    go (x:xs) (y:ys)
+      | m x <= m y  = x:go xs (y:ys)
+      | otherwise    = y:go (x:xs) ys
 
+mergeAllOn :: Ord b => (a -> b) -> [[a]] -> [a]
+mergeAllOn _ [] = []
+mergeAllOn m (x:xs) = mergeOn m x (mergeAllOn m xs)
 
-merge :: Ord a => [a] -> [a] -> [a]
-merge [] xs = xs
-merge xs [] = xs
-merge (x:xs) (y:ys)
-  | x <= y = x:merge xs (y:ys)
-  | otherwise = y:merge (x:xs) ys
+bestsOn :: forall a b. (Poset b, Ord b)
+      => (a -> b) -- ^ measure
+      -> [[a]] -> [a]
+bestsOn m = paretoOn' m [] . mergeAllOn m
 
+-- | @paretoOn m = paretoOn' m []@
+paretoOn' :: Poset b => (a -> b) -> [a] -> [a] -> [a]
+paretoOn' _ acc [] = P.reverse acc
+paretoOn' m acc (x:xs) = if any ((≺ m x) . m) acc
+                            then paretoOn' m acc xs
+                            else paretoOn' m (x:acc) xs
+                            -- because of the ordering, we have that
+                            -- for all y ∈ acc, y <= x, and thus x ≺ y
+                            -- is false. No need to refilter acc.
 
-mergeAll :: Ord a => [[a]] -> [a]
-mergeAll [] = []
-mergeAll (x:xs) = merge x (mergeAll xs)
+-- list sorted by lexicographic order for the first component
+-- function argument is the page width
+newtype ODoc a = MkDoc {fromDoc :: Int -> [(Pair M L a)]}
 
-bests :: forall a. (Ord a, Poset a) => [[a]] -> [a]
-bests = pareto' [] . mergeAll
+instance Monoid a => Semigroup (ODoc a) where
+  MkDoc xs <> MkDoc ys = MkDoc $ \w -> bestsOn frst [ discardInvalid w [x <> y | y <- ys w] | x <- xs w]
 
-pareto' :: Poset a => [a] -> [a] -> [a]
-pareto' acc [] = Prelude.reverse acc
-pareto' acc (x:xs) = if any (≺ x) acc
-                       then pareto' acc xs
-                       else pareto' (x:acc) xs
+discardInvalid w = quasifilter (fits w . frst)
 
+quasifilter _ [] = []
+quasifilter p zs = let fzs = filter p zs
+                   in if null fzs -- in case that there are no valid layouts, we take a narrow one.
+                      then [minimumBy (compare `on` (maxWidth . frst)) zs]
+                      else fzs
 
-newtype Doc = MkDoc [(M,L)]
+instance Monoid a => Monoid (ODoc a) where
+  mempty = text ""
+  mappend = (<>)
 
-quasifilter :: (a -> Bool) -> [a] -> [a]
-quasifilter p xs = let fxs = filter p xs in if null fxs then take 1 xs else fxs
+-- TODO: make columns configurable
+fits :: Int -> M a -> Bool
+fits w x = maxWidth x <= w
 
-instance Monoid Doc where
+instance Layout ODoc where
+  flush (MkDoc xs) = MkDoc $ \w -> bestsOn frst $ map (sortOn frst) $ groupBy ((==) `on` (height . frst)) $ (map flush (xs w))
+  -- flush xs = paretoOn' fst [] $ sort $ (map flush xs)
+  text s = MkDoc $ \w -> [text s]
+  annotate a (MkDoc xs) = MkDoc $ \w -> fmap (annotate a) (xs w)
+
+renderWith :: (Monoid r,  Monoid a, Eq a)
+           => Options a r  -- ^ rendering options
+           -> Doc a          -- ^ renderable
+           -> r
+renderWith opts d = case xs of
+    [] -> error "No suitable layout found."
+    ((_ :-: x):_) -> renderWithL opts x
+  where
+    pageWidth = optsPageWidth opts
+    xs = discardInvalid pageWidth (fromDoc (interp d) pageWidth)
+
+instance Document ODoc where
+  MkDoc m1 <|> MkDoc m2 = MkDoc $ \w -> bestsOn frst [m1 w,m2 w]
+  empty = MkDoc $ \_ -> []
+
+data Pair f g a = (:-:) {frst :: f a, scnd :: g a}
+
+instance (Semigroup (f a), Semigroup (g a)) => Semigroup (Pair f g a) where
+  (x :-: y) <> (x' :-: y') = (x <> x') :-: (y <> y')
+instance (Monoid (f a), Monoid (g a)) => Monoid (Pair f g a) where
+  mempty = mempty :-: mempty
+  mappend (x :-: y)(x' :-: y') = (x `mappend` x') :-: (y `mappend` y')
+
+instance (Layout a, Layout b) => Layout (Pair a b) where
+  text s = text s :-: text s
+  flush (a:-:b) = (flush a:-: flush b)
+  annotate x (a:-:b) = (annotate x a:-:annotate x b)
+
+instance Monoid a => IsString (Doc a) where
+  fromString = text
+
+data DDoc a = Text String | Flush (DDoc a) | S (Seq (DDoc a)) | DDoc a :<|> DDoc a | Fail | Annotate a (DDoc a)
+  deriving Eq
+
+type Annotation a = (Eq a, Monoid a)
+
+interp :: Annotation a => DDoc a -> ODoc a
+interp = \case
+  Text s -> text s
+  Flush d -> flush (interp d)
+  Fail -> empty
+  S ds -> foldMap interp $ catTexts $ toList ds
+  d :<|> e -> interp d <|> interp e
+  Annotate a d -> annotate a (interp d)
+
+
+catTexts :: forall a. [DDoc a] -> [DDoc a]
+catTexts (Text t:Text u:xs) = catTexts (Text (t<>u):xs)
+catTexts (x:xs) = x:catTexts xs
+catTexts [] = []
+
+instance Semigroup (DDoc a) where
+  Fail <> _ = Fail
+  _ <> Fail = Fail
+  S as <> S bs = S (as <> bs)
+  S as <> b = S (as <> singleton b)
+  a <> S bs = S (singleton a <> bs)
+  a <> b = S (singleton a <> singleton b)
+
+instance Monoid a => Monoid (DDoc a) where
   mempty = text ""
-  MkDoc xs `mappend` MkDoc ys = MkDoc $ bests [ quasifilter (fits . fst) [x <> y | y <- ys] | x <- xs]
+  mappend = (<>)
 
-instance Layout Doc where
-  flush (MkDoc xs) = MkDoc $ bests $ map sort $ groupBy ((==) `on` (height . fst)) $ (map flush xs)
-  -- flush xs = pareto' [] $ sort $ (map flush xs)
-  text s = MkDoc [text s]
-  render (MkDoc []) = error "No suitable layout found."
-  render (MkDoc (x:_)) = render x
+instance Layout DDoc where
+  text = Text
+  flush (Flush x) = Flush x
+  flush x = Flush x
+  annotate = Annotate -- can be pushed down to text. Is this a good idea? (Note it'll get rid of complications in the classes, etc.)
 
-instance Document Doc where
-  MkDoc m1 <|> MkDoc m2 = MkDoc (bests [m1,m2])
+instance Document DDoc where
+  S (viewl -> a :< as) <|> S (viewl -> b :< bs) | a == b = a <> (S as <|> S bs)
+  S (viewr -> as :> a) <|> S (viewr -> bs :> b) | a == b = (S as <|> S bs) <> a
+  Flush a <|> Flush b = Flush (a <|> b)
+  Annotate a b <|> Annotate a' d | a == a' = Annotate a' (b <|> d)
+  a <|> b = a <||> b
+  empty = Fail
 
+(<||>) :: forall a. DDoc a -> DDoc a -> DDoc a
+a <||> Fail = a
+Fail <||> a = a
+a <||> b = a :<|> b
 
---  (a,b) `mappend` (c,d) = (a<>c ,b<>d)
 
-instance (Layout a, Layout b) => Layout (a,b) where
-  text s = (text s, text s)
-  flush (a,b) = (flush a, flush b)
-  render = render . snd
+singleLine :: forall a. Monoid a => DDoc a -> DDoc a
+singleLine (Flush _) = Fail
+singleLine (Annotate a d) = Annotate a (singleLine d)
+singleLine (Text s) = Text s
+singleLine (a :<|> b) = singleLine a <||> singleLine b
+singleLine Fail = Fail
+singleLine (S xs) = foldMap singleLine xs
 
-instance (Document a, Document b) => Document (a,b) where
-  (a,b) <|> (c,d) = (a<|>c,b<|>d)
+type Doc = DDoc
 
-instance (Poset a) => Poset (a,b) where
-  (a,_) ≺ (b,_) = a ≺ b
+
+-- $setup
+-- >>> import Text.PrettyPrint.Compact
+-- >>> import Data.Monoid
+-- >>> import Data.Char
diff --git a/bench/Benchmark.hs b/bench/Benchmark.hs
new file mode 100644
--- /dev/null
+++ b/bench/Benchmark.hs
@@ -0,0 +1,85 @@
+module Main (main) where
+
+import Prelude ()
+import Prelude.Compat
+
+import Control.DeepSeq (force)
+import Control.Exception (evaluate)
+import Data.Aeson (Value (..), decode)
+import Data.Foldable (toList)
+
+import qualified Criterion.Main as C
+import qualified Data.HashMap.Lazy as H
+import qualified Data.ByteString.Lazy as BSL
+import qualified Data.Text.Lazy as TL
+import qualified Data.Text.Lazy.Builder as TLB
+
+import qualified Text.PrettyPrint.Compact  as PC
+import qualified Text.PrettyPrint.HughesPJ as HPJ
+import qualified Text.PrettyPrint.Leijen   as WL
+
+prettiestJSON :: Value -> PC.Doc ()
+prettiestJSON (Bool True)  = PC.text "true"
+prettiestJSON (Bool False) = PC.text "false"
+prettiestJSON (Object o)   = PC.encloseSep (PC.text "{") (PC.text "}") (PC.text ",") (map prettyKV $ H.toList o)
+  where prettyKV (k,v)     = PC.text (show k) PC.<> PC.text ":" PC.<+> prettiestJSON v
+prettiestJSON (String s)   = PC.string (show s)
+prettiestJSON (Array a)    = PC.encloseSep (PC.text "[") (PC.text "]") (PC.text ",") (map prettiestJSON $ toList a)
+prettiestJSON Null         = PC.mempty
+prettiestJSON (Number n)   = PC.text (show n)
+
+pcRenderText :: Monoid a => PC.Doc a -> TL.Text
+pcRenderText = TLB.toLazyText . PC.renderWith PC.defaultOptions
+    { PC.optsAnnotate = \_ -> TLB.fromString }
+
+wlJSON :: Value -> WL.Doc
+wlJSON (Bool True)     = WL.text "true"
+wlJSON (Bool False)    = WL.text "false"
+wlJSON (Object o)      = WL.encloseSep (WL.text "{") (WL.text "}") (WL.text ",") (map prettyKV $ H.toList o)
+  where prettyKV (k,v) = WL.text (show k) WL.<> WL.text ":" WL.<+> wlJSON v
+wlJSON (String s)      = WL.string (show s)
+wlJSON (Array a)       = WL.encloseSep (WL.text "[") (WL.text "]") (WL.text ",") (map wlJSON $ toList a)
+wlJSON Null            = WL.empty
+wlJSON (Number n)      = WL.text (show n)
+
+wlRender :: WL.Doc -> String
+wlRender d = WL.displayS (WL.renderPretty 1 80 d) ""
+
+hpjEncloseSep :: HPJ.Doc -> HPJ.Doc -> HPJ.Doc -> [HPJ.Doc] -> HPJ.Doc
+hpjEncloseSep open close sep list = open HPJ.<> HPJ.sep (HPJ.punctuate sep list) HPJ.<> close
+
+hpjJSON :: Value -> HPJ.Doc
+hpjJSON (Bool True)    = HPJ.text "true"
+hpjJSON (Bool False)   = HPJ.text "false"
+hpjJSON (Object o)     = hpjEncloseSep (HPJ.text "{") (HPJ.text "}") (HPJ.text ",") (map prettyKV $ H.toList o)
+  where prettyKV (k,v) = HPJ.text (show k) HPJ.<> HPJ.text ":" HPJ.<+> hpjJSON v
+hpjJSON (String s)     = HPJ.text (show s)
+hpjJSON (Array a)      = hpjEncloseSep (HPJ.text "[") (HPJ.text "]") (HPJ.text ",") (map hpjJSON $ toList a)
+hpjJSON Null           = HPJ.empty
+hpjJSON (Number n)     = HPJ.text (show n)
+
+readJSONValue :: FilePath -> IO Value
+readJSONValue fname = do
+    contents <- BSL.readFile fname
+    let Just inpJson = decode contents
+    return inpJson
+
+main :: IO ()
+main = do
+    smallValue <- evaluate . force =<< readJSONValue "bench/small.json"
+    bigValue <- evaluate . force =<< readJSONValue "bench/big.json"
+
+    C.defaultMain
+        [ C.bgroup "small"
+            [ C.bench "pretty-compact" $ C.nf (PC.render . prettiestJSON) smallValue
+            , C.bench "pretty-compact Text" $ C.nf (pcRenderText . prettiestJSON) smallValue
+            , C.bench "pretty"         $ C.nf (HPJ.render . hpjJSON) smallValue
+            , C.bench "wl-pprint"      $ C.nf (wlRender . wlJSON) smallValue
+            ]
+        , C.bgroup "big"
+            [ C.bench "pretty-compact" $ C.nf (PC.render . prettiestJSON) bigValue
+            , C.bench "pretty-compact Text" $ C.nf (pcRenderText . prettiestJSON) bigValue
+            , C.bench "pretty"         $ C.nf (HPJ.render . hpjJSON) bigValue 
+            , C.bench "wl-pprint"      $ C.nf (wlRender . wlJSON) bigValue
+            ]
+        ]
diff --git a/pretty-compact.cabal b/pretty-compact.cabal
--- a/pretty-compact.cabal
+++ b/pretty-compact.cabal
@@ -1,5 +1,5 @@
 name: pretty-compact
-version: 2.0
+version: 2.1
 synopsis: Pretty-printing library
 description:
   This package contains a pretty-printing library, a set of API's
@@ -16,6 +16,13 @@
 maintainer: Jean-Philippe Bernardy <jeanphilippe.bernardy@gmail.com>
 build-type: Simple
 Cabal-Version: >= 1.8
+tested-with:
+  GHC == 7.4.2,
+  GHC == 7.6.3,
+  GHC == 7.8.4,
+  GHC == 7.10.3,
+  GHC == 8.0.2,
+  GHC == 8.2.1
 
 source-repository head
                   type: git
@@ -23,9 +30,30 @@
 
 
 Library
-        exposed-modules:
-                Text.PrettyPrint.Compact
-                Text.PrettyPrint.Compact.Core
-        build-depends:
-                      base >= 3 && < 5,
-                      containers
+  exposed-modules:
+    Text.PrettyPrint.Compact
+    Text.PrettyPrint.Compact.Core
+  build-depends:
+    base >= 3 && < 5,
+    base-compat >= 0.9.3 && <0.10,
+    containers
+
+  if !impl(ghc >= 8.0)
+    build-depends: semigroups
+
+benchmark pretty-comparison
+  type: exitcode-stdio-1.0
+  hs-source-dirs: bench
+  main-is: Benchmark.hs
+  build-depends:
+    aeson,
+    base,
+    base-compat,
+    bytestring,
+    criterion,
+    deepseq,
+    pretty,
+    pretty-compact,
+    text,
+    unordered-containers,
+    wl-pprint