From cc269e6b0b615e9e237c35a985e4ace7b9ab0dd9 Mon Sep 17 00:00:00 2001
From: Mateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk>
Date: Mon, 5 May 2014 09:01:03 +0200
Subject: Move parser + parser tests out to own package.

We move some types out that are necessary as well and then
re-export and specialise them in the core Haddock.

Reason for moving out spec tests is that if we're working on the parser,
we can simply work on that and we can ignore the rest of Haddock. The
downside is that it's a little inconvenient if at the end of the day we
want to see that everything passes.
---
 haddock-library/src/Documentation/Haddock/Doc.hs | 60 ++++++++++++++++++++++++
 1 file changed, 60 insertions(+)
 create mode 100644 haddock-library/src/Documentation/Haddock/Doc.hs

(limited to 'haddock-library/src/Documentation/Haddock/Doc.hs')

diff --git a/haddock-library/src/Documentation/Haddock/Doc.hs b/haddock-library/src/Documentation/Haddock/Doc.hs
new file mode 100644
index 00000000..4d6c10a4
--- /dev/null
+++ b/haddock-library/src/Documentation/Haddock/Doc.hs
@@ -0,0 +1,60 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Documentation.Haddock.Doc (docParagraph) where
+
+import Data.Monoid
+import Documentation.Haddock.Types
+import Data.Char (isSpace)
+
+-- We put it here so that we can avoid a circular import
+-- anything relevant imports this module anyway
+instance Monoid (DocH mod id) where
+  mempty  = DocEmpty
+  mappend = docAppend
+
+docAppend :: DocH mod id -> DocH mod id -> DocH mod id
+docAppend (DocDefList ds1) (DocDefList ds2) = DocDefList (ds1++ds2)
+docAppend (DocDefList ds1) (DocAppend (DocDefList ds2) d) = DocAppend (DocDefList (ds1++ds2)) d
+docAppend (DocOrderedList ds1) (DocOrderedList ds2) = DocOrderedList (ds1 ++ ds2)
+docAppend (DocUnorderedList ds1) (DocUnorderedList ds2) = DocUnorderedList (ds1 ++ ds2)
+docAppend DocEmpty d = d
+docAppend d DocEmpty = d
+docAppend (DocString s1) (DocString s2) = DocString (s1 ++ s2)
+docAppend (DocAppend d (DocString s1)) (DocString s2) = DocAppend d (DocString (s1 ++ s2))
+docAppend (DocString s1) (DocAppend (DocString s2) d) = DocAppend (DocString (s1 ++ s2)) d
+docAppend d1 d2 = DocAppend d1 d2
+
+-- again to make parsing easier - we spot a paragraph whose only item
+-- is a DocMonospaced and make it into a DocCodeBlock
+docParagraph :: DocH mod id -> DocH mod id
+docParagraph (DocMonospaced p)
+  = DocCodeBlock (docCodeBlock p)
+docParagraph (DocAppend (DocString s1) (DocMonospaced p))
+  | all isSpace s1
+  = DocCodeBlock (docCodeBlock p)
+docParagraph (DocAppend (DocString s1)
+    (DocAppend (DocMonospaced p) (DocString s2)))
+  | all isSpace s1 && all isSpace s2
+  = DocCodeBlock (docCodeBlock p)
+docParagraph (DocAppend (DocMonospaced p) (DocString s2))
+  | all isSpace s2
+  = DocCodeBlock (docCodeBlock p)
+docParagraph p
+  = DocParagraph p
+
+
+-- Drop trailing whitespace from @..@ code blocks.  Otherwise this:
+--
+--    -- @
+--    -- foo
+--    -- @
+--
+-- turns into (DocCodeBlock "\nfoo\n ") which when rendered in HTML
+-- gives an extra vertical space after the code block.  The single space
+-- on the final line seems to trigger the extra vertical space.
+--
+docCodeBlock :: DocH mod id -> DocH mod id
+docCodeBlock (DocString s)
+  = DocString (reverse $ dropWhile (`elem` " \t") $ reverse s)
+docCodeBlock (DocAppend l r)
+  = DocAppend l (docCodeBlock r)
+docCodeBlock d = d
-- 
cgit v1.2.3