diff --git a/COPYING b/COPYING deleted file mode 100644 --- a/COPYING +++ /dev/null @@ -1,340 +0,0 @@ - GNU GENERAL PUBLIC LICENSE - Version 2, June 1991 - - Copyright (C) 1989, 1991 Free Software Foundation, Inc. - 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA - Everyone is permitted to copy and distribute verbatim copies - of this license document, but changing it is not allowed. - - Preamble - - The licenses for most software are designed to take away your -freedom to share and change it. By contrast, the GNU General Public -License is intended to guarantee your freedom to share and change free -software--to make sure the software is free for all its users. This -General Public License applies to most of the Free Software -Foundation's software and to any other program whose authors commit to -using it. (Some other Free Software Foundation software is covered by -the GNU Library General Public License instead.) You can apply it to -your programs, too. - - When we speak of free software, we are referring to freedom, not -price. Our General Public Licenses are designed to make sure that you -have the freedom to distribute copies of free software (and charge for -this service if you wish), that you receive source code or can get it -if you want it, that you can change the software or use pieces of it -in new free programs; and that you know you can do these things. - - To protect your rights, we need to make restrictions that forbid -anyone to deny you these rights or to ask you to surrender the rights. -These restrictions translate to certain responsibilities for you if you -distribute copies of the software, or if you modify it. - - For example, if you distribute copies of such a program, whether -gratis or for a fee, you must give the recipients all the rights that -you have. You must make sure that they, too, receive or can get the -source code. And you must show them these terms so they know their -rights. - - We protect your rights with two steps: (1) copyright the software, and -(2) offer you this license which gives you legal permission to copy, -distribute and/or modify the software. - - Also, for each author's protection and ours, we want to make certain -that everyone understands that there is no warranty for this free -software. If the software is modified by someone else and passed on, we -want its recipients to know that what they have is not the original, so -that any problems introduced by others will not reflect on the original -authors' reputations. - - Finally, any free program is threatened constantly by software -patents. We wish to avoid the danger that redistributors of a free -program will individually obtain patent licenses, in effect making the -program proprietary. To prevent this, we have made it clear that any -patent must be licensed for everyone's free use or not licensed at all. - - The precise terms and conditions for copying, distribution and -modification follow. - - GNU GENERAL PUBLIC LICENSE - TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION - - 0. This License applies to any program or other work which contains -a notice placed by the copyright holder saying it may be distributed -under the terms of this General Public License. The "Program", below, -refers to any such program or work, and a "work based on the Program" -means either the Program or any derivative work under copyright law: -that is to say, a work containing the Program or a portion of it, -either verbatim or with modifications and/or translated into another -language. (Hereinafter, translation is included without limitation in -the term "modification".) Each licensee is addressed as "you". - -Activities other than copying, distribution and modification are not -covered by this License; they are outside its scope. The act of -running the Program is not restricted, and the output from the Program -is covered only if its contents constitute a work based on the -Program (independent of having been made by running the Program). -Whether that is true depends on what the Program does. - - 1. You may copy and distribute verbatim copies of the Program's -source code as you receive it, in any medium, provided that you -conspicuously and appropriately publish on each copy an appropriate -copyright notice and disclaimer of warranty; keep intact all the -notices that refer to this License and to the absence of any warranty; -and give any other recipients of the Program a copy of this License -along with the Program. - -You may charge a fee for the physical act of transferring a copy, and -you may at your option offer warranty protection in exchange for a fee. - - 2. You may modify your copy or copies of the Program or any portion -of it, thus forming a work based on the Program, and copy and -distribute such modifications or work under the terms of Section 1 -above, provided that you also meet all of these conditions: - - a) You must cause the modified files to carry prominent notices - stating that you changed the files and the date of any change. - - b) You must cause any work that you distribute or publish, that in - whole or in part contains or is derived from the Program or any - part thereof, to be licensed as a whole at no charge to all third - parties under the terms of this License. - - c) If the modified program normally reads commands interactively - when run, you must cause it, when started running for such - interactive use in the most ordinary way, to print or display an - announcement including an appropriate copyright notice and a - notice that there is no warranty (or else, saying that you provide - a warranty) and that users may redistribute the program under - these conditions, and telling the user how to view a copy of this - License. (Exception: if the Program itself is interactive but - does not normally print such an announcement, your work based on - the Program is not required to print an announcement.) - -These requirements apply to the modified work as a whole. If -identifiable sections of that work are not derived from the Program, -and can be reasonably considered independent and separate works in -themselves, then this License, and its terms, do not apply to those -sections when you distribute them as separate works. But when you -distribute the same sections as part of a whole which is a work based -on the Program, the distribution of the whole must be on the terms of -this License, whose permissions for other licensees extend to the -entire whole, and thus to each and every part regardless of who wrote it. - -Thus, it is not the intent of this section to claim rights or contest -your rights to work written entirely by you; rather, the intent is to -exercise the right to control the distribution of derivative or -collective works based on the Program. - -In addition, mere aggregation of another work not based on the Program -with the Program (or with a work based on the Program) on a volume of -a storage or distribution medium does not bring the other work under -the scope of this License. - - 3. You may copy and distribute the Program (or a work based on it, -under Section 2) in object code or executable form under the terms of -Sections 1 and 2 above provided that you also do one of the following: - - a) Accompany it with the complete corresponding machine-readable - source code, which must be distributed under the terms of Sections - 1 and 2 above on a medium customarily used for software interchange; or, - - b) Accompany it with a written offer, valid for at least three - years, to give any third party, for a charge no more than your - cost of physically performing source distribution, a complete - machine-readable copy of the corresponding source code, to be - distributed under the terms of Sections 1 and 2 above on a medium - customarily used for software interchange; or, - - c) Accompany it with the information you received as to the offer - to distribute corresponding source code. (This alternative is - allowed only for noncommercial distribution and only if you - received the program in object code or executable form with such - an offer, in accord with Subsection b above.) - -The source code for a work means the preferred form of the work for -making modifications to it. For an executable work, complete source -code means all the source code for all modules it contains, plus any -associated interface definition files, plus the scripts used to -control compilation and installation of the executable. However, as a -special exception, the source code distributed need not include -anything that is normally distributed (in either source or binary -form) with the major components (compiler, kernel, and so on) of the -operating system on which the executable runs, unless that component -itself accompanies the executable. - -If distribution of executable or object code is made by offering -access to copy from a designated place, then offering equivalent -access to copy the source code from the same place counts as -distribution of the source code, even though third parties are not -compelled to copy the source along with the object code. - - 4. You may not copy, modify, sublicense, or distribute the Program -except as expressly provided under this License. Any attempt -otherwise to copy, modify, sublicense or distribute the Program is -void, and will automatically terminate your rights under this License. -However, parties who have received copies, or rights, from you under -this License will not have their licenses terminated so long as such -parties remain in full compliance. - - 5. You are not required to accept this License, since you have not -signed it. However, nothing else grants you permission to modify or -distribute the Program or its derivative works. These actions are -prohibited by law if you do not accept this License. Therefore, by -modifying or distributing the Program (or any work based on the -Program), you indicate your acceptance of this License to do so, and -all its terms and conditions for copying, distributing or modifying -the Program or works based on it. - - 6. Each time you redistribute the Program (or any work based on the -Program), the recipient automatically receives a license from the -original licensor to copy, distribute or modify the Program subject to -these terms and conditions. You may not impose any further -restrictions on the recipients' exercise of the rights granted herein. -You are not responsible for enforcing compliance by third parties to -this License. - - 7. If, as a consequence of a court judgment or allegation of patent -infringement or for any other reason (not limited to patent issues), -conditions are imposed on you (whether by court order, agreement or -otherwise) that contradict the conditions of this License, they do not -excuse you from the conditions of this License. If you cannot -distribute so as to satisfy simultaneously your obligations under this -License and any other pertinent obligations, then as a consequence you -may not distribute the Program at all. For example, if a patent -license would not permit royalty-free redistribution of the Program by -all those who receive copies directly or indirectly through you, then -the only way you could satisfy both it and this License would be to -refrain entirely from distribution of the Program. - -If any portion of this section is held invalid or unenforceable under -any particular circumstance, the balance of the section is intended to -apply and the section as a whole is intended to apply in other -circumstances. - -It is not the purpose of this section to induce you to infringe any -patents or other property right claims or to contest validity of any -such claims; this section has the sole purpose of protecting the -integrity of the free software distribution system, which is -implemented by public license practices. Many people have made -generous contributions to the wide range of software distributed -through that system in reliance on consistent application of that -system; it is up to the author/donor to decide if he or she is willing -to distribute software through any other system and a licensee cannot -impose that choice. - -This section is intended to make thoroughly clear what is believed to -be a consequence of the rest of this License. - - 8. If the distribution and/or use of the Program is restricted in -certain countries either by patents or by copyrighted interfaces, the -original copyright holder who places the Program under this License -may add an explicit geographical distribution limitation excluding -those countries, so that distribution is permitted only in or among -countries not thus excluded. In such case, this License incorporates -the limitation as if written in the body of this License. - - 9. The Free Software Foundation may publish revised and/or new versions -of the General Public License from time to time. Such new versions will -be similar in spirit to the present version, but may differ in detail to -address new problems or concerns. - -Each version is given a distinguishing version number. If the Program -specifies a version number of this License which applies to it and "any -later version", you have the option of following the terms and conditions -either of that version or of any later version published by the Free -Software Foundation. If the Program does not specify a version number of -this License, you may choose any version ever published by the Free Software -Foundation. - - 10. If you wish to incorporate parts of the Program into other free -programs whose distribution conditions are different, write to the author -to ask for permission. For software which is copyrighted by the Free -Software Foundation, write to the Free Software Foundation; we sometimes -make exceptions for this. Our decision will be guided by the two goals -of preserving the free status of all derivatives of our free software and -of promoting the sharing and reuse of software generally. - - NO WARRANTY - - 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY -FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN -OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES -PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED -OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF -MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS -TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE -PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, -REPAIR OR CORRECTION. - - 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING -WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR -REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, -INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING -OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED -TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY -YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER -PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE -POSSIBILITY OF SUCH DAMAGES. - - END OF TERMS AND CONDITIONS - - How to Apply These Terms to Your New Programs - - If you develop a new program, and you want it to be of the greatest -possible use to the public, the best way to achieve this is to make it -free software which everyone can redistribute and change under these terms. - - To do so, attach the following notices to the program. It is safest -to attach them to the start of each source file to most effectively -convey the exclusion of warranty; and each file should have at least -the "copyright" line and a pointer to where the full notice is found. - - - Copyright (C) - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA - - -Also add information on how to contact you by electronic and paper mail. - -If the program is interactive, make it output a short notice like this -when it starts in an interactive mode: - - Gnomovision version 69, Copyright (C) year name of author - Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. - This is free software, and you are welcome to redistribute it - under certain conditions; type `show c' for details. - -The hypothetical commands `show w' and `show c' should show the appropriate -parts of the General Public License. Of course, the commands you use may -be called something other than `show w' and `show c'; they could even be -mouse-clicks or menu items--whatever suits your program. - -You should also get your employer (if you work as a programmer) or your -school, if any, to sign a "copyright disclaimer" for the program, if -necessary. Here is a sample; alter the names: - - Yoyodyne, Inc., hereby disclaims all copyright interest in the program - `Gnomovision' (which makes passes at compilers) written by James Hacker. - - , 1 April 1989 - Ty Coon, President of Vice - -This General Public License does not permit incorporating your program into -proprietary programs. If your program is a subroutine library, you may -consider it more useful to permit linking proprietary applications with the -library. If this is what you want to do, use the GNU Library General -Public License instead of this License. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2006-2023, John MacFarlane + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of John MacFarlane nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Text/Pandoc/Builder.hs b/Text/Pandoc/Builder.hs deleted file mode 100644 --- a/Text/Pandoc/Builder.hs +++ /dev/null @@ -1,405 +0,0 @@ -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, - DeriveDataTypeable, GeneralizedNewtypeDeriving, CPP #-} -{- -Copyright (C) 2010 John MacFarlane - -This program is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2 of the License, or -(at your option) any later version. - -This program is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with this program; if not, write to the Free Software -Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -{- | - Module : Text.Pandoc.Builder - Copyright : Copyright (C) 2010 John MacFarlane - License : GNU GPL, version 2 or above - - Maintainer : John MacFarlane - Stability : alpha - Portability : portable - -Convenience functions for building pandoc documents programmatically. - -Example of use: - -> {-# LANGUAGE OverloadedStrings #-} -> import Text.Pandoc.Builder -> -> myDoc :: Pandoc -> myDoc = setTitle "My title" $ doc $ -> para "This is the first paragraph" <> -> para ("And " <> emph "another" <> ".") <> -> bulletList [ para "item one" <> para "continuation" -> , plain ("item two and a " <> -> link "/url" "go to url" "link") -> ] - -Isn't that nicer than writing the following? - -> import Text.Pandoc.Definition -> -> myDoc :: Pandoc -> myDoc = Pandoc (Meta {docTitle = [Str "My",Space,Str "title"] -> , docAuthors = [] -> , docDate = []}) -> [Para [Str "This",Space,Str "is",Space,Str "the",Space,Str "first", -> Space,Str "paragraph"] -> ,Para [Str "And",Space,Emph [Str "another"],Str "."] -> ,BulletList [[Para [Str "item",Space,Str "one"] -> ,Para [Str "continuation"]] -> ,[Plain [Str "item",Space,Str "two",Space,Str "and", Space, -> Str "a",Space,Link [Str "link"] ("/url","go to url")]]]] - -And of course, you can use Haskell to define your own builders: - -> import Text.Pandoc.Builder -> import Text.JSON -> import Control.Arrow ((***)) -> import Data.Monoid (mempty) -> -> -- | Converts a JSON document into 'Blocks'. -> json :: String -> Blocks -> json x = -> case decode x of -> Ok y -> jsValueToBlocks y -> Error y -> error y -> where jsValueToBlocks x = -> case x of -> JSNull -> mempty -> JSBool x -> plain $ text $ show x -> JSRational _ x -> plain $ text $ show x -> JSString x -> plain $ text $ fromJSString x -> JSArray xs -> bulletList $ map jsValueToBlocks xs -> JSObject x -> definitionList $ -> map (text *** (:[]) . jsValueToBlocks) $ -> fromJSObject x - --} - -module Text.Pandoc.Builder ( module Text.Pandoc.Definition - , Inlines(..) - , Blocks(..) - , (<>) - , Listable(..) - -- * Document builders - , doc - , setTitle - , setAuthors - , setDate - -- * Inline list builders - , text - , str - , emph - , strong - , strikeout - , superscript - , subscript - , smallcaps - , singleQuoted - , doubleQuoted - , cite - , codeWith - , code - , space - , linebreak - , math - , displayMath - , rawInline - , link - , image - , note - , trimInlines - -- * Block list builders - , para - , plain - , codeBlockWith - , codeBlock - , rawBlock - , blockQuote - , bulletList - , orderedListWith - , orderedList - , definitionList - , header - , horizontalRule - , table - , simpleTable - ) -where -import Text.Pandoc.Definition -import Data.String -import Data.Monoid -import Data.Maybe (fromMaybe) -import Data.Sequence (Seq, (|>), viewr, viewl, ViewR(..), ViewL(..)) -import qualified Data.Sequence as Seq -import Data.Foldable (Foldable) -import qualified Data.Foldable as F -import Data.List (groupBy, intersperse) -import Data.Data -import Data.Typeable -import Control.Arrow ((***)) - -#if MIN_VERSION_base(4,5,0) --- (<>) is defined in Data.Monoid -#else -infixr 6 <> - --- | An infix synonym for 'mappend'. -(<>) :: Monoid m => m -> m -> m -(<>) = mappend -{-# INLINE (<>) #-} -#endif - -newtype Inlines = Inlines { unInlines :: Seq Inline } - deriving (Data, Ord, Eq, Typeable) - --- We show an Inlines just like [Inline]. -instance Show Inlines where - show = show . F.toList . unInlines - -instance Read Inlines where - readsPrec n = map (\(x,y) -> (Inlines . Seq.fromList $ x, y)) . readsPrec n - -instance Monoid Inlines where - mempty = Inlines mempty - (Inlines xs) `mappend` (Inlines ys) = - case (viewr xs, viewl ys) of - (EmptyR, _) -> Inlines ys - (_, EmptyL) -> Inlines xs - (xs' :> x, y :< ys') -> Inlines (meld `mappend` ys') - where meld = case (x, y) of - (Space, Space) -> xs' |> Space - (Str t1, Str t2) -> xs' |> Str (t1 <> t2) - (Emph i1, Emph i2) -> xs' |> Emph (i1 <> i2) - (Strong i1, Strong i2) -> xs' |> Strong (i1 <> i2) - (Subscript i1, Subscript i2) -> xs' |> Subscript (i1 <> i2) - (Superscript i1, Superscript i2) -> xs' |> Superscript (i1 <> i2) - (Strikeout i1, Strikeout i2) -> xs' |> Strikeout (i1 <> i2) - (Space, LineBreak) -> xs' |> LineBreak - _ -> xs' |> x |> y - -instance IsString Inlines where - fromString = text - -newtype Blocks = Blocks { unBlocks :: Seq Block } - deriving (Data, Ord, Eq, Typeable, Monoid) - --- We show a Blocks just like [Block]. -instance Show Blocks where - show = show . F.toList . unBlocks - -instance Read Blocks where - readsPrec n = map (\(x,y) -> (Blocks . Seq.fromList $ x, y)) . readsPrec n - -class Listable a b where - toList :: a -> [b] - fromList :: [b] -> a - foldMap :: (b -> a) -> a -> a - singleton :: b -> a - foldlM :: Monad m => (a -> b -> m a) -> a -> a -> m a - isNull :: a -> Bool - -instance Listable Inlines Inline where - toList = F.toList . unInlines - fromList = Inlines . Seq.fromList - foldMap f = F.foldMap f . unInlines - singleton = Inlines . Seq.singleton - foldlM f x = F.foldlM f x . unInlines - isNull = Seq.null . unInlines - -instance Listable Blocks Block where - toList = F.toList . unBlocks - fromList = Blocks . Seq.fromList - foldMap f = F.foldMap f . unBlocks - singleton = Blocks . Seq.singleton - foldlM f x = F.foldlM f x . unBlocks - isNull = Seq.null . unBlocks - --- | Trim leading and trailing Sp (spaces) from an Inlines. -trimInlines :: Inlines -> Inlines -#if MIN_VERSION_containers(0,4,0) -trimInlines (Inlines ils) = Inlines $ Seq.dropWhileL (== Space) $ - Seq.dropWhileR (== Space) $ ils -#else --- for GHC 6.12, we need to workaround a bug in dropWhileR --- see http://hackage.haskell.org/trac/ghc/ticket/4157 -trimInlines (Inlines ils) = Inlines $ Seq.dropWhileL (== Space) $ - Seq.reverse $ Seq.dropWhileL (== Space) $ - Seq.reverse ils -#endif - --- Document builders - -doc :: Blocks -> Pandoc -doc = Pandoc (Meta [] [] []) . toList - -setTitle :: Inlines -> Pandoc -> Pandoc -setTitle t (Pandoc m bs) = Pandoc m{ docTitle = toList t } bs - -setAuthors :: [Inlines] -> Pandoc -> Pandoc -setAuthors as (Pandoc m bs) = Pandoc m{ docAuthors = map toList as } bs - -setDate :: Inlines -> Pandoc -> Pandoc -setDate d (Pandoc m bs) = Pandoc m{ docDate = toList d } bs - --- Inline list builders - --- | Convert a 'String' to 'Inlines', treating interword spaces as 'Space's. --- If you want a 'Str' with literal spaces, use 'str'. -text :: String -> Inlines -text = fromList . map conv . breakBySpaces - where breakBySpaces = groupBy sameCategory - sameCategory x y = (is_space x && is_space y) || - (not $ is_space x || is_space y) - conv xs | all is_space xs = Space - conv xs = Str xs - is_space ' ' = True - is_space '\n' = True - is_space '\t' = True - is_space _ = False - -str :: String -> Inlines -str = singleton . Str - -emph :: Inlines -> Inlines -emph = singleton . Emph . toList - -strong :: Inlines -> Inlines -strong = singleton . Strong . toList - -strikeout :: Inlines -> Inlines -strikeout = singleton . Strikeout . toList - -superscript :: Inlines -> Inlines -superscript = singleton . Superscript . toList - -subscript :: Inlines -> Inlines -subscript = singleton . Subscript . toList - -smallcaps :: Inlines -> Inlines -smallcaps = singleton . SmallCaps . toList - -singleQuoted :: Inlines -> Inlines -singleQuoted = quoted SingleQuote - -doubleQuoted :: Inlines -> Inlines -doubleQuoted = quoted DoubleQuote - -quoted :: QuoteType -> Inlines -> Inlines -quoted qt = singleton . Quoted qt . toList - -cite :: [Citation] -> Inlines -> Inlines -cite cts = singleton . Cite cts . toList - --- | Inline code with attributes. -codeWith :: Attr -> String -> Inlines -codeWith attrs = singleton . Code attrs - --- | Plain inline code. -code :: String -> Inlines -code = codeWith nullAttr - -space :: Inlines -space = singleton Space - -linebreak :: Inlines -linebreak = singleton LineBreak - --- | Inline math -math :: String -> Inlines -math = singleton . Math InlineMath - --- | Display math -displayMath :: String -> Inlines -displayMath = singleton . Math DisplayMath - -rawInline :: Format -> String -> Inlines -rawInline format = singleton . RawInline format - -link :: String -- ^ URL - -> String -- ^ Title - -> Inlines -- ^ Label - -> Inlines -link url title x = singleton $ Link (toList x) (url, title) - -image :: String -- ^ URL - -> String -- ^ Title - -> Inlines -- ^ Alt text - -> Inlines -image url title x = singleton $ Image (toList x) (url, title) - -note :: Blocks -> Inlines -note = singleton . Note . toList - --- Block list builders - -para :: Inlines -> Blocks -para = singleton . Para . toList - -plain :: Inlines -> Blocks -plain = singleton . Plain . toList - --- | A code block with attributes. -codeBlockWith :: Attr -> String -> Blocks -codeBlockWith attrs = singleton . CodeBlock attrs - --- | A plain code block. -codeBlock :: String -> Blocks -codeBlock = codeBlockWith nullAttr - -rawBlock :: Format -> String -> Blocks -rawBlock format = singleton . RawBlock format - -blockQuote :: Blocks -> Blocks -blockQuote = singleton . BlockQuote . toList - --- | Ordered list with attributes. -orderedListWith :: ListAttributes -> [Blocks] -> Blocks -orderedListWith attrs = singleton . OrderedList attrs . map toList - --- | Ordered list with default attributes. -orderedList :: [Blocks] -> Blocks -orderedList = orderedListWith (1, DefaultStyle, DefaultDelim) - -bulletList :: [Blocks] -> Blocks -bulletList = singleton . BulletList . map toList - -definitionList :: [(Inlines, [Blocks])] -> Blocks -definitionList = singleton . DefinitionList . map (toList *** map toList) - -header :: Int -- ^ Level - -> Inlines - -> Blocks -header level = singleton . Header level . toList - -horizontalRule :: Blocks -horizontalRule = singleton HorizontalRule - -table :: Inlines -- ^ Caption - -> [(Alignment, Double)] -- ^ Column alignments and fractional widths - -> [Blocks] -- ^ Headers - -> [[Blocks]] -- ^ Rows - -> Blocks -table caption cellspecs headers rows = singleton $ - Table (toList caption) aligns widths - (map toList headers) (map (map toList) rows) - where (aligns, widths) = unzip cellspecs - --- | A simple table without a caption. -simpleTable :: [Blocks] -- ^ Headers - -> [[Blocks]] -- ^ Rows - -> Blocks -simpleTable headers = table mempty (mapConst defaults headers) headers - where defaults = (AlignDefault, 0) - -mapConst :: Functor f => b -> f a -> f b -mapConst = fmap . const diff --git a/Text/Pandoc/Definition.hs b/Text/Pandoc/Definition.hs deleted file mode 100644 --- a/Text/Pandoc/Definition.hs +++ /dev/null @@ -1,162 +0,0 @@ -{-# LANGUAGE CPP, DeriveDataTypeable #-} - -#ifdef GENERICS -{-# LANGUAGE DeriveGeneric #-} -#endif - -{- -Copyright (C) 2006-2010 John MacFarlane - -This program is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2 of the License, or -(at your option) any later version. - -This program is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with this program; if not, write to the Free Software -Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -{- | - Module : Text.Pandoc.Definition - Copyright : Copyright (C) 2006-2010 John MacFarlane - License : GNU GPL, version 2 or above - - Maintainer : John MacFarlane - Stability : alpha - Portability : portable - -Definition of 'Pandoc' data structure for format-neutral representation -of documents. --} -module Text.Pandoc.Definition where - -import Data.Generics (Data, Typeable) -import Data.Ord (comparing) - -#ifdef GENERICS -import GHC.Generics (Generic) -#define GENERIC , Generic -#else -#define GENERIC -#endif - -data Pandoc = Pandoc Meta [Block] deriving (Eq, Ord, Read, Show, Typeable, Data GENERIC) - --- | Bibliographic information for the document: title, authors, date. -data Meta = Meta { docTitle :: [Inline] - , docAuthors :: [[Inline]] - , docDate :: [Inline] } - deriving (Eq, Ord, Show, Read, Typeable, Data GENERIC) - --- | Alignment of a table column. -data Alignment = AlignLeft - | AlignRight - | AlignCenter - | AlignDefault deriving (Eq, Ord, Show, Read, Typeable, Data GENERIC) - --- | List attributes. -type ListAttributes = (Int, ListNumberStyle, ListNumberDelim) - --- | Style of list numbers. -data ListNumberStyle = DefaultStyle - | Example - | Decimal - | LowerRoman - | UpperRoman - | LowerAlpha - | UpperAlpha deriving (Eq, Ord, Show, Read, Typeable, Data GENERIC) - --- | Delimiter of list numbers. -data ListNumberDelim = DefaultDelim - | Period - | OneParen - | TwoParens deriving (Eq, Ord, Show, Read, Typeable, Data GENERIC) - --- | Attributes: identifier, classes, key-value pairs -type Attr = (String, [String], [(String, String)]) - -nullAttr :: Attr -nullAttr = ("",[],[]) - --- | Table cells are list of Blocks -type TableCell = [Block] - --- | Formats for raw blocks -type Format = String - --- | Block element. -data Block - = Plain [Inline] -- ^ Plain text, not a paragraph - | Para [Inline] -- ^ Paragraph - | CodeBlock Attr String -- ^ Code block (literal) with attributes - | RawBlock Format String -- ^ Raw block - | BlockQuote [Block] -- ^ Block quote (list of blocks) - | OrderedList ListAttributes [[Block]] -- ^ Ordered list (attributes - -- and a list of items, each a list of blocks) - | BulletList [[Block]] -- ^ Bullet list (list of items, each - -- a list of blocks) - | DefinitionList [([Inline],[[Block]])] -- ^ Definition list - -- Each list item is a pair consisting of a - -- term (a list of inlines) and one or more - -- definitions (each a list of blocks) - | Header Int [Inline] -- ^ Header - level (integer) and text (inlines) - | HorizontalRule -- ^ Horizontal rule - | Table [Inline] [Alignment] [Double] [TableCell] [[TableCell]] -- ^ Table, - -- with caption, column alignments, - -- relative column widths (0 = default), - -- column headers (each a list of blocks), and - -- rows (each a list of lists of blocks) - | Null -- ^ Nothing - deriving (Eq, Ord, Read, Show, Typeable, Data GENERIC) - --- | Type of quotation marks to use in Quoted inline. -data QuoteType = SingleQuote | DoubleQuote deriving (Show, Eq, Ord, Read, Typeable, Data GENERIC) - --- | Link target (URL, title). -type Target = (String, String) - --- | Type of math element (display or inline). -data MathType = DisplayMath | InlineMath deriving (Show, Eq, Ord, Read, Typeable, Data GENERIC) - --- | Inline elements. -data Inline - = Str String -- ^ Text (string) - | Emph [Inline] -- ^ Emphasized text (list of inlines) - | Strong [Inline] -- ^ Strongly emphasized text (list of inlines) - | Strikeout [Inline] -- ^ Strikeout text (list of inlines) - | Superscript [Inline] -- ^ Superscripted text (list of inlines) - | Subscript [Inline] -- ^ Subscripted text (list of inlines) - | SmallCaps [Inline] -- ^ Small caps text (list of inlines) - | Quoted QuoteType [Inline] -- ^ Quoted text (list of inlines) - | Cite [Citation] [Inline] -- ^ Citation (list of inlines) - | Code Attr String -- ^ Inline code (literal) - | Space -- ^ Inter-word space - | LineBreak -- ^ Hard line break - | Math MathType String -- ^ TeX math (literal) - | RawInline Format String -- ^ Raw inline - | Link [Inline] Target -- ^ Hyperlink: text (list of inlines), target - | Image [Inline] Target -- ^ Image: alt text (list of inlines), target - -- and target - | Note [Block] -- ^ Footnote or endnote - deriving (Show, Eq, Ord, Read, Typeable, Data GENERIC) - -data Citation = Citation { citationId :: String - , citationPrefix :: [Inline] - , citationSuffix :: [Inline] - , citationMode :: CitationMode - , citationNoteNum :: Int - , citationHash :: Int - } - deriving (Show, Eq, Read, Typeable, Data GENERIC) - -instance Ord Citation where - compare = comparing citationHash - -data CitationMode = AuthorInText | SuppressAuthor | NormalCitation - deriving (Show, Eq, Ord, Read, Typeable, Data GENERIC) diff --git a/Text/Pandoc/Generic.hs b/Text/Pandoc/Generic.hs deleted file mode 100644 --- a/Text/Pandoc/Generic.hs +++ /dev/null @@ -1,135 +0,0 @@ -{- -Copyright (C) 2006-2010 John MacFarlane - -This program is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2 of the License, or -(at your option) any later version. - -This program is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with this program; if not, write to the Free Software -Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -{- | - Module : Text.Pandoc.Generic - Copyright : Copyright (C) 2006-2010 John MacFarlane - License : GNU GPL, version 2 or above - - Maintainer : John MacFarlane - Stability : alpha - Portability : portable - -Generic functions for manipulating 'Pandoc' documents. - -Here's a simple example, defining a function that replaces all the level 3+ -headers in a document with regular paragraphs in ALL CAPS: - -> import Text.Pandoc.Definition -> import Text.Pandoc.Generic -> import Data.Char (toUpper) -> -> modHeader :: Block -> Block -> modHeader (Header n xs) | n >= 3 = Para $ bottomUp allCaps xs -> modHeader x = x -> -> allCaps :: Inline -> Inline -> allCaps (Str xs) = Str $ map toUpper xs -> allCaps x = x -> -> changeHeaders :: Pandoc -> Pandoc -> changeHeaders = bottomUp modHeader - -'bottomUp' is so called because it traverses the @Pandoc@ structure from -bottom up. 'topDown' goes the other way. The difference between them can be -seen from this example: - -> normal :: [Inline] -> [Inline] -> normal (Space : Space : xs) = Space : xs -> normal (Emph xs : Emph ys : zs) = Emph (xs ++ ys) : zs -> normal xs = xs -> -> myDoc :: Pandoc -> myDoc = Pandoc (Meta {docTitle = [], docAuthors = [], docDate = []}) -> [Para [Str "Hi",Space,Emph [Str "world",Space],Emph [Space,Str "emphasized"]]] - -Here we want to use 'topDown' to lift @normal@ to @Pandoc -> Pandoc@. -The top down strategy will collapse the two adjacent @Emph@s first, then -collapse the resulting adjacent @Space@s, as desired. If we used 'bottomUp', -we would end up with two adjacent @Space@s, since the contents of the -two @Emph@ inlines would be processed before the @Emph@s were collapsed -into one. - -> topDown normal myDoc == -> Pandoc (Meta {docTitle = [], docAuthors = [], docDate = []}) -> [Para [Str "Hi",Space,Emph [Str "world",Space,Str "emphasized"]]] -> -> bottomUp normal myDoc == -> Pandoc (Meta {docTitle = [], docAuthors = [], docDate = []}) -> [Para [Str "Hi",Space,Emph [Str "world",Space,Space,Str "emphasized"]]] - -'bottomUpM' is a monadic version of 'bottomUp'. It could be used, -for example, to replace the contents of delimited code blocks with -attribute @include=FILENAME@ with the contents of @FILENAME@: - -> doInclude :: Block -> IO Block -> doInclude cb@(CodeBlock (id, classes, namevals) contents) = -> case lookup "include" namevals of -> Just f -> return . (CodeBlock (id, classes, namevals)) =<< readFile f -> Nothing -> return cb -> doInclude x = return x -> -> processIncludes :: Pandoc -> IO Pandoc -> processIncludes = bottomUpM doInclude - -'queryWith' can be used, for example, to compile a list of URLs -linked to in a document: - -> extractURL :: Inline -> [String] -> extractURL (Link _ (u,_)) = [u] -> extractURL (Image _ (u,_)) = [u] -> extractURL _ = [] -> -> extractURLs :: Pandoc -> [String] -> extractURLs = queryWith extractURL - --} -module Text.Pandoc.Generic where - -import Data.Generics -import Data.Monoid - --- | Applies a transformation on @a@s to matching elements in a @b@, --- moving from the bottom of the structure up. -bottomUp :: (Data a, Data b) => (a -> a) -> b -> b -bottomUp f = everywhere (mkT f) - --- | Applies a transformation on @a@s to matching elements in a @b@, --- moving from the top of the structure down. -topDown :: (Data a, Data b) => (a -> a) -> b -> b -topDown f = everywhere' (mkT f) - --- | Like 'bottomUp', but with monadic transformations. -bottomUpM :: (Monad m, Data a, Data b) => (a -> m a) -> b -> m b -bottomUpM f = everywhereM (mkM f) - --- | Runs a query on matching @a@ elements in a @c@. The results --- of the queries are combined using 'mappend'. -queryWith :: (Data a, Monoid b, Data c) => (a -> b) -> c -> b -queryWith f = everything mappend (mempty `mkQ` f) - -{-# DEPRECATED processWith "Use bottomUp instead" #-} --- | Deprecated synonym for @bottomUp@. -processWith :: (Data a, Data b) => (a -> a) -> b -> b -processWith = bottomUp - -{-# DEPRECATED processWithM "Use bottomUpM instead" #-} --- | Deprecated synonym for @bottomUpM@. -processWithM :: (Monad m, Data a, Data b) => (a -> m a) -> b -> m b -processWithM = bottomUpM - diff --git a/benchmark/bench.hs b/benchmark/bench.hs new file mode 100644 --- /dev/null +++ b/benchmark/bench.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE OverloadedStrings #-} + +import Criterion.Main (bench, defaultMain, nf) +import Text.Pandoc.Walk (walk) +import Text.Pandoc.Builder +import qualified Data.Text as T + +main :: IO () +main = + defaultMain [ + bench "simple walk" $ nf (walk prependZeroWidthSpace) mydoc + , bench "walk concatMap" $ nf (walk $ concatMap prependZeroWidthSpace') mydoc + , bench "walk lists" $ nf (walk prependZeroWidthSpace'') mydoc + ] + +prependZeroWidthSpace :: Inline -> Inline +prependZeroWidthSpace (Str s) = Str (T.cons '\8203' s) +prependZeroWidthSpace x = x + +prependZeroWidthSpace' :: Inline -> [Inline] +prependZeroWidthSpace' (Str s) = [Str (T.cons '\8203' s)] +prependZeroWidthSpace' x = [x] + +prependZeroWidthSpace'' :: [Inline] -> [Inline] +prependZeroWidthSpace'' (Str s : xs) = + Str (T.cons '\8203' s) : prependZeroWidthSpace'' xs +prependZeroWidthSpace'' (x : xs) = + x : prependZeroWidthSpace'' xs +prependZeroWidthSpace'' [] = [] + +mydoc :: Pandoc +mydoc = setTitle "My title" $ doc $ + mconcat $ replicate 50 $ + para "This is the first paragraph" <> + para ("And " <> emph "another" <> ".") <> + bulletList [ para "item one" <> para "continuation" + , plain ("item two and a " <> + link "/url" "go to url" "link") + ] diff --git a/changelog b/changelog new file mode 100644 --- /dev/null +++ b/changelog @@ -0,0 +1,403 @@ +[1.23.1.2] + + * Bump upper bound for QuickCheck. + + * Remove obsolete semigroups clause for ghc < 8. + + * Allow aeson 2.3 (Francesco Gazzetta). + + * CI: remove ghc 8.10 from testing + + * Use lts-26 in stack.yaml. + + * Set minimum base version 4.15. + +[1.23.1.1] + + * Remove unused `ghc-prim` dependency (konsumlam). + + * Bump bound for QuickCheck. + + * Allow deepseq-1.5 (Bodigrim). + + * Fix 'patter' typo in SimpleFigure haddock (Owen Shepherd). + +[1.23.1] + + * Restore toJSONFilter instance for pure `a -> [a]`. + This went missing after my ill-considered revision to #105, + commit 183af9d9f1066be974ac55fd23a4c985999d3ce8 . See jgm/pandoc#8976. + + * Generalize ToJSONFilter instance. Previously a pure function `a -> a` + could only be promoted to a filter in IO. Now we allow it to work with + any instance of MonadIO. (This adds to #105.) + + * Allow bytestring 0.12. + +[1.23.0.1] + + * Allow aeson 2.2. + + * Remove dependency on string-qq (recbecca skinner). + +[1.23] + + * Remove Null constructor from Block (#91) [API change]. + + * ToJSONFilter: Add instance for MonadIO (#105, Willem Van Onsem) + [API change]. + + * Add `Figure` block constructor (Albert Krewinkel, Aner Lucero, + and Christian Despres) [API change]. The new Figure block represents + a figure with attributes, caption, and arbitrary block content. + +[1.22.2.1] + + * Allow aeson 2.1.* and criterion 1.6. + +[1.22.2] + + * Use StrictData in Text.Pandoc.Definition. + + * Add Walkable Meta(Value) Pandoc instances (Travis Cardwell). + +[1.22.1] + + * Text.Pandoc.Builder: add simpleFigure, simpleFigureWith, + and the SimpleFigure bidirectional pattern synonym + (Aner Lucero) [API change]. + + * Allow bytestring 0.11 (Alexander Batischev). + + * Update stack resolver to lts-18.10 + + * Allow aeson 2+. Tested with aeson 2.0.1.0. + + * Allow transformers 0.6. + + * Fix incorrect table ColWidth documentation (#85, Nils Carlson). + The documentation stated that the ColWidth represented the width + of the column as a fraction of the table width when in represents + a percentage of the text width. + +[1.22] + + * Deprecate isNull from Builder: null can serve just as well (#67). + Use null instead of isNull in Arbitrary (Christian Despres, #84). + + * Use untagged JSON encoding for single-constructor types (#75, #76, + Christian Despres). All of the single constructor types related + to Table are now represented in JSON either as arrays (for + multi-argument constructors) or as the representation of the + inner type (for single argument constructors). This behaviour + for newtype-defined and multi-argument non-record types is now + consistent across the entire JSON interface, with the exception + of Pandoc itself (which is represented as a JSON object with + additional metadata). Multi-argument records (of which Citation + is the only example) are still represented as objects with the + record accessors as keys. + + * The Meta and Citation types now use derived JSON serialization (newtype + and generic, respectively). The format remains the same as before + (Christian Despres). + + * New serialization tests now test that Meta and the Table types are + encoded properly in JSON (Christian Despres). + + * Use TH To/FromJSON instances (Christian Despres). + + * Remove unused Legacy modules (#80, Despres). + They are not exported, and are not used internally. + + * Change the table builder to permit looser intermediate table heads (#77, + Christian Despres). + + The table builder (and the normalizeTableBody function) now permit + cells in the intermediate head of a TableBody to extend past the + RowHeadColumns. This allows for intermediate tables to have + subheadings that extend across the entire table. + + Formerly the table builder would treat the intermediate head like the + intermediate body, and clip or drop cells that extended past the row + head. + + * Update QuickCheck lower bound. + + * Fix redundant pattern match. + +[1.21] + + * Add Underline constructor (#68, Vaibhav Sagar). + + * Improve table types to allow col, rowspans and more (#65, Christian + Despres). The additions include modification of the Block type, some + newtypes related to tables, and changes to the table builders. The table + builder is now aware of the new Table constructor, and normalizes the + input table appropriately, so that when laid onto a grid the resulting + table has no empty spaces, overlapping cells, or cells that extend beyond + their section boundary. + + Three properties of normalization are checked: + + - Normalization is idempotent. + - Each row of a normalized table is an initial segment of the + corresponding row in the unnormalized table, modulo changed cell + dimensions, dropped cells, and padding with empty cells. This is only + checked for the first row of the TableBody, however, due to row head + difficulties. + - The sum of the cell lengths in the first row of every + normalized table section is always equal to the total table width. + + `simpleTable` has been changed so that a null header list becomes a + TableHead with a null body, not a TableHead with a single empty row. + + * Bump QuickCheck upper bound. + + * Change lower bound for QuickCheck to 2.10 (needed for `liftShrink2`). + + * Small code quality improvements (Joseph C. Sible, #69). + + * Allow aeson 1.5 (#72, Felix Yan). + + * Fixed documentation typo (Merlin Göttlinger). + + * Add COMPLETE pragmas to the pattern definitions (Christian Despres). + +[1.20] + + * Change all uses of String in type definitions to strict Text + (Christian Despres) [API change]. The MetaValue instances using String + have been kept, and parallel ones using Text were added. + + * Remove the Arbitrary Text orphan instance (Christian Despres). + This instance should not have been in the Text.Pandoc.Arbitrary, since + it would have been exported with the rest of the instances in that + module. Instead, more shrink* functions were added to compensate for + the absence of this instance. + + * Add Text.Pandoc.Legacy.Definition (Christian Despres). + To ease the transition to Text, this module provides an interface + compatible with the String one, so that any unqualified imports of + Text.Pandoc.Definition in other packages can be replaced by + Text.Pandoc.Legacy.Definition without other code changes. This is done + with PatternSynonyms. + + Some of the constructors of the types Meta, MetaValue, Block, Inline, + Format, and Citation required PatternSynonym handling. The Attr and + Target types had to be redefined, and certain functions had to be + rewritten to handle String or the old Attr and Target types in this + module. This module otherwise exports the definitions in + Text.Pandoc.Definition unchanged. + + This is not a perfect drop-in replacement, since some imports like + Inline(..) will no longer work. This may also cause incomplete pattern + warnings when used, since the coverage checker does not seem to be + aware of PatternSynonyms. + + * Add Text.Pandoc.Legacy.Builder (Christian Despres). + Like Text.Pandoc.Legacy.Definition, this modules provides a + compatibility interface while the transition to Text takes + place. Unlike that module, this module only requires redefining the + ToMetaValue and HasMeta classes and a few functions so that they use + the old types. No PatternSynonyms are required. + + * Change Semigroup/Monoid instance for Meta. + Previously `<>` was left-biased, so if meta1 and meta2 both + contained a field 'foo', the value from meta1 would be retained + in `meta1 <> meta2`, and the value from meta2 ignored. + This is counterintuitive and doesn't work well with pandoc; + for example, we want to be able to override a value in an + earlier `--metadata-file` with a later one on the command line. + + It also makes the behavior of metadata more like other + things (such as reference links, where later definitions + take precedence over earlier ones). + + Note that this change may break some current workflows, + if one is relying on metadata fields that occur later in + a document to be overridden by those occurring earlier. + +[1.17.6.1] + + * Relax version bound for string-qq. + +[1.17.6] + + * Walk: export walk and query helpers (Albert Krewinkel) [API change]. + The `walk*M` and `query*` functions are helpful when defining new + `Walkable` instances. + * Allow QuickCheck 2.13. + * Document meaning of Int in ListAttributes (#45). + * Update copyright year spans to include 2019 (Albert Krewinkel). + * Remove CPP instructions for GHC versions < 7.10 (Albert Krewinkel). + * update list of GHC versions used for testing (Albert Krewinkel). + * Fix compiler and hlint warnings (Pete Ryland). + +[1.17.5.4] + + * Put NFData in scope for ghc < 7.10. + * Reduce deepseq lower bound for ghc < 7.10. + +[1.17.5.3] + + * For ghc < 7.10, constrain deepseq-generics to >= 0.2, which no + longer exprots NFData from deepseq. Add deepseq dependency. + +[1.17.5.2] + + * Bump upper bound for deepseq-generics, QuickCheck, criterion. + * Implement QuickCheck shrinking for Inlines and Blocks (Alexander Krotov). + +[1.17.5.1] + + * Declare the ToMetaValue instance for String as OVERLAPPING (#46). + +[1.17.5] + + + * Bump upper bounds for aeson, base. + * Allow building on older ghc versions (George Wilson). + * Text.Pandoc.Arbitrary: generate SoftBreaks and LineBreaks + (Alexander Krotov). + * Pad table rows up to maximum row length, to guarantee that + all rows have the same number of columns + (see jgm/pandoc#4059, Francesco Occhipinti). + * Make String an instance of ToMetaValue (Alexander Krotov). + +[1.17.4.2] + + * Fix compiler warnings. + +[1.17.4.1] + + * Import Semigroups when needed rather than using CPP. + * Bump criterion upper bound. + +[1.17.4] + + * Add Semigroup instances for Pandoc, Meta, Inlines, Blocks + (if base >= 4.9). This is needed for the library to compile + with ghc 8.4. + * Bumped criterion upper bound. + +[1.17.3.1] + + * Bumped upper bounds for criterion and QuickCheck. + +[1.17.3] + + * Added Walkable instances for `[Inline] Inline` and `[Block] Block`. + +[1.17.2] + + * Provide default implementation for walk (Albert Krewinkel). + The implementations for `walk` and `walkM` are very similar, so a + default method is provided which implements the former in terms of the + latter. This change should not affect performance, as the `Identity` + functor, which is used in the default definition, is a newtype that + should be eliminated at compile time. (This requires a dependency + on transformers for ghc 7.8.x.) + * Force optimizations when compiling Walk module (Albert Krewinkel). + * Add `Applicative m` to the context of walkM (Albert Krewinkel). + The acceptance of AMP makes this a natural change. + * Add `Walkable [Block]` and `Walkable [Inline]` instances (Albert + Krewinkel). + * Factored out duplicate code in Walk. + * Added benchmark. + * Text.Pandoc.JSON: Use `walk` instead of `bottomUp` in the + `ToJSONFilter` instance for `a -> [a]`. Note that behavior will be + slightly different, since bottomUp's treatment of a function `[a] -> [a]` + is to apply it to each sublist of a list, while walk applies it only to + maximal sublists. Usually the latter behavior is what is wanted, and the + former can be simulated when needed. But there may be existing filters + that need to be rewritten in light of the new behavior. + +[1.17.1] + + * Better consistency in simpleTable and table (jgm/pandoc#3648). + If `headers` is empty, we populate it with empty cells, using the rows + to determine number of columns. We also ensure that there are numcols + alignments and column widths. + * Make sure Div and Span occur in Arbitrary instances. + * Bump dependency upper bounds. + * Removed unused mapConst. + +[1.17.0.5] + + * Allow aeson 1.1. + * Added tests for Walk (originally from pandoc). + * Renamed README -> README.md, fix link (Kolen Cheung). + +[1.17.0.4] + + * Re-add Functor constraint to walkM, needed for ghc 7.8. + * Turn off redundant-constraints warning for Walk (for ghc 8.0.1+). + * Added necessary Data.Traversable import. + * Allow HUnit 1.5. + +[1.17.0.3] + + * More ghc 7.8 compatibility imports. + +[1.17.0.2] + + * Added a necessary import from Data.Monoid (for ghc 7.8). + +[1.17.0.1] + + * Fix compiler warnings around Data.Monoid import on some platforms. + +[1.17] + + * Remimplement json encoding of inlines manually (Jesse Rosenthal). + This is the first step to doing manual encoding and decoding of pandoc + JSON. This will replace the current generic deriving, which can be a + moving target. + * Move Arbitrary instances for types from pandoc (Jesse Rosenthal). + * Remove empty arrays for leaf elements (Jesse Rosenthal). + Elements with no children (Space, SoftBreak, LineBreak, HorizontalRule, + Null) previously had an empty array for their "c" value. We remove that + here. This is a breaking change for the JSON format. + * New toplevel JSON format with api-version (Jesse Rosenthal). The version + number is the pandoc-types version. The toplevel format was previously: + + [{"unMeta": META}, [BLOCKS]] + + It is now: + + { + "pandoc-api-version" : [MAJ, MIN, REV], + "meta" : META, + "blocks": BLOCKS + } + + Decoding fails if the major and minor version numbers don't match. + * Add simple quickcheck tests to verify that roundtrip works properly + (Jesse Rosenthal). + * Add a LineBlock block element (Albert Krewinkel). + * Add explicit unit tests for encoding and decoding (Jesse Rosenthal). + * Fixed warnings in Walk, Builder. + * Test with travis and appveyor. + +[1.16.1.1] + + * Allow aeson 1.0.*. + +[1.16.1] + + * Allow aeson 0.11.*. + * Export pandocTypesVersion from Text.Pandoc.Definition. + +[1.16.0.1] + + * Use deepseq instead of deepseq-generics. deepseq now allows deriving + generic NFData instances, so we don't need deepseq-generics. + * Removed unneeded instance, use OVERLAPPING pragma for ghc 7.10. + * Added CPP so that deepseq-generics is used for ghc < 7.10. + * Added tested-with, generate .travis.yml using make_travis_yml.hs + * Added stack.yaml + +[1.16] + +* Added Attr field to Image and Link. +* Added SoftBreak constructor to Inline diff --git a/pandoc-types.cabal b/pandoc-types.cabal --- a/pandoc-types.cabal +++ b/pandoc-types.cabal @@ -1,11 +1,12 @@ +cabal-version: 2.2 Name: pandoc-types -Version: 1.9.1 +version: 1.23.1.2 Synopsis: Types for representing a structured document -Description: This package contains definitions for the 'Pandoc' data +Description: @Text.Pandoc.Definition@ defines the 'Pandoc' data structure, which is used by pandoc to represent - structured documents. These definitions used to live - in the pandoc package, but starting with pandoc 1.7, they - have been split off, so that other packages can use them + structured documents. This module used to live + in the pandoc package, but starting with pandoc 1.7, it + has been split off, so that other packages can use it without drawing in all of pandoc's dependencies, and pandoc itself can depend on packages (like citeproc-hs) that use them. @@ -15,29 +16,77 @@ . @Text.Pandoc.Generic@ provides generic functions for manipulating Pandoc documents. + . + @Text.Pandoc.Walk@ provides faster, nongeneric functions + for manipulating Pandoc documents. + . + @Text.Pandoc.JSON@ provides functions for serializing + and deserializing a @Pandoc@ structure to and from JSON. -Homepage: http://johnmacfarlane.net/pandoc -License: GPL -License-file: COPYING +Homepage: https://pandoc.org/ +License: BSD-3-Clause +License-file: LICENSE Author: John MacFarlane Maintainer: jgm@berkeley.edu -Bug-Reports: http://code.google.com/p/pandoc/issues/list -Copyright: (c) 2006-2010 John MacFarlane +Bug-Reports: https://github.com/jgm/pandoc-types/issues +Copyright: (c) 2006-2023 John MacFarlane Category: Text Build-type: Simple -Cabal-version: >=1.6 +Extra-doc-files: changelog Source-repository head type: git - location: git://github.com/jgm/pandoc-types.git + location: https://github.com/jgm/pandoc-types.git + Library + hs-source-dirs: src Exposed-modules: Text.Pandoc.Definition Text.Pandoc.Generic + Text.Pandoc.Walk Text.Pandoc.Builder - if impl(ghc >= 6.10) - Build-depends: base >= 4 && < 5, syb, containers >= 0.3 - else - Build-depends: base >= 3 && < 4, containers >= 0.3 + Text.Pandoc.JSON + Text.Pandoc.Arbitrary + Other-modules: Paths_pandoc_types + Autogen-modules: Paths_pandoc_types + Build-depends: base >= 4.15 && < 5, + containers >= 0.3, + text, + deepseq >= 1.4.1 && < 1.6, + syb >= 0.1 && < 0.8, + bytestring >= 0.9 && < 0.13, + aeson >= 0.6.2 && < 2.4, + transformers >= 0.2 && < 0.7, + QuickCheck >= 2.10 && < 2.19 + ghc-options: -Wall + default-language: Haskell2010 - if impl(ghc >= 7.2.1) - cpp-options: -DGENERICS - build-depends: ghc-prim >= 0.2 +test-suite test-pandoc-types + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: test-pandoc-types.hs + Other-modules: Data.String.QQ + build-depends: base, + pandoc-types, + syb, + aeson >= 0.6.2 && < 2.4, + containers >= 0.3, + text, + bytestring >= 0.9 && < 0.13, + test-framework >= 0.3 && < 0.9, + test-framework-hunit >= 0.2 && < 0.4, + test-framework-quickcheck2 >= 0.2.9 && < 0.4, + QuickCheck >= 2.10 && < 2.19, + HUnit >= 1.2 && < 1.7, + template-haskell >= 2 + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -O2 + default-language: Haskell2010 + +benchmark benchmark-pandoc-types + type: exitcode-stdio-1.0 + main-is: bench.hs + hs-source-dirs: benchmark + build-depends: pandoc-types, + base >= 4.15 && < 5, + text, + criterion >= 1.0 + ghc-options: -rtsopts -Wall -fno-warn-unused-do-bind -O2 + default-language: Haskell2010 diff --git a/src/Text/Pandoc/Arbitrary.hs b/src/Text/Pandoc/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Arbitrary.hs @@ -0,0 +1,405 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE FlexibleInstances, ScopedTypeVariables, OverloadedStrings #-} +-- provides Arbitrary instance for Pandoc types +module Text.Pandoc.Arbitrary () +where +import Test.QuickCheck +import Control.Monad (forM) +import Data.Text (Text) +import qualified Data.Text as T +import Text.Pandoc.Definition +import Text.Pandoc.Builder + +realString :: Gen Text +realString = fmap T.pack $ resize 8 $ listOf $ frequency [ (9, elements [' '..'\127']) + , (1, elements ['\128'..'\9999']) ] + +shrinkText :: Text -> [Text] +shrinkText xs = T.pack <$> shrink (T.unpack xs) + +shrinkText2 :: (Text, Text) -> [(Text, Text)] +shrinkText2 = liftShrink2 shrinkText shrinkText + +arbAttr :: Gen Attr +arbAttr = do + id' <- elements ["","loc"] + classes' <- elements [[],["haskell"],["c","numberLines"]] + keyvals <- elements [[],[("start","22")],[("a","11"),("b_2","a b c")]] + return (id',classes',keyvals) + +shrinkAttr :: Attr -> [Attr] +shrinkAttr (a, b, c) + = [ (a', b', c') | a' <- shrinkText a, + b' <- liftShrink shrinkText b, + c' <- liftShrink shrinkText2 c ] + +instance Arbitrary Inlines where + arbitrary = (fromList :: [Inline] -> Inlines) <$> arbitrary + shrink = fmap fromList . ((++) <$> shrink <*> flattenShrinkInlines) . toList + where flattenShrinkInlines (x:xs) = + let x' = flattenInline x + in [x' ++ xs | not (null x')] ++ [x:xs' | xs' <- flattenShrinkInlines xs] + flattenShrinkInlines [] = [] + flattenInline :: Inline -> [Inline] + flattenInline (Str _) = [] + flattenInline (Emph ils) = ils + flattenInline (Underline ils) = ils + flattenInline (Strong ils) = ils + flattenInline (Strikeout ils) = ils + flattenInline (Superscript ils) = ils + flattenInline (Subscript ils) = ils + flattenInline (SmallCaps ils) = ils + flattenInline (Quoted _ ils) = ils + flattenInline (Cite _ ils) = ils + flattenInline Code{} = [] + flattenInline Space = [] + flattenInline SoftBreak = [] + flattenInline LineBreak = [] + flattenInline Math{} = [] + flattenInline RawInline{} = [] + flattenInline (Link _ ils _) = ils + flattenInline (Image _ ils _) = ils + flattenInline Note{} = [] + flattenInline (Span _ ils) = ils + +instance Arbitrary Blocks where + arbitrary = (fromList :: [Block] -> Blocks) <$> arbitrary + shrink = fmap fromList . ((++) <$> shrink <*> flattenShrinkBlocks) . toList + where flattenShrinkBlocks (x:xs) = + let x' = flattenBlock x + in [x' ++ xs | not (null x')] ++ [x:xs' | xs' <- flattenShrinkBlocks xs] + flattenShrinkBlocks [] = [] + flattenBlock :: Block -> [Block] + flattenBlock Plain{} = [] + flattenBlock Para{} = [] + flattenBlock (LineBlock lns) = [Para x | x <- lns] + flattenBlock CodeBlock{} = [] + flattenBlock RawBlock{} = [] + flattenBlock (BlockQuote blks) = blks + flattenBlock (OrderedList _ blksList) = concat blksList + flattenBlock (BulletList blksList) = concat blksList + flattenBlock (DefinitionList defs) = concat [Para ils:concat blks | (ils, blks) <- defs] + flattenBlock (Header _ _ ils) = [Para ils] + flattenBlock HorizontalRule = [] + flattenBlock (Table _ capt _ hd bd ft) = flattenCaption capt <> + flattenTableHead hd <> + concatMap flattenTableBody bd <> + flattenTableFoot ft + flattenBlock (Figure _ capt blks) = flattenCaption capt <> blks + flattenBlock (Div _ blks) = blks + + flattenCaption (Caption Nothing body) = body + flattenCaption (Caption (Just ils) body) = Para ils : body + + flattenTableHead (TableHead _ body) = flattenRows body + flattenTableBody (TableBody _ _ hd bd) = flattenRows hd <> flattenRows bd + flattenTableFoot (TableFoot _ body) = flattenRows body + + flattenRows = concatMap flattenRow + flattenRow (Row _ body) = concatMap flattenCell body + flattenCell (Cell _ _ _ _ blks) = blks + +shrinkInlineList :: [Inline] -> [[Inline]] +shrinkInlineList = fmap toList . shrink . fromList + +shrinkInlinesList :: [[Inline]] -> [[[Inline]]] +shrinkInlinesList = fmap (fmap toList) . shrink . fmap fromList + +shrinkBlockList :: [Block] -> [[Block]] +shrinkBlockList = fmap toList . shrink . fromList + +shrinkBlocksList :: [[Block]] -> [[[Block]]] +shrinkBlocksList = fmap (fmap toList) . shrink . fmap fromList + +instance Arbitrary Inline where + arbitrary = resize 3 $ arbInline 2 + shrink (Str s) = Str <$> shrinkText s + shrink (Emph ils) = Emph <$> shrinkInlineList ils + shrink (Underline ils) = Underline <$> shrinkInlineList ils + shrink (Strong ils) = Strong <$> shrinkInlineList ils + shrink (Strikeout ils) = Strikeout <$> shrinkInlineList ils + shrink (Superscript ils) = Superscript <$> shrinkInlineList ils + shrink (Subscript ils) = Subscript <$> shrinkInlineList ils + shrink (SmallCaps ils) = SmallCaps <$> shrinkInlineList ils + shrink (Quoted qtype ils) = Quoted qtype <$> shrinkInlineList ils + shrink (Cite cits ils) = (Cite cits <$> shrinkInlineList ils) + ++ (flip Cite ils <$> shrink cits) + shrink (Code attr s) = (Code attr <$> shrinkText s) + ++ (flip Code s <$> shrinkAttr attr) + shrink Space = [] + shrink SoftBreak = [] + shrink LineBreak = [] + shrink (Math mtype s) = Math mtype <$> shrinkText s + shrink (RawInline fmt s) = RawInline fmt <$> shrinkText s + shrink (Link attr ils target) = [Link attr ils' target | ils' <- shrinkInlineList ils] + ++ [Link attr ils target' | target' <- shrinkText2 target] + ++ [Link attr' ils target | attr' <- shrinkAttr attr] + shrink (Image attr ils target) = [Image attr ils' target | ils' <- shrinkInlineList ils] + ++ [Image attr ils target' | target' <- shrinkText2 target] + ++ [Image attr' ils target | attr' <- shrinkAttr attr] + shrink (Note blks) = Note <$> shrinkBlockList blks + shrink (Span attr s) = (Span attr <$> shrink s) + ++ (flip Span s <$> shrinkAttr attr) + +arbInlines :: Int -> Gen [Inline] +arbInlines n = listOf1 (arbInline n) `suchThat` (not . startsWithSpace) + where startsWithSpace (Space:_) = True + startsWithSpace (SoftBreak:_) = True + -- Note: no LineBreak, similarly to Text.Pandoc.Builder (trimInlines) + startsWithSpace _ = False + +-- restrict to 3 levels of nesting max; otherwise we get +-- bogged down in indefinitely large structures +arbInline :: Int -> Gen Inline +arbInline n = frequency $ [ (60, Str <$> realString) + , (40, pure Space) + , (10, pure SoftBreak) + , (10, pure LineBreak) + , (10, Code <$> arbAttr <*> realString) + , (5, elements [ RawInline (Format "html") "" + , RawInline (Format "latex") "\\my{command}" ]) + ] ++ [ x | n > 1, x <- nesters] + where nesters = [ (10, Emph <$> arbInlines (n-1)) + , (10, Underline <$> arbInlines (n-1)) + , (10, Strong <$> arbInlines (n-1)) + , (10, Strikeout <$> arbInlines (n-1)) + , (10, Superscript <$> arbInlines (n-1)) + , (10, Subscript <$> arbInlines (n-1)) + , (10, SmallCaps <$> arbInlines (n-1)) + , (10, Span <$> arbAttr <*> arbInlines (n-1)) + , (10, Quoted <$> arbitrary <*> arbInlines (n-1)) + , (10, Math <$> arbitrary <*> realString) + , (10, Link <$> arbAttr <*> arbInlines (n-1) <*> ((,) <$> realString <*> realString)) + , (10, Image <$> arbAttr <*> arbInlines (n-1) <*> ((,) <$> realString <*> realString)) + , (2, Cite <$> arbitrary <*> arbInlines 1) + , (2, Note <$> resize 3 (listOf1 $ arbBlock (n-1))) + ] + +instance Arbitrary Block where + arbitrary = resize 3 $ arbBlock 2 + shrink (Plain ils) = Plain <$> shrinkInlineList ils + shrink (Para ils) = Para <$> shrinkInlineList ils + shrink (LineBlock lns) = LineBlock <$> shrinkInlinesList lns + shrink (CodeBlock attr s) = (CodeBlock attr <$> shrinkText s) + ++ (flip CodeBlock s <$> shrinkAttr attr) + shrink (RawBlock fmt s) = RawBlock fmt <$> shrinkText s + shrink (BlockQuote blks) = BlockQuote <$> shrinkBlockList blks + shrink (OrderedList listAttrs blksList) = OrderedList listAttrs <$> shrinkBlocksList blksList + shrink (BulletList blksList) = BulletList <$> shrinkBlocksList blksList + shrink (DefinitionList defs) = DefinitionList <$> shrinkDefinitionList defs + where shrinkDefinition (ils, blksList) = [(ils', blksList) | ils' <- shrinkInlineList ils] + ++ [(ils, blksList') | blksList' <- shrinkBlocksList blksList] + shrinkDefinitionList (x:xs) = [xs] + ++ [x':xs | x' <- shrinkDefinition x] + ++ [x:xs' | xs' <- shrinkDefinitionList xs] + shrinkDefinitionList [] = [] + shrink (Header n attr ils) = (Header n attr <$> shrinkInlineList ils) + ++ (flip (Header n) ils <$> shrinkAttr attr) + shrink HorizontalRule = [] + shrink (Table attr capt specs thead tbody tfoot) = + -- TODO: shrink number of columns + [Table attr' capt specs thead tbody tfoot | attr' <- shrinkAttr attr] ++ + [Table attr capt specs thead' tbody tfoot | thead' <- shrink thead] ++ + [Table attr capt specs thead tbody' tfoot | tbody' <- shrink tbody] ++ + [Table attr capt specs thead tbody tfoot' | tfoot' <- shrink tfoot] ++ + [Table attr capt' specs thead tbody tfoot | capt' <- shrink capt] + shrink (Figure attr capt blks) = + [Figure attr capt blks' | blks' <- shrinkBlockList blks] ++ + [Figure attr capt' blks | capt' <- shrink capt] ++ + [Figure attr' capt blks | attr' <- shrinkAttr attr] + shrink (Div attr blks) = (Div attr <$> shrinkBlockList blks) + ++ (flip Div blks <$> shrinkAttr attr) + +arbBlock :: Int -> Gen Block +arbBlock n = frequency $ [ (10, Plain <$> arbInlines (n-1)) + , (15, Para <$> arbInlines (n-1)) + , (5, CodeBlock <$> arbAttr <*> realString) + , (3, LineBlock <$> + ((:) <$> + arbInlines ((n - 1) `mod` 3) <*> + forM [1..((n - 1) `div` 3)] (const (arbInlines 3)))) + , (2, elements [ RawBlock (Format "html") + "
\n*&*\n
" + , RawBlock (Format "latex") + "\\begin[opt]{env}\nhi\n{\\end{env}" + ]) + , (5, Header <$> choose (1 :: Int, 6) + <*> pure nullAttr + <*> arbInlines (n-1)) + , (2, pure HorizontalRule) + ] ++ [x | n > 0, x <- nesters] + where nesters = [ (5, BlockQuote <$> listOf1 (arbBlock (n-1))) + , (5, OrderedList <$> ((,,) <$> (arbitrary `suchThat` (> 0)) + <*> arbitrary + <*> arbitrary) + <*> listOf1 (listOf1 $ arbBlock (n-1))) + , (5, BulletList <$> listOf1 (listOf1 $ arbBlock (n-1))) + , (5, DefinitionList <$> listOf1 ((,) <$> arbInlines (n-1) + <*> listOf1 (listOf1 $ arbBlock (n-1)))) + , (5, Div <$> arbAttr <*> listOf1 (arbBlock (n-1))) + , (2, do cs <- choose (1 :: Int, 6) + bs <- choose (0 :: Int, 2) + Table <$> arbAttr + <*> arbitrary + <*> vectorOf cs ((,) <$> arbitrary + <*> elements [ ColWidthDefault + , ColWidth (1/3) + , ColWidth 0.25 ]) + <*> arbTableHead (n-1) + <*> vectorOf bs (arbTableBody (n-1)) + <*> arbTableFoot (n-1)) + , (2, Figure <$> arbAttr + <*> arbitrary + <*> listOf1 (arbBlock (n-1))) + ] + +arbRow :: Int -> Gen Row +arbRow n = do + cs <- choose (0, 5) + Row <$> arbAttr <*> vectorOf cs (arbCell n) + +arbTableHead :: Int -> Gen TableHead +arbTableHead n = do + rs <- choose (0, 5) + TableHead <$> arbAttr <*> vectorOf rs (arbRow n) + +arbTableBody :: Int -> Gen TableBody +arbTableBody n = do + hrs <- choose (0 :: Int, 2) + rs <- choose (0, 5) + rhc <- choose (0, 5) + TableBody <$> arbAttr + <*> pure (RowHeadColumns rhc) + <*> vectorOf hrs (arbRow n) + <*> vectorOf rs (arbRow n) + +arbTableFoot :: Int -> Gen TableFoot +arbTableFoot n = do + rs <- choose (0, 5) + TableFoot <$> arbAttr <*> vectorOf rs (arbRow n) + +arbCell :: Int -> Gen Cell +arbCell n = Cell <$> arbAttr + <*> arbitrary + <*> (RowSpan <$> choose (1 :: Int, 2)) + <*> (ColSpan <$> choose (1 :: Int, 2)) + <*> listOf (arbBlock n) + +instance Arbitrary Pandoc where + arbitrary = resize 8 (Pandoc <$> arbitrary <*> arbitrary) + +instance Arbitrary CitationMode where + arbitrary + = do x <- choose (0 :: Int, 2) + case x of + 0 -> return AuthorInText + 1 -> return SuppressAuthor + 2 -> return NormalCitation + _ -> error "FATAL ERROR: Arbitrary instance, logic bug" + +instance Arbitrary Citation where + arbitrary + = Citation <$> fmap T.pack (listOf $ elements $ ['a'..'z'] ++ ['0'..'9'] ++ ['_']) + <*> arbInlines 1 + <*> arbInlines 1 + <*> arbitrary + <*> arbitrary + <*> arbitrary + +instance Arbitrary Row where + arbitrary = resize 3 $ arbRow 2 + shrink (Row attr body) + = [Row attr' body | attr' <- shrinkAttr attr] ++ + [Row attr body' | body' <- shrink body] + +instance Arbitrary TableHead where + arbitrary = resize 3 $ arbTableHead 2 + shrink (TableHead attr body) + = [TableHead attr' body | attr' <- shrinkAttr attr] ++ + [TableHead attr body' | body' <- shrink body] + +instance Arbitrary TableBody where + arbitrary = resize 3 $ arbTableBody 2 + -- TODO: shrink rhc? + shrink (TableBody attr rhc hd bd) + = [TableBody attr' rhc hd bd | attr' <- shrinkAttr attr] ++ + [TableBody attr rhc hd' bd | hd' <- shrink hd] ++ + [TableBody attr rhc hd bd' | bd' <- shrink bd] + +instance Arbitrary TableFoot where + arbitrary = resize 3 $ arbTableFoot 2 + shrink (TableFoot attr body) + = [TableFoot attr' body | attr' <- shrinkAttr attr] ++ + [TableFoot attr body' | body' <- shrink body] + +instance Arbitrary Cell where + arbitrary = resize 3 $ arbCell 2 + shrink (Cell attr malign h w body) + = [Cell attr malign h w body' | body' <- shrinkBlockList body] ++ + [Cell attr' malign h w body | attr' <- shrinkAttr attr] ++ + [Cell attr malign' h w body | malign' <- shrink malign] + +instance Arbitrary Caption where + arbitrary = Caption <$> arbitrary <*> arbitrary + shrink (Caption mshort body) + = [Caption mshort' body | mshort' <- shrink mshort] ++ + [Caption mshort body' | body' <- shrinkBlockList body] + +instance Arbitrary MathType where + arbitrary + = do x <- choose (0 :: Int, 1) + case x of + 0 -> return DisplayMath + 1 -> return InlineMath + _ -> error "FATAL ERROR: Arbitrary instance, logic bug" + +instance Arbitrary QuoteType where + arbitrary + = do x <- choose (0 :: Int, 1) + case x of + 0 -> return SingleQuote + 1 -> return DoubleQuote + _ -> error "FATAL ERROR: Arbitrary instance, logic bug" + +instance Arbitrary Meta where + arbitrary + = do (x1 :: Inlines) <- arbitrary + (x2 :: [Inlines]) <- filter (not . null) <$> arbitrary + (x3 :: Inlines) <- arbitrary + return $ setMeta "title" x1 + $ setMeta "author" x2 + $ setMeta "date" x3 + nullMeta + +instance Arbitrary Alignment where + arbitrary + = do x <- choose (0 :: Int, 3) + case x of + 0 -> return AlignLeft + 1 -> return AlignRight + 2 -> return AlignCenter + 3 -> return AlignDefault + _ -> error "FATAL ERROR: Arbitrary instance, logic bug" + +instance Arbitrary ListNumberStyle where + arbitrary + = do x <- choose (0 :: Int, 6) + case x of + 0 -> return DefaultStyle + 1 -> return Example + 2 -> return Decimal + 3 -> return LowerRoman + 4 -> return UpperRoman + 5 -> return LowerAlpha + 6 -> return UpperAlpha + _ -> error "FATAL ERROR: Arbitrary instance, logic bug" + +instance Arbitrary ListNumberDelim where + arbitrary + = do x <- choose (0 :: Int, 3) + case x of + 0 -> return DefaultDelim + 1 -> return Period + 2 -> return OneParen + 3 -> return TwoParens + _ -> error "FATAL ERROR: Arbitrary instance, logic bug" diff --git a/src/Text/Pandoc/Builder.hs b/src/Text/Pandoc/Builder.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Builder.hs @@ -0,0 +1,756 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, DeriveDataTypeable, + GeneralizedNewtypeDeriving, CPP, StandaloneDeriving, DeriveGeneric, + DeriveTraversable, OverloadedStrings, PatternGuards #-} + +{- +Copyright (C) 2010-2023 John MacFarlane + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of John MacFarlane nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-} + +{- | + Module : Text.Pandoc.Builder + Copyright : Copyright (C) 2010-2023 John MacFarlane + License : BSD3 + + Maintainer : John MacFarlane + Stability : alpha + Portability : portable + +Convenience functions for building pandoc documents programmatically. + +Example of use (with @OverloadedStrings@ pragma): + +> import Text.Pandoc.Builder +> +> myDoc :: Pandoc +> myDoc = setTitle "My title" $ doc $ +> para "This is the first paragraph" <> +> para ("And " <> emph "another" <> ".") <> +> bulletList [ para "item one" <> para "continuation" +> , plain ("item two and a " <> +> link "/url" "go to url" "link") +> ] + +Isn't that nicer than writing the following? + +> import Text.Pandoc.Definition +> import Data.Map (fromList) +> +> myDoc :: Pandoc +> myDoc = Pandoc (Meta {unMeta = fromList [("title", +> MetaInlines [Str "My",Space,Str "title"])]}) +> [Para [Str "This",Space,Str "is",Space,Str "the",Space,Str "first", +> Space,Str "paragraph"],Para [Str "And",Space,Emph [Str "another"], +> Str "."] +> ,BulletList [ +> [Para [Str "item",Space,Str "one"] +> ,Para [Str "continuation"]] +> ,[Plain [Str "item",Space,Str "two",Space,Str "and",Space, +> Str "a",Space,Link nullAttr [Str "link"] ("/url","go to url")]]]] + +And of course, you can use Haskell to define your own builders: + +> import Text.Pandoc.Builder +> import Text.JSON +> import Control.Arrow ((***)) +> import Data.Monoid (mempty) +> +> -- | Converts a JSON document into 'Blocks'. +> json :: String -> Blocks +> json x = +> case decode x of +> Ok y -> jsValueToBlocks y +> Error y -> error y +> where jsValueToBlocks x = +> case x of +> JSNull -> mempty +> JSBool x -> plain $ text $ show x +> JSRational _ x -> plain $ text $ show x +> JSString x -> plain $ text $ fromJSString x +> JSArray xs -> bulletList $ map jsValueToBlocks xs +> JSObject x -> definitionList $ +> map (text *** (:[]) . jsValueToBlocks) $ +> fromJSObject x + +-} + +module Text.Pandoc.Builder ( module Text.Pandoc.Definition + , Many(..) + , Inlines + , Blocks + , (<>) + , singleton + , toList + , fromList + , isNull + -- * Document builders + , doc + , ToMetaValue(..) + , HasMeta(..) + , setTitle + , setAuthors + , setDate + -- * Inline list builders + , text + , str + , emph + , underline + , strong + , strikeout + , superscript + , subscript + , smallcaps + , singleQuoted + , doubleQuoted + , cite + , codeWith + , code + , space + , softbreak + , linebreak + , math + , displayMath + , rawInline + , link + , linkWith + , image + , imageWith + , note + , spanWith + , trimInlines + -- * Block list builders + , para + , plain + , lineBlock + , codeBlockWith + , codeBlock + , rawBlock + , blockQuote + , bulletList + , orderedListWith + , orderedList + , definitionList + , header + , headerWith + , horizontalRule + , cell + , simpleCell + , emptyCell + , cellWith + , table + , simpleTable + , tableWith + , figure + , figureWith + , caption + , simpleCaption + , emptyCaption + , simpleFigureWith + , simpleFigure + , divWith + -- * Table processing + , normalizeTableHead + , normalizeTableBody + , normalizeTableFoot + , placeRowSection + , clipRows + ) +where +import Text.Pandoc.Definition +import Data.String +import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Text as T +import Data.Sequence (Seq, (|>), viewr, viewl, ViewR(..), ViewL(..)) +import qualified Data.Sequence as Seq +import qualified Data.Foldable as F +import Data.Data +import Control.Arrow ((***)) +import GHC.Generics (Generic) + +newtype Many a = Many { unMany :: Seq a } + deriving (Data, Ord, Eq, Typeable, Foldable, Traversable, Functor, Show, Read) + +deriving instance Generic (Many a) + +toList :: Many a -> [a] +toList = F.toList + +singleton :: a -> Many a +singleton = Many . Seq.singleton + +fromList :: [a] -> Many a +fromList = Many . Seq.fromList + +{-# DEPRECATED isNull "Use null instead" #-} +isNull :: Many a -> Bool +isNull = Seq.null . unMany + +type Inlines = Many Inline +type Blocks = Many Block + +deriving instance Semigroup Blocks +deriving instance Monoid Blocks + +instance Semigroup Inlines where + (Many xs) <> (Many ys) = + case (viewr xs, viewl ys) of + (EmptyR, _) -> Many ys + (_, EmptyL) -> Many xs + (xs' :> x, y :< ys') -> Many (meld <> ys') + where meld = case (x, y) of + (Space, Space) -> xs' |> Space + (Space, SoftBreak) -> xs' |> SoftBreak + (SoftBreak, Space) -> xs' |> SoftBreak + (Str t1, Str t2) -> xs' |> Str (t1 <> t2) + (Emph i1, Emph i2) -> xs' |> Emph (i1 <> i2) + (Underline i1, Underline i2) -> xs' |> Underline (i1 <> i2) + (Strong i1, Strong i2) -> xs' |> Strong (i1 <> i2) + (Subscript i1, Subscript i2) -> xs' |> Subscript (i1 <> i2) + (Superscript i1, Superscript i2) -> xs' |> Superscript (i1 <> i2) + (Strikeout i1, Strikeout i2) -> xs' |> Strikeout (i1 <> i2) + (Space, LineBreak) -> xs' |> LineBreak + (LineBreak, Space) -> xs' |> LineBreak + (SoftBreak, LineBreak) -> xs' |> LineBreak + (LineBreak, SoftBreak) -> xs' |> LineBreak + (SoftBreak, SoftBreak) -> xs' |> SoftBreak + _ -> xs' |> x |> y +instance Monoid Inlines where + mempty = Many mempty + mappend = (<>) + +instance IsString Inlines where + fromString = text . T.pack + +-- | Trim leading and trailing spaces and softbreaks from an Inlines. +trimInlines :: Inlines -> Inlines +#if MIN_VERSION_containers(0,4,0) +trimInlines (Many ils) = Many $ Seq.dropWhileL isSp $ + Seq.dropWhileR isSp $ ils +#else +-- for GHC 6.12, we need to workaround a bug in dropWhileR +-- see http://hackage.haskell.org/trac/ghc/ticket/4157 +trimInlines (Many ils) = Many $ Seq.dropWhileL isSp $ + Seq.reverse $ Seq.dropWhileL isSp $ + Seq.reverse ils +#endif + where isSp Space = True + isSp SoftBreak = True + isSp _ = False + +-- Document builders + +doc :: Blocks -> Pandoc +doc = Pandoc nullMeta . toList + +class ToMetaValue a where + toMetaValue :: a -> MetaValue + +instance ToMetaValue MetaValue where + toMetaValue = id + +instance ToMetaValue Blocks where + toMetaValue = MetaBlocks . toList + +instance ToMetaValue Inlines where + toMetaValue = MetaInlines . toList + +instance ToMetaValue Bool where + toMetaValue = MetaBool + +instance ToMetaValue Text where + toMetaValue = MetaString + +instance {-# OVERLAPPING #-} ToMetaValue String where + toMetaValue = MetaString . T.pack + +instance ToMetaValue a => ToMetaValue [a] where + toMetaValue = MetaList . map toMetaValue + +instance ToMetaValue a => ToMetaValue (M.Map Text a) where + toMetaValue = MetaMap . M.map toMetaValue + +instance ToMetaValue a => ToMetaValue (M.Map String a) where + toMetaValue = MetaMap . M.map toMetaValue . M.mapKeys T.pack + +class HasMeta a where + setMeta :: ToMetaValue b => Text -> b -> a -> a + deleteMeta :: Text -> a -> a + +instance HasMeta Meta where + setMeta key val (Meta ms) = Meta $ M.insert key (toMetaValue val) ms + deleteMeta key (Meta ms) = Meta $ M.delete key ms + +instance HasMeta Pandoc where + setMeta key val (Pandoc (Meta ms) bs) = + Pandoc (Meta $ M.insert key (toMetaValue val) ms) bs + deleteMeta key (Pandoc (Meta ms) bs) = + Pandoc (Meta $ M.delete key ms) bs + +setTitle :: Inlines -> Pandoc -> Pandoc +setTitle = setMeta "title" + +setAuthors :: [Inlines] -> Pandoc -> Pandoc +setAuthors = setMeta "author" + +setDate :: Inlines -> Pandoc -> Pandoc +setDate = setMeta "date" + +-- Inline list builders + +-- | Convert a 'Text' to 'Inlines', treating interword spaces as 'Space's +-- or 'SoftBreak's. If you want a 'Str' with literal spaces, use 'str'. +text :: Text -> Inlines +text = fromList . map conv . breakBySpaces + where breakBySpaces = T.groupBy sameCategory + sameCategory x y = is_space x == is_space y + conv xs | T.all is_space xs = + if T.any is_newline xs + then SoftBreak + else Space + conv xs = Str xs + is_space ' ' = True + is_space '\r' = True + is_space '\n' = True + is_space '\t' = True + is_space _ = False + is_newline '\r' = True + is_newline '\n' = True + is_newline _ = False + +str :: Text -> Inlines +str = singleton . Str + +emph :: Inlines -> Inlines +emph = singleton . Emph . toList + +underline :: Inlines -> Inlines +underline = singleton . Underline . toList + +strong :: Inlines -> Inlines +strong = singleton . Strong . toList + +strikeout :: Inlines -> Inlines +strikeout = singleton . Strikeout . toList + +superscript :: Inlines -> Inlines +superscript = singleton . Superscript . toList + +subscript :: Inlines -> Inlines +subscript = singleton . Subscript . toList + +smallcaps :: Inlines -> Inlines +smallcaps = singleton . SmallCaps . toList + +singleQuoted :: Inlines -> Inlines +singleQuoted = quoted SingleQuote + +doubleQuoted :: Inlines -> Inlines +doubleQuoted = quoted DoubleQuote + +quoted :: QuoteType -> Inlines -> Inlines +quoted qt = singleton . Quoted qt . toList + +cite :: [Citation] -> Inlines -> Inlines +cite cts = singleton . Cite cts . toList + +-- | Inline code with attributes. +codeWith :: Attr -> Text -> Inlines +codeWith attrs = singleton . Code attrs + +-- | Plain inline code. +code :: Text -> Inlines +code = codeWith nullAttr + +space :: Inlines +space = singleton Space + +softbreak :: Inlines +softbreak = singleton SoftBreak + +linebreak :: Inlines +linebreak = singleton LineBreak + +-- | Inline math +math :: Text -> Inlines +math = singleton . Math InlineMath + +-- | Display math +displayMath :: Text -> Inlines +displayMath = singleton . Math DisplayMath + +rawInline :: Text -> Text -> Inlines +rawInline format = singleton . RawInline (Format format) + +link :: Text -- ^ URL + -> Text -- ^ Title + -> Inlines -- ^ Label + -> Inlines +link = linkWith nullAttr + +linkWith :: Attr -- ^ Attributes + -> Text -- ^ URL + -> Text -- ^ Title + -> Inlines -- ^ Label + -> Inlines +linkWith attr url title x = singleton $ Link attr (toList x) (url, title) + +image :: Text -- ^ URL + -> Text -- ^ Title + -> Inlines -- ^ Alt text + -> Inlines +image = imageWith nullAttr + +imageWith :: Attr -- ^ Attributes + -> Text -- ^ URL + -> Text -- ^ Title + -> Inlines -- ^ Alt text + -> Inlines +imageWith attr url title x = singleton $ Image attr (toList x) (url, title) + +note :: Blocks -> Inlines +note = singleton . Note . toList + +spanWith :: Attr -> Inlines -> Inlines +spanWith attr = singleton . Span attr . toList + +-- Block list builders + +para :: Inlines -> Blocks +para = singleton . Para . toList + +plain :: Inlines -> Blocks +plain ils = if isNull ils + then mempty + else singleton . Plain . toList $ ils + +lineBlock :: [Inlines] -> Blocks +lineBlock = singleton . LineBlock . map toList + +-- | A code block with attributes. +codeBlockWith :: Attr -> Text -> Blocks +codeBlockWith attrs = singleton . CodeBlock attrs + +-- | A plain code block. +codeBlock :: Text -> Blocks +codeBlock = codeBlockWith nullAttr + +rawBlock :: Text -> Text -> Blocks +rawBlock format = singleton . RawBlock (Format format) + +blockQuote :: Blocks -> Blocks +blockQuote = singleton . BlockQuote . toList + +-- | Ordered list with attributes. +orderedListWith :: ListAttributes -> [Blocks] -> Blocks +orderedListWith attrs = singleton . OrderedList attrs . map toList + +-- | Ordered list with default attributes. +orderedList :: [Blocks] -> Blocks +orderedList = orderedListWith (1, DefaultStyle, DefaultDelim) + +bulletList :: [Blocks] -> Blocks +bulletList = singleton . BulletList . map toList + +definitionList :: [(Inlines, [Blocks])] -> Blocks +definitionList = singleton . DefinitionList . map (toList *** map toList) + +header :: Int -- ^ Level + -> Inlines + -> Blocks +header = headerWith nullAttr + +headerWith :: Attr -> Int -> Inlines -> Blocks +headerWith attr level = singleton . Header level attr . toList + +horizontalRule :: Blocks +horizontalRule = singleton HorizontalRule + +cellWith :: Attr + -> Alignment + -> RowSpan + -> ColSpan + -> Blocks + -> Cell +cellWith at a r c = Cell at a r c . toList + +cell :: Alignment + -> RowSpan + -> ColSpan + -> Blocks + -> Cell +cell = cellWith nullAttr + +-- | A 1×1 cell with default alignment. +simpleCell :: Blocks -> Cell +simpleCell = cell AlignDefault 1 1 + +-- | A 1×1 empty cell. +emptyCell :: Cell +emptyCell = simpleCell mempty + +-- | Table builder. Performs normalization with 'normalizeTableHead', +-- 'normalizeTableBody', and 'normalizeTableFoot'. The number of table +-- columns is given by the length of @['ColSpec']@. +table :: Caption + -> [ColSpec] + -> TableHead + -> [TableBody] + -> TableFoot + -> Blocks +table = tableWith nullAttr + +tableWith :: Attr + -> Caption + -> [ColSpec] + -> TableHead + -> [TableBody] + -> TableFoot + -> Blocks +tableWith attr capt specs th tbs tf + = singleton $ Table attr capt specs th' tbs' tf' + where + twidth = length specs + th' = normalizeTableHead twidth th + tbs' = map (normalizeTableBody twidth) tbs + tf' = normalizeTableFoot twidth tf + +-- | A simple table without a caption. +simpleTable :: [Blocks] -- ^ Headers + -> [[Blocks]] -- ^ Rows + -> Blocks +simpleTable headers rows = + table emptyCaption (replicate numcols defaults) th [tb] tf + where defaults = (AlignDefault, ColWidthDefault) + numcols = maximum (map length (headers:rows)) + toRow = Row nullAttr . map simpleCell + toHeaderRow l + | null l = [] + | otherwise = [toRow headers] + th = TableHead nullAttr (toHeaderRow headers) + tb = TableBody nullAttr 0 [] $ map toRow rows + tf = TableFoot nullAttr [] + +figure :: Caption -> Blocks -> Blocks +figure = figureWith nullAttr + +figureWith :: Attr -> Caption -> Blocks -> Blocks +figureWith attr capt = singleton . Figure attr capt . toList + +caption :: Maybe ShortCaption -> Blocks -> Caption +caption x = Caption x . toList + +simpleCaption :: Blocks -> Caption +simpleCaption = caption Nothing + +emptyCaption :: Caption +emptyCaption = simpleCaption mempty + +-- | Creates a simple figure from attributes, a figure caption, an image +-- path and image title. The attributes are used as the image +-- attributes. +simpleFigureWith :: Attr -> Inlines -> Text -> Text -> Blocks +simpleFigureWith attr figureCaption url title = + figure (simpleCaption (plain figureCaption)) . plain $ + imageWith attr url title mempty + +simpleFigure :: Inlines -> Text -> Text -> Blocks +simpleFigure = simpleFigureWith nullAttr + +divWith :: Attr -> Blocks -> Blocks +divWith attr = singleton . Div attr . toList + +-- | Normalize the 'TableHead' with 'clipRows' and 'placeRowSection' +-- so that when placed on a grid with the given width and a height +-- equal to the number of rows in the initial 'TableHead', there will +-- be no empty spaces or overlapping cells, and the cells will not +-- protrude beyond the grid. +normalizeTableHead :: Int -> TableHead -> TableHead +normalizeTableHead twidth (TableHead attr rows) + = TableHead attr $ normalizeHeaderSection twidth rows + +-- | Normalize the intermediate head and body section of a +-- 'TableBody', as in 'normalizeTableHead', but additionally ensure +-- that row head cells do not go beyond the row head inside the +-- intermediate body. +normalizeTableBody :: Int -> TableBody -> TableBody +normalizeTableBody twidth (TableBody attr rhc th tb) + = TableBody attr + rhc' + (normalizeHeaderSection twidth th) + (normalizeBodySection twidth rhc' tb) + where + rhc' = max 0 $ min (RowHeadColumns twidth) rhc + +-- | Normalize the 'TableFoot', as in 'normalizeTableHead'. +normalizeTableFoot :: Int -> TableFoot -> TableFoot +normalizeTableFoot twidth (TableFoot attr rows) + = TableFoot attr $ normalizeHeaderSection twidth rows + +normalizeHeaderSection :: Int -- ^ The desired width of the table + -> [Row] + -> [Row] +normalizeHeaderSection twidth rows + = normalizeRows' (replicate twidth 1) $ clipRows rows + where + normalizeRows' oldHang (Row attr cells:rs) + = let (newHang, cells', _) = placeRowSection oldHang $ cells <> repeat emptyCell + rs' = normalizeRows' newHang rs + in Row attr cells' : rs' + normalizeRows' _ [] = [] + +normalizeBodySection :: Int -- ^ The desired width of the table + -> RowHeadColumns -- ^ The width of the row head, + -- between 0 and the table + -- width + -> [Row] + -> [Row] +normalizeBodySection twidth (RowHeadColumns rhc) rows + = normalizeRows' (replicate rhc 1) (replicate rbc 1) $ clipRows rows + where + rbc = twidth - rhc + + normalizeRows' headHang bodyHang (Row attr cells:rs) + = let (headHang', rowHead, cells') = placeRowSection headHang $ cells <> repeat emptyCell + (bodyHang', rowBody, _) = placeRowSection bodyHang cells' + rs' = normalizeRows' headHang' bodyHang' rs + in Row attr (rowHead <> rowBody) : rs' + normalizeRows' _ _ [] = [] + +-- | Normalize the given list of cells so that they fit on a single +-- grid row. The 'RowSpan' values of the cells are assumed to be valid +-- (clamped to lie between 1 and the remaining grid height). The cells +-- in the list are also assumed to be able to fill the entire grid +-- row. These conditions can be met by appending @repeat 'emptyCell'@ +-- to the @['Cell']@ list and using 'clipRows' on the entire table +-- section beforehand. +-- +-- Normalization follows the principle that cells are placed on a grid +-- row in order, each at the first available grid position from the +-- left, having their 'ColSpan' reduced if they would overlap with a +-- previous cell, stopping once the row is filled. Only the dimensions +-- of cells are changed, and only of those cells that fit on the row. +-- +-- Possible overlap is detected using the given @['RowSpan']@, which +-- is the "overhang" of the previous grid row, a list of the heights +-- of cells that descend through the previous row, reckoned +-- /only from the previous row/. +-- Its length should be the width (number of columns) of the current +-- grid row. +-- +-- For example, the numbers in the following headerless grid table +-- represent the overhang at each grid position for that table: +-- +-- @ +-- 1 1 1 1 +-- +---+---+---+---+ +-- | 1 | 2 2 | 3 | +-- +---+ + + +-- | 1 | 1 1 | 2 | +-- +---+---+---+ + +-- | 1 1 | 1 | 1 | +-- +---+---+---+---+ +-- @ +-- +-- In any table, the row before the first has an overhang of +-- @replicate tableWidth 1@, since there are no cells to descend into +-- the table from there. The overhang of the first row in the example +-- is @[1, 2, 2, 3]@. +-- +-- So if after 'clipRows' the unnormalized second row of that example +-- table were +-- +-- > r = [("a", 1, 2),("b", 2, 3)] -- the cells displayed as (label, RowSpan, ColSpan) only +-- +-- a correct invocation of 'placeRowSection' to normalize it would be +-- +-- >>> placeRowSection [1, 2, 2, 3] $ r ++ repeat emptyCell +-- ([1, 1, 1, 2], [("a", 1, 1)], [("b", 2, 3)] ++ repeat emptyCell) -- wouldn't stop printing, of course +-- +-- and if the third row were only @[("c", 1, 2)]@, then the expression +-- would be +-- +-- >>> placeRowSection [1, 1, 1, 2] $ [("c", 1, 2)] ++ repeat emptyCell +-- ([1, 1, 1, 1], [("c", 1, 2), emptyCell], repeat emptyCell) +placeRowSection :: [RowSpan] -- ^ The overhang of the previous grid + -- row + -> [Cell] -- ^ The cells to lay on the grid row + -> ([RowSpan], [Cell], [Cell]) -- ^ The overhang of + -- the current grid + -- row, the normalized + -- cells that fit on + -- the current row, and + -- the remaining + -- unmodified cells +placeRowSection oldHang cellStream + -- If the grid has overhang at our position, try to re-lay in + -- the next position. + | o:os <- oldHang + , o > 1 = let (newHang, newCell, cellStream') = placeRowSection os cellStream + in (o - 1 : newHang, newCell, cellStream') + -- Otherwise if there is any available width, place the cell and + -- continue. + | c:cellStream' <- cellStream + , (h, w) <- getDim c + , w' <- max 1 w + , (n, oldHang') <- dropAtMostWhile (== 1) (getColSpan w') oldHang + , n > 0 + = let w'' = min (ColSpan n) w' + c' = setW w'' c + (newHang, newCell, remainCell) = placeRowSection oldHang' cellStream' + in (replicate (getColSpan w'') h <> newHang, c' : newCell, remainCell) + -- Otherwise there is no room in the section, or not enough cells + -- were given. + | otherwise = ([], [], cellStream) + where + getColSpan (ColSpan w) = w + getDim (Cell _ _ h w _) = (h, w) + setW w (Cell a ma h _ b) = Cell a ma h w b + + dropAtMostWhile :: (a -> Bool) -> Int -> [a] -> (Int, [a]) + dropAtMostWhile p n = go 0 + where + go acc (l:ls) | p l && acc < n = go (acc+1) ls + go acc l = (acc, l) + +-- | Ensure that the height of each cell in a table section lies +-- between 1 and the distance from its row to the end of the +-- section. So if there were four rows in the input list, the cells in +-- the second row would have their height clamped between 1 and 3. +clipRows :: [Row] -> [Row] +clipRows rows + = let totalHeight = RowSpan $ length rows + in zipWith clipRowH [totalHeight, totalHeight - 1..1] rows + where + getH (Cell _ _ h _ _) = h + setH h (Cell a ma _ w body) = Cell a ma h w body + clipH low high c = let h = getH c in setH (min high $ max low h) c + clipRowH high (Row attr cells) = Row attr $ map (clipH 1 high) cells diff --git a/src/Text/Pandoc/Definition.hs b/src/Text/Pandoc/Definition.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Definition.hs @@ -0,0 +1,475 @@ +{-# LANGUAGE OverloadedStrings, DeriveDataTypeable, DeriveGeneric, + FlexibleContexts, GeneralizedNewtypeDeriving, PatternGuards, CPP, + TemplateHaskell , PatternSynonyms, ViewPatterns, StrictData #-} + +{- +Copyright (c) 2006-2023, John MacFarlane + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of John MacFarlane nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-} + +{- | + Module : Text.Pandoc.Definition + Copyright : Copyright (C) 2006-2023 John MacFarlane + License : BSD3 + + Maintainer : John MacFarlane + Stability : alpha + Portability : portable + +Definition of 'Pandoc' data structure for format-neutral representation +of documents. +-} +module Text.Pandoc.Definition ( Pandoc(..) + , Meta(..) + , MetaValue(..) + , nullMeta + , isNullMeta + , lookupMeta + , docTitle + , docAuthors + , docDate + , Block(..) + , pattern SimpleFigure + , Inline(..) + , ListAttributes + , ListNumberStyle(..) + , ListNumberDelim(..) + , Format(..) + , Attr + , nullAttr + , Caption(..) + , ShortCaption + , RowHeadColumns(..) + , Alignment(..) + , ColWidth(..) + , ColSpec + , Row(..) + , TableHead(..) + , TableBody(..) + , TableFoot(..) + , Cell(..) + , RowSpan(..) + , ColSpan(..) + , QuoteType(..) + , Target + , MathType(..) + , Citation(..) + , CitationMode(..) + , pandocTypesVersion + ) where + +import Data.Generics (Data, Typeable) +import Data.Ord (comparing) +import Data.Aeson +import Data.Aeson.TH (deriveJSON) +import qualified Data.Aeson.Types as Aeson +import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Text as T +import GHC.Generics (Generic) +import Data.String +import Control.DeepSeq +import Paths_pandoc_types (version) +import Data.Version (Version, versionBranch) +import Control.Arrow (second) + +data Pandoc = Pandoc Meta [Block] + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + +instance Semigroup Pandoc where + (Pandoc m1 bs1) <> (Pandoc m2 bs2) = + Pandoc (m1 <> m2) (bs1 <> bs2) +instance Monoid Pandoc where + mempty = Pandoc mempty mempty + mappend = (<>) + +-- | Metadata for the document: title, authors, date. +newtype Meta = Meta { unMeta :: M.Map Text MetaValue } + deriving (Eq, Ord, Show, Read, Typeable, Data, Generic) + +instance Semigroup Meta where + (Meta m1) <> (Meta m2) = Meta (M.union m2 m1) + -- note: M.union is left-biased, so if there are fields in both m2 + -- and m1, m2 wins. +instance Monoid Meta where + mempty = Meta M.empty + mappend = (<>) + +data MetaValue = MetaMap (M.Map Text MetaValue) + | MetaList [MetaValue] + | MetaBool Bool + | MetaString Text + | MetaInlines [Inline] + | MetaBlocks [Block] + deriving (Eq, Ord, Show, Read, Typeable, Data, Generic) + +nullMeta :: Meta +nullMeta = Meta M.empty + +isNullMeta :: Meta -> Bool +isNullMeta (Meta m) = M.null m + +-- Helper functions to extract metadata + +-- | Retrieve the metadata value for a given @key@. +lookupMeta :: Text -> Meta -> Maybe MetaValue +lookupMeta key (Meta m) = M.lookup key m + +-- | Extract document title from metadata; works just like the old @docTitle@. +docTitle :: Meta -> [Inline] +docTitle meta = + case lookupMeta "title" meta of + Just (MetaString s) -> [Str s] + Just (MetaInlines ils) -> ils + Just (MetaBlocks [Plain ils]) -> ils + Just (MetaBlocks [Para ils]) -> ils + _ -> [] + +-- | Extract document authors from metadata; works just like the old +-- @docAuthors@. +docAuthors :: Meta -> [[Inline]] +docAuthors meta = + case lookupMeta "author" meta of + Just (MetaString s) -> [[Str s]] + Just (MetaInlines ils) -> [ils] + Just (MetaList ms) -> [ils | MetaInlines ils <- ms] ++ + [ils | MetaBlocks [Plain ils] <- ms] ++ + [ils | MetaBlocks [Para ils] <- ms] ++ + [[Str x] | MetaString x <- ms] + _ -> [] + +-- | Extract date from metadata; works just like the old @docDate@. +docDate :: Meta -> [Inline] +docDate meta = + case lookupMeta "date" meta of + Just (MetaString s) -> [Str s] + Just (MetaInlines ils) -> ils + Just (MetaBlocks [Plain ils]) -> ils + Just (MetaBlocks [Para ils]) -> ils + _ -> [] + +-- | List attributes. The first element of the triple is the +-- start number of the list. +type ListAttributes = (Int, ListNumberStyle, ListNumberDelim) + +-- | Style of list numbers. +data ListNumberStyle = DefaultStyle + | Example + | Decimal + | LowerRoman + | UpperRoman + | LowerAlpha + | UpperAlpha deriving (Eq, Ord, Show, Read, Typeable, Data, Generic) + +-- | Delimiter of list numbers. +data ListNumberDelim = DefaultDelim + | Period + | OneParen + | TwoParens deriving (Eq, Ord, Show, Read, Typeable, Data, Generic) + +-- | Attributes: identifier, classes, key-value pairs +type Attr = (Text, [Text], [(Text, Text)]) + +nullAttr :: Attr +nullAttr = ("",[],[]) + +-- | Formats for raw blocks +newtype Format = Format Text + deriving (Read, Show, Typeable, Data, Generic, ToJSON, FromJSON) + +instance IsString Format where + fromString f = Format $ T.toCaseFold $ T.pack f + +instance Eq Format where + Format x == Format y = T.toCaseFold x == T.toCaseFold y + +instance Ord Format where + compare (Format x) (Format y) = compare (T.toCaseFold x) (T.toCaseFold y) + +-- | The number of columns taken up by the row head of each row of a +-- 'TableBody'. The row body takes up the remaining columns. +newtype RowHeadColumns = RowHeadColumns Int + deriving (Eq, Ord, Show, Read, Typeable, Data, Generic, Num, Enum, ToJSON, FromJSON) + +-- | Alignment of a table column. +data Alignment = AlignLeft + | AlignRight + | AlignCenter + | AlignDefault deriving (Eq, Ord, Show, Read, Typeable, Data, Generic) + +-- | The width of a table column, as a percentage of the text width. +data ColWidth = ColWidth Double + | ColWidthDefault deriving (Eq, Ord, Show, Read, Typeable, Data, Generic) + +-- | The specification for a single table column. +type ColSpec = (Alignment, ColWidth) + +-- | A table row. +data Row = Row Attr [Cell] + deriving (Eq, Ord, Show, Read, Typeable, Data, Generic) + +-- | The head of a table. +data TableHead = TableHead Attr [Row] + deriving (Eq, Ord, Show, Read, Typeable, Data, Generic) + +-- | A body of a table, with an intermediate head, intermediate body, +-- and the specified number of row header columns in the intermediate +-- body. +data TableBody = TableBody Attr RowHeadColumns [Row] [Row] + deriving (Eq, Ord, Show, Read, Typeable, Data, Generic) + +-- | The foot of a table. +data TableFoot = TableFoot Attr [Row] + deriving (Eq, Ord, Show, Read, Typeable, Data, Generic) + +-- | A short caption, for use in, for instance, lists of figures. +type ShortCaption = [Inline] + +-- | The caption of a table or figure, with optional short caption. +data Caption = Caption (Maybe ShortCaption) [Block] + deriving (Eq, Ord, Show, Read, Typeable, Data, Generic) + +-- | A table cell. +data Cell = Cell Attr Alignment RowSpan ColSpan [Block] + deriving (Eq, Ord, Show, Read, Typeable, Data, Generic) + +-- | The number of rows occupied by a cell; the height of a cell. +newtype RowSpan = RowSpan Int + deriving (Eq, Ord, Show, Read, Typeable, Data, Generic, Num, Enum, ToJSON, FromJSON) + +-- | The number of columns occupied by a cell; the width of a cell. +newtype ColSpan = ColSpan Int + deriving (Eq, Ord, Show, Read, Typeable, Data, Generic, Num, Enum, ToJSON, FromJSON) + +-- | Block element. +data Block + -- | Plain text, not a paragraph + = Plain [Inline] + -- | Paragraph + | Para [Inline] + -- | Multiple non-breaking lines + | LineBlock [[Inline]] + -- | Code block (literal) with attributes + | CodeBlock Attr Text + -- | Raw block + | RawBlock Format Text + -- | Block quote (list of blocks) + | BlockQuote [Block] + -- | Ordered list (attributes and a list of items, each a list of + -- blocks) + | OrderedList ListAttributes [[Block]] + -- | Bullet list (list of items, each a list of blocks) + | BulletList [[Block]] + -- | Definition list. Each list item is a pair consisting of a + -- term (a list of inlines) and one or more definitions (each a + -- list of blocks) + | DefinitionList [([Inline],[[Block]])] + -- | Header - level (integer) and text (inlines) + | Header Int Attr [Inline] + -- | Horizontal rule + | HorizontalRule + -- | Table, with attributes, caption, optional short caption, + -- column alignments and widths (required), table head, table + -- bodies, and table foot + | Table Attr Caption [ColSpec] TableHead [TableBody] TableFoot + -- | Figure, with attributes, caption, and content (list of blocks) + | Figure Attr Caption [Block] + -- | Generic block container with attributes + | Div Attr [Block] + deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) + +-- | Type of quotation marks to use in Quoted inline. +data QuoteType = SingleQuote | DoubleQuote deriving (Show, Eq, Ord, Read, Typeable, Data, Generic) + +-- | Link target (URL, title). +type Target = (Text, Text) + +isFigureTarget :: Target -> Maybe Target +isFigureTarget tgt + | (src, Just tit) <- second (T.stripPrefix "fig:") tgt = Just (src, tit) + | otherwise = Nothing + +-- | Bidirectional pattern synonym +-- +-- It can pass as a Block constructor +-- +-- >>> SimpleFigure nullAttr [] (T.pack "", T.pack "title") +-- Para [Image ("",[],[]) [] ("","fig:title")] +-- +-- +-- It can be used to pattern match +-- >>> let img = Para [Image undefined undefined (undefined, T.pack "title")] +-- >>> case img of { SimpleFigure _ _ _ -> True; _ -> False } +-- False +-- >>> let fig = Para [Image undefined undefined (undefined, T.pack "fig:title")] +-- >>> case fig of { SimpleFigure _ _ tit -> snd tit; _ -> T.pack "" } +-- "title" +pattern SimpleFigure :: Attr -> [Inline] -> Target -> Block +pattern SimpleFigure attr figureCaption tgt <- + Para [Image attr figureCaption + (isFigureTarget -> Just tgt)] where + SimpleFigure attr figureCaption tgt = + Para [Image attr figureCaption (second ("fig:" <>) tgt)] + + +-- | Type of math element (display or inline). +data MathType = DisplayMath | InlineMath deriving (Show, Eq, Ord, Read, Typeable, Data, Generic) + +-- | Inline elements. +data Inline + = Str Text -- ^ Text (string) + | Emph [Inline] -- ^ Emphasized text (list of inlines) + | Underline [Inline] -- ^ Underlined text (list of inlines) + | Strong [Inline] -- ^ Strongly emphasized text (list of inlines) + | Strikeout [Inline] -- ^ Strikeout text (list of inlines) + | Superscript [Inline] -- ^ Superscripted text (list of inlines) + | Subscript [Inline] -- ^ Subscripted text (list of inlines) + | SmallCaps [Inline] -- ^ Small caps text (list of inlines) + | Quoted QuoteType [Inline] -- ^ Quoted text (list of inlines) + | Cite [Citation] [Inline] -- ^ Citation (list of inlines) + | Code Attr Text -- ^ Inline code (literal) + | Space -- ^ Inter-word space + | SoftBreak -- ^ Soft line break + | LineBreak -- ^ Hard line break + | Math MathType Text -- ^ TeX math (literal) + | RawInline Format Text -- ^ Raw inline + | Link Attr [Inline] Target -- ^ Hyperlink: alt text (list of inlines), target + | Image Attr [Inline] Target -- ^ Image: alt text (list of inlines), target + | Note [Block] -- ^ Footnote or endnote + | Span Attr [Inline] -- ^ Generic inline container with attributes + deriving (Show, Eq, Ord, Read, Typeable, Data, Generic) + +data Citation = Citation { citationId :: Text + , citationPrefix :: [Inline] + , citationSuffix :: [Inline] + , citationMode :: CitationMode + , citationNoteNum :: Int + , citationHash :: Int + } + deriving (Show, Eq, Read, Typeable, Data, Generic) + +instance Ord Citation where + compare = comparing citationHash + +data CitationMode = AuthorInText | SuppressAuthor | NormalCitation + deriving (Show, Eq, Ord, Read, Typeable, Data, Generic) + + +-- ToJSON/FromJSON instances. Some are defined by hand so that we have +-- more control over the format. + +$(let jsonOpts = defaultOptions + { allNullaryToStringTag = False + , sumEncoding = TaggedObject { tagFieldName = "t", contentsFieldName = "c" } + } + in concat <$> traverse (deriveJSON jsonOpts) + [ ''MetaValue + , ''CitationMode + , ''Citation + , ''QuoteType + , ''MathType + , ''ListNumberStyle + , ''ListNumberDelim + , ''Alignment + , ''ColWidth + , ''Row + , ''Caption + , ''TableHead + , ''TableBody + , ''TableFoot + , ''Cell + , ''Inline + , ''Block + ]) + +instance FromJSON Meta where + parseJSON = fmap Meta . parseJSON +instance ToJSON Meta where + toJSON (Meta m) = toJSON m + toEncoding (Meta m) = toEncoding m + +instance FromJSON Pandoc where + parseJSON (Object v) = do + mbJVersion <- v .:? "pandoc-api-version" :: Aeson.Parser (Maybe [Int]) + case mbJVersion of + Just jVersion | x : y : _ <- jVersion + , x' : y' : _ <- versionBranch pandocTypesVersion + , x == x' + , y == y' -> Pandoc <$> v .: "meta" <*> v .: "blocks" + | otherwise -> + fail $ mconcat [ "Incompatible API versions: " + , "encoded with " + , show jVersion + , " but attempted to decode with " + , show $ versionBranch pandocTypesVersion + , "." + ] + _ -> fail "JSON missing pandoc-api-version." + parseJSON _ = mempty +instance ToJSON Pandoc where + toJSON (Pandoc meta blks) = + object [ "pandoc-api-version" .= versionBranch pandocTypesVersion + , "meta" .= meta + , "blocks" .= blks + ] + toEncoding (Pandoc meta blks) = + pairs $ mconcat [ "pandoc-api-version" .= versionBranch pandocTypesVersion + , "meta" .= meta + , "blocks" .= blks + ] + +-- Instances for deepseq +instance NFData MetaValue +instance NFData Meta +instance NFData Citation +instance NFData Alignment +instance NFData RowSpan +instance NFData ColSpan +instance NFData Cell +instance NFData Row +instance NFData TableHead +instance NFData TableBody +instance NFData TableFoot +instance NFData Caption +instance NFData Inline +instance NFData MathType +instance NFData Format +instance NFData CitationMode +instance NFData QuoteType +instance NFData ListNumberDelim +instance NFData ListNumberStyle +instance NFData ColWidth +instance NFData RowHeadColumns +instance NFData Block +instance NFData Pandoc + +pandocTypesVersion :: Version +pandocTypesVersion = version diff --git a/src/Text/Pandoc/Generic.hs b/src/Text/Pandoc/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Generic.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE CPP #-} +{- +Copyright (c) 2006-2023, John MacFarlane + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of John MacFarlane nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-} + +{- | + Module : Text.Pandoc.Generic + Copyright : Copyright (C) 2006-2023 John MacFarlane + License : BSD3 + + Maintainer : John MacFarlane + Stability : alpha + Portability : portable + +Generic functions for manipulating 'Pandoc' documents. +(Note: the functions defined in @Text.Pandoc.Walk@ should be used instead, +when possible, as they are much faster.) + +Here's a simple example, defining a function that replaces all the level 3+ +headers in a document with regular paragraphs in ALL CAPS: + +> import Text.Pandoc.Definition +> import Text.Pandoc.Generic +> import Data.Char (toUpper) +> +> modHeader :: Block -> Block +> modHeader (Header n _ xs) | n >= 3 = Para $ bottomUp allCaps xs +> modHeader x = x +> +> allCaps :: Inline -> Inline +> allCaps (Str xs) = Str $ map toUpper xs +> allCaps x = x +> +> changeHeaders :: Pandoc -> Pandoc +> changeHeaders = bottomUp modHeader + +'bottomUp' is so called because it traverses the @Pandoc@ structure from +bottom up. 'topDown' goes the other way. The difference between them can be +seen from this example: + +> normal :: [Inline] -> [Inline] +> normal (Space : Space : xs) = Space : xs +> normal (Emph xs : Emph ys : zs) = Emph (xs ++ ys) : zs +> normal xs = xs +> +> myDoc :: Pandoc +> myDoc = Pandoc nullMeta +> [ Para [Str "Hi",Space,Emph [Str "world",Space],Emph [Space,Str "emphasized"]]] + +Here we want to use 'topDown' to lift @normal@ to @Pandoc -> Pandoc@. +The top down strategy will collapse the two adjacent @Emph@s first, then +collapse the resulting adjacent @Space@s, as desired. If we used 'bottomUp', +we would end up with two adjacent @Space@s, since the contents of the +two @Emph@ inlines would be processed before the @Emph@s were collapsed +into one. + +> topDown normal myDoc == +> Pandoc nullMeta +> [Para [Str "Hi",Space,Emph [Str "world",Space,Str "emphasized"]]] +> +> bottomUp normal myDoc == +> Pandoc nullMeta +> [Para [Str "Hi",Space,Emph [Str "world",Space,Space,Str "emphasized"]]] + +'bottomUpM' is a monadic version of 'bottomUp'. It could be used, +for example, to replace the contents of delimited code blocks with +attribute @include=FILENAME@ with the contents of @FILENAME@: + +> doInclude :: Block -> IO Block +> doInclude cb@(CodeBlock (id, classes, namevals) contents) = +> case lookup "include" namevals of +> Just f -> return . (CodeBlock (id, classes, namevals)) =<< readFile f +> Nothing -> return cb +> doInclude x = return x +> +> processIncludes :: Pandoc -> IO Pandoc +> processIncludes = bottomUpM doInclude + +'queryWith' can be used, for example, to compile a list of URLs +linked to in a document: + +> extractURL :: Inline -> [String] +> extractURL (Link _ (u,_)) = [u] +> extractURL (Image _ _ (u,_)) = [u] +> extractURL _ = [] +> +> extractURLs :: Pandoc -> [String] +> extractURLs = queryWith extractURL + +-} +module Text.Pandoc.Generic where + +import Data.Generics + +-- | Applies a transformation on @a@s to matching elements in a @b@, +-- moving from the bottom of the structure up. +bottomUp :: (Data a, Data b) => (a -> a) -> b -> b +bottomUp f = everywhere (mkT f) + +-- | Applies a transformation on @a@s to matching elements in a @b@, +-- moving from the top of the structure down. +topDown :: (Data a, Data b) => (a -> a) -> b -> b +topDown f = everywhere' (mkT f) + +-- | Like 'bottomUp', but with monadic transformations. +bottomUpM :: (Monad m, Data a, Data b) => (a -> m a) -> b -> m b +bottomUpM f = everywhereM (mkM f) + +-- | Runs a query on matching @a@ elements in a @c@. The results +-- of the queries are combined using 'mappend'. +queryWith :: (Data a, Monoid b, Data c) => (a -> b) -> c -> b +queryWith f = everything mappend (mempty `mkQ` f) diff --git a/src/Text/Pandoc/JSON.hs b/src/Text/Pandoc/JSON.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/JSON.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses #-} +{- +Copyright (c) 2013-2023, John MacFarlane + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of John MacFarlane nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-} + +{- | + Module : Text.Pandoc.JSON + Copyright : Copyright (C) 2013-2023 John MacFarlane + License : BSD3 + + Maintainer : John MacFarlane + Stability : alpha + Portability : portable + +Functions for serializing the Pandoc AST to JSON and deserializing from JSON. + +Example of use: The following script (@capitalize.hs@) reads +reads a JSON representation of a Pandoc document from stdin, +and writes a JSON representation of a Pandoc document to stdout. +It changes all regular text in the document to uppercase, without +affecting URLs, code, tags, etc. Run the script with + +> pandoc -t json | runghc capitalize.hs | pandoc -f json + +or (making capitalize.hs executable) + +> pandoc --filter ./capitalize.hs + +> #!/usr/bin/env runghc +> import Text.Pandoc.JSON +> import Data.Char (toUpper) +> +> main :: IO () +> main = toJSONFilter capitalizeStrings +> +> capitalizeStrings :: Inline -> Inline +> capitalizeStrings (Str s) = Str $ map toUpper s +> capitalizeStrings x = x + +-} + +module Text.Pandoc.JSON ( module Text.Pandoc.Definition + , ToJSONFilter(..) + ) +where +import Text.Pandoc.Definition +import Text.Pandoc.Walk +import Control.Monad.IO.Class(MonadIO(liftIO)) +import Data.Maybe (listToMaybe) +import qualified Data.ByteString.Lazy as BL +import qualified Data.Text as T +import Data.Aeson +import System.Environment (getArgs) + +-- | 'toJSONFilter' convert a function into a filter that reads pandoc's +-- JSON serialized output from stdin, transforms it by walking the AST +-- and applying the specified function, and serializes the result as JSON +-- to stdout. +-- +-- For a straight transformation, use a function of type @a -> a@ or +-- @a -> IO a@ where @a@ = 'Block', 'Inline', 'Pandoc', 'Meta', or 'MetaValue'. +-- +-- If your transformation needs to be sensitive to the script's arguments, +-- use a function of type @[String] -> a -> a@ (with @a@ constrained as above). +-- The @[String]@ will be populated with the script's arguments. +-- +-- An alternative is to use the type @Maybe Format -> a -> a@. +-- This is appropriate when the first argument of the script (if present) +-- will be the target format, and allows scripts to behave differently +-- depending on the target format. The pandoc executable automatically +-- provides the target format as argument when scripts are called using +-- the `--filter` option. + +class ToJSONFilter m a where + toJSONFilter :: a -> m () + +instance (Walkable a Pandoc, MonadIO m) => ToJSONFilter m (a -> a) where + toJSONFilter f = liftIO $ BL.getContents >>= + BL.putStr . encode . (walk f :: Pandoc -> Pandoc) . either error id . + eitherDecode' + +instance (Walkable [a] Pandoc, MonadIO m) => ToJSONFilter m (a -> [a]) where + toJSONFilter f = liftIO $ BL.getContents >>= + BL.putStr . encode . (walk (concatMap f) :: Pandoc -> Pandoc) . + either error id . + eitherDecode' + +instance (Walkable a Pandoc, MonadIO m) => ToJSONFilter m (a -> m a) where + toJSONFilter f = do + c <- liftIO BL.getContents + r <- walkM f (either error id (eitherDecode' c) :: Pandoc) + liftIO (BL.putStr (encode (r :: Pandoc))) + +instance (Walkable [a] Pandoc, MonadIO m) => ToJSONFilter m (a -> m [a]) where + toJSONFilter f = do + c <- liftIO BL.getContents + r <- (walkM (fmap concat . mapM f)) (either error id (eitherDecode' c) :: Pandoc) + liftIO (BL.putStr (encode (r :: Pandoc))) + +instance (ToJSONFilter m a, MonadIO m) => ToJSONFilter m ([String] -> a) where + toJSONFilter f = liftIO getArgs >>= toJSONFilter . f + +instance (ToJSONFilter m a, MonadIO m) => ToJSONFilter m (Maybe Format -> a) where + toJSONFilter f = liftIO getArgs >>= toJSONFilter . f . fmap (Format . T.pack) . listToMaybe diff --git a/src/Text/Pandoc/Walk.hs b/src/Text/Pandoc/Walk.hs new file mode 100644 --- /dev/null +++ b/src/Text/Pandoc/Walk.hs @@ -0,0 +1,664 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +#if MIN_VERSION_base(4,9,0) +{-# OPTIONS_GHC -fno-warn-redundant-constraints -O2 #-} +#endif +#define OVERLAPS {-# OVERLAPPING #-} +{- +Copyright (c) 2013-2023, John MacFarlane + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of John MacFarlane nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-} + +{- | + Module : Text.Pandoc.Walk + Copyright : Copyright (C) 2013-2023 John MacFarlane + License : BSD3 + + Maintainer : John MacFarlane + Stability : alpha + Portability : portable + +Functions for manipulating 'Pandoc' documents or extracting +information from them by walking the 'Pandoc' structure (or +intermediate structures like '[Block]' or '[Inline]'. +These are faster (by a factor of four or five) than the generic +functions defined in @Text.Pandoc.Generic@. + +Here's a simple example, defining a function that replaces all the level 3+ +headers in a document with regular paragraphs in ALL CAPS: + +> import Text.Pandoc.Definition +> import Text.Pandoc.Walk +> import Data.Char (toUpper) +> +> modHeader :: Block -> Block +> modHeader (Header n _ xs) | n >= 3 = Para $ walk allCaps xs +> modHeader x = x +> +> allCaps :: Inline -> Inline +> allCaps (Str xs) = Str $ map toUpper xs +> allCaps x = x +> +> changeHeaders :: Pandoc -> Pandoc +> changeHeaders = walk modHeader + +'query' can be used, for example, to compile a list of URLs +linked to in a document: + +> extractURL :: Inline -> [Text] +> extractURL (Link _ _ (u,_)) = [u] +> extractURL (Image _ _ (u,_)) = [u] +> extractURL _ = [] +> +> extractURLs :: Pandoc -> [Text] +> extractURLs = query extractURL +-} + + +module Text.Pandoc.Walk + ( Walkable(..) + , queryBlock + , queryCaption + , queryRow + , queryTableHead + , queryTableBody + , queryTableFoot + , queryCell + , queryCitation + , queryInline + , queryMetaValue + , queryMetaValue' + , queryPandoc + , walkBlockM + , walkCaptionM + , walkRowM + , walkTableHeadM + , walkTableBodyM + , walkTableFootM + , walkCellM + , walkCitationM + , walkInlineM + , walkMetaValueM + , walkMetaValueM' + , walkPandocM + ) +where +import Control.Monad ((>=>)) +import Data.Functor.Identity (Identity (runIdentity)) +import qualified Data.Map as M +import Text.Pandoc.Definition +import qualified Data.Traversable as T +import qualified Data.Foldable as F + +class Walkable a b where + -- | @walk f x@ walks the structure @x@ (bottom up) and replaces every + -- occurrence of an @a@ with the result of applying @f@ to it. + walk :: (a -> a) -> b -> b + walk f = runIdentity . walkM (return . f) + -- | A monadic version of 'walk'. + walkM :: (Monad m, Applicative m, Functor m) => (a -> m a) -> b -> m b + -- | @query f x@ walks the structure @x@ (bottom up) and applies @f@ + -- to every @a@, appending the results. + query :: Monoid c => (a -> c) -> b -> c + {-# MINIMAL walkM, query #-} + +instance (Foldable t, Traversable t, Walkable a b) => Walkable a (t b) where + walk f = T.fmapDefault (walk f) + walkM f = T.mapM (walkM f) + query f = F.foldMap (query f) + +-- Walk pairs by handling both elements, then combine the results. +instance OVERLAPS + (Walkable a b, Walkable a c) => Walkable a (b,c) where + walk f (x,y) = (walk f x, walk f y) + walkM f (x,y) = do x' <- walkM f x + y' <- walkM f y + return (x',y') + query f (x,y) = mappend (query f x) (query f y) + +instance Walkable Inline Inline where + walkM f x = walkInlineM f x >>= f + query f x = f x <> queryInline f x + +instance OVERLAPS + Walkable [Inline] [Inline] where + walkM f = T.traverse (walkInlineM f) >=> f + query f inlns = f inlns <> mconcat (map (queryInline f) inlns) + +instance Walkable [Inline] Inline where + walkM = walkInlineM + query = queryInline + +instance Walkable Inline Block where + walkM = walkBlockM + query = queryBlock + +instance Walkable [Inline] Block where + walkM = walkBlockM + query = queryBlock + +instance Walkable Block Block where + walkM f x = walkBlockM f x >>= f + query f x = f x <> queryBlock f x + +instance Walkable [Block] Block where + walkM = walkBlockM + query = queryBlock + +instance OVERLAPS + Walkable [Block] [Block] where + walkM f = T.traverse (walkBlockM f) >=> f + query f blks = f blks <> mconcat (map (queryBlock f) blks) + +instance Walkable Block Inline where + walkM = walkInlineM + query = queryInline + +instance Walkable [Block] Inline where + walkM = walkInlineM + query = queryInline + +-- +-- Walk Pandoc +-- +instance Walkable Block Pandoc where + walkM = walkPandocM + query = queryPandoc + +instance Walkable [Block] Pandoc where + walkM = walkPandocM + query = queryPandoc + +instance Walkable Inline Pandoc where + walkM = walkPandocM + query = queryPandoc + +instance Walkable [Inline] Pandoc where + walkM = walkPandocM + query = queryPandoc + +instance Walkable Meta Pandoc where + walkM f (Pandoc m bs) = Pandoc <$> f m <*> pure bs + query f (Pandoc m _) = f m + +instance Walkable MetaValue Pandoc where + walkM f (Pandoc m bs) = Pandoc <$> walkM f m <*> pure bs + query f (Pandoc m _) = query f m + +instance Walkable Pandoc Pandoc where + walkM f = f + query f = f + +-- +-- Walk Meta +-- +instance Walkable Meta Meta where + walkM f = f + query f = f + +instance Walkable Inline Meta where + walkM f (Meta metamap) = Meta <$> walkM f metamap + query f (Meta metamap) = query f metamap + +instance Walkable [Inline] Meta where + walkM f (Meta metamap) = Meta <$> walkM f metamap + query f (Meta metamap) = query f metamap + +instance Walkable Block Meta where + walkM f (Meta metamap) = Meta <$> walkM f metamap + query f (Meta metamap) = query f metamap + +instance Walkable [Block] Meta where + walkM f (Meta metamap) = Meta <$> walkM f metamap + query f (Meta metamap) = query f metamap + +instance Walkable MetaValue Meta where + walkM f (Meta metamap) = + Meta . M.fromAscList <$> mapM (\(k, v) -> (,) k <$> walkM f v) (M.toAscList metamap) + query f (Meta metamap) = M.foldMapWithKey (const $ query f) metamap + +-- +-- Walk MetaValue +-- +instance Walkable MetaValue MetaValue where + walkM f x = walkMetaValueM' f x >>= f + query f x = f x <> queryMetaValue' f x + +instance Walkable Inline MetaValue where + walkM = walkMetaValueM + query = queryMetaValue + +instance Walkable [Inline] MetaValue where + walkM = walkMetaValueM + query = queryMetaValue + +instance Walkable Block MetaValue where + walkM = walkMetaValueM + query = queryMetaValue + +instance Walkable [Block] MetaValue where + walkM = walkMetaValueM + query = queryMetaValue + +-- +-- Walk Row +-- +instance Walkable Inline Row where + walkM = walkRowM + query = queryRow + +instance Walkable [Inline] Row where + walkM = walkRowM + query = queryRow + +instance Walkable Block Row where + walkM = walkRowM + query = queryRow + +instance Walkable [Block] Row where + walkM = walkRowM + query = queryRow + +-- +-- Walk TableHead +-- +instance Walkable Inline TableHead where + walkM = walkTableHeadM + query = queryTableHead + +instance Walkable [Inline] TableHead where + walkM = walkTableHeadM + query = queryTableHead + +instance Walkable Block TableHead where + walkM = walkTableHeadM + query = queryTableHead + +instance Walkable [Block] TableHead where + walkM = walkTableHeadM + query = queryTableHead + +-- +-- Walk TableBody +-- +instance Walkable Inline TableBody where + walkM = walkTableBodyM + query = queryTableBody + +instance Walkable [Inline] TableBody where + walkM = walkTableBodyM + query = queryTableBody + +instance Walkable Block TableBody where + walkM = walkTableBodyM + query = queryTableBody + +instance Walkable [Block] TableBody where + walkM = walkTableBodyM + query = queryTableBody + +-- +-- Walk TableFoot +-- +instance Walkable Inline TableFoot where + walkM = walkTableFootM + query = queryTableFoot + +instance Walkable [Inline] TableFoot where + walkM = walkTableFootM + query = queryTableFoot + +instance Walkable Block TableFoot where + walkM = walkTableFootM + query = queryTableFoot + +instance Walkable [Block] TableFoot where + walkM = walkTableFootM + query = queryTableFoot + +-- +-- Walk Caption +-- +instance Walkable Inline Caption where + walkM = walkCaptionM + query = queryCaption + +instance Walkable [Inline] Caption where + walkM = walkCaptionM + query = queryCaption + +instance Walkable Block Caption where + walkM = walkCaptionM + query = queryCaption + +instance Walkable [Block] Caption where + walkM = walkCaptionM + query = queryCaption + +-- +-- Walk Cell +-- +instance Walkable Inline Cell where + walkM = walkCellM + query = queryCell + +instance Walkable [Inline] Cell where + walkM = walkCellM + query = queryCell + +instance Walkable Block Cell where + walkM = walkCellM + query = queryCell + +instance Walkable [Block] Cell where + walkM = walkCellM + query = queryCell + +-- +-- Walk Citation +-- +instance Walkable Inline Citation where + walkM = walkCitationM + query = queryCitation + +instance Walkable [Inline] Citation where + walkM = walkCitationM + query = queryCitation + +instance Walkable Block Citation where + walkM = walkCitationM + query = queryCitation + +instance Walkable [Block] Citation where + walkM = walkCitationM + query = queryCitation + +-- | Helper method to walk to elements nested below @'Inline'@ nodes. +-- +-- When walking an inline with this function, only the contents of the traversed +-- inline element may change. The element itself, i.e. its constructor, cannot +-- be changed. +walkInlineM :: (Walkable a Citation, Walkable a [Block], + Walkable a [Inline], Monad m, Applicative m, Functor m) + => (a -> m a) -> Inline -> m Inline +walkInlineM _ (Str xs) = return (Str xs) +walkInlineM f (Emph xs) = Emph <$> walkM f xs +walkInlineM f (Underline xs) = Underline <$> walkM f xs +walkInlineM f (Strong xs) = Strong <$> walkM f xs +walkInlineM f (Strikeout xs) = Strikeout <$> walkM f xs +walkInlineM f (Subscript xs) = Subscript <$> walkM f xs +walkInlineM f (Superscript xs) = Superscript <$> walkM f xs +walkInlineM f (SmallCaps xs) = SmallCaps <$> walkM f xs +walkInlineM f (Quoted qt xs) = Quoted qt <$> walkM f xs +walkInlineM f (Link atr xs t) = Link atr <$> walkM f xs <*> pure t +walkInlineM f (Image atr xs t) = Image atr <$> walkM f xs <*> pure t +walkInlineM f (Note bs) = Note <$> walkM f bs +walkInlineM f (Span attr xs) = Span attr <$> walkM f xs +walkInlineM f (Cite cs xs) = Cite <$> walkM f cs <*> walkM f xs +walkInlineM _ LineBreak = return LineBreak +walkInlineM _ SoftBreak = return SoftBreak +walkInlineM _ Space = return Space +walkInlineM _ x@Code {} = return x +walkInlineM _ x@Math {} = return x +walkInlineM _ x@RawInline {} = return x + +-- | Perform a query on elements nested below an @'Inline'@ element by +-- querying nested lists of @Inline@s, @Block@s, or @Citation@s. +queryInline :: (Walkable a Citation, Walkable a [Block], + Walkable a [Inline], Monoid c) + => (a -> c) -> Inline -> c +queryInline _ (Str _) = mempty +queryInline f (Emph xs) = query f xs +queryInline f (Underline xs) = query f xs +queryInline f (Strong xs) = query f xs +queryInline f (Strikeout xs) = query f xs +queryInline f (Subscript xs) = query f xs +queryInline f (Superscript xs)= query f xs +queryInline f (SmallCaps xs) = query f xs +queryInline f (Quoted _ xs) = query f xs +queryInline f (Cite cs xs) = query f cs <> query f xs +queryInline _ (Code _ _) = mempty +queryInline _ Space = mempty +queryInline _ SoftBreak = mempty +queryInline _ LineBreak = mempty +queryInline _ (Math _ _) = mempty +queryInline _ (RawInline _ _) = mempty +queryInline f (Link _ xs _) = query f xs +queryInline f (Image _ xs _) = query f xs +queryInline f (Note bs) = query f bs +queryInline f (Span _ xs) = query f xs + + +-- | Helper method to walk to elements nested below @'Block'@ nodes. +-- +-- When walking a block with this function, only the contents of the traversed +-- block element may change. The element itself, i.e. its constructor, its @'Attr'@, +-- and its raw text value, will remain unchanged. +walkBlockM :: (Walkable a [Block], Walkable a [Inline], Walkable a Row, + Walkable a Caption, Walkable a TableHead, Walkable a TableBody, + Walkable a TableFoot, Monad m, Applicative m, Functor m) + => (a -> m a) -> Block -> m Block +walkBlockM f (Para xs) = Para <$> walkM f xs +walkBlockM f (Plain xs) = Plain <$> walkM f xs +walkBlockM f (LineBlock xs) = LineBlock <$> walkM f xs +walkBlockM f (BlockQuote xs) = BlockQuote <$> walkM f xs +walkBlockM f (OrderedList a cs) = OrderedList a <$> walkM f cs +walkBlockM f (BulletList cs) = BulletList <$> walkM f cs +walkBlockM f (DefinitionList xs) = DefinitionList <$> walkM f xs +walkBlockM f (Header lev attr xs) = Header lev attr <$> walkM f xs +walkBlockM f (Div attr bs') = Div attr <$> walkM f bs' +walkBlockM _ x@CodeBlock {} = return x +walkBlockM _ x@RawBlock {} = return x +walkBlockM _ HorizontalRule = return HorizontalRule +walkBlockM f (Table attr capt as hs bs fs) + = do capt' <- walkM f capt + hs' <- walkM f hs + bs' <- walkM f bs + fs' <- walkM f fs + return $ Table attr capt' as hs' bs' fs' +walkBlockM f (Figure attr capt blks) + = do capt' <- walkM f capt + blks' <- walkM f blks + return $ Figure attr capt' blks' + +-- | Perform a query on elements nested below a @'Block'@ element by +-- querying all directly nested lists of @Inline@s or @Block@s. +queryBlock :: (Walkable a Citation, Walkable a [Block], Walkable a Row, + Walkable a Caption, Walkable a TableHead, Walkable a TableBody, + Walkable a TableFoot, Walkable a [Inline], Monoid c) + => (a -> c) -> Block -> c +queryBlock f (Para xs) = query f xs +queryBlock f (Plain xs) = query f xs +queryBlock f (LineBlock xs) = query f xs +queryBlock _ (CodeBlock _ _) = mempty +queryBlock _ (RawBlock _ _) = mempty +queryBlock f (BlockQuote bs) = query f bs +queryBlock f (OrderedList _ cs) = query f cs +queryBlock f (BulletList cs) = query f cs +queryBlock f (DefinitionList xs) = query f xs +queryBlock f (Header _ _ xs) = query f xs +queryBlock _ HorizontalRule = mempty +queryBlock f (Table _ capt _ hs bs fs) + = query f capt <> + query f hs <> + query f bs <> + query f fs +queryBlock f (Figure _ capt blks) + = query f capt <> + query f blks +queryBlock f (Div _ bs) = query f bs + +-- | Helper method to walk to elements nested below @'MetaValue'@ nodes. +-- +-- When walking a meta value with this function, only the contents of the +-- traversed meta value element may change. @MetaBool@ and @MetaString@ will +-- always remain unchanged. +walkMetaValueM :: (Walkable a MetaValue, Walkable a [Block], + Walkable a [Inline], Monad f, Applicative f, Functor f) + => (a -> f a) -> MetaValue -> f MetaValue +walkMetaValueM f (MetaList xs) = MetaList <$> walkM f xs +walkMetaValueM _ (MetaBool b) = return $ MetaBool b +walkMetaValueM _ (MetaString s) = return $ MetaString s +walkMetaValueM f (MetaInlines xs) = MetaInlines <$> walkM f xs +walkMetaValueM f (MetaBlocks bs) = MetaBlocks <$> walkM f bs +walkMetaValueM f (MetaMap m) = MetaMap <$> walkM f m + +-- | Helper method to walk @'MetaValue'@ nodes nested below @'MetaValue'@ nodes. +walkMetaValueM' :: (Monad f, Applicative f, Functor f) + => (MetaValue -> f MetaValue) -> MetaValue -> f MetaValue +walkMetaValueM' f (MetaMap m) = + MetaMap . M.fromAscList <$> mapM (\(k, v) -> (,) k <$> walkM f v) (M.toAscList m) +walkMetaValueM' f (MetaList xs) = MetaList <$> mapM (walkM f) xs +walkMetaValueM' _ x = return x + +-- | Perform a query on elements nested below a @'MetaValue'@ element by +-- querying all directly nested lists of @Inline@s, list of @Block@s, or +-- lists or maps of @MetaValue@s. +queryMetaValue :: (Walkable a MetaValue, Walkable a [Block], + Walkable a [Inline], Monoid c) + => (a -> c) -> MetaValue -> c +queryMetaValue f (MetaList xs) = query f xs +queryMetaValue _ (MetaBool _) = mempty +queryMetaValue _ (MetaString _) = mempty +queryMetaValue f (MetaInlines xs) = query f xs +queryMetaValue f (MetaBlocks bs) = query f bs +queryMetaValue f (MetaMap m) = query f m + +-- | Perform a query on @'MetaValue'@ elements nested below a @'MetaValue'@ +-- element +queryMetaValue' :: Monoid c + => (MetaValue -> c) -> MetaValue -> c +queryMetaValue' f (MetaMap m) = M.foldMapWithKey (const $ query f) m +queryMetaValue' f (MetaList xs) = mconcat $ map (query f) xs +queryMetaValue' _ _ = mempty + +-- | Helper method to walk to elements nested below @'Citation'@ nodes. +-- +-- The non-inline contents of a citation will remain unchanged during traversal. +-- Only the inline contents, viz. the citation's prefix and postfix, will be +-- traversed further and can thus be changed during this operation. +walkCitationM :: (Walkable a [Inline], Monad m, Applicative m, Functor m) + => (a -> m a) -> Citation -> m Citation +walkCitationM f (Citation id' pref suff mode notenum hash) = + do pref' <- walkM f pref + suff' <- walkM f suff + return $ Citation id' pref' suff' mode notenum hash + +-- | Perform a query on elements nested below a @'Citation'@ element by +-- querying the prefix and postfix @Inline@ lists. +queryCitation :: (Walkable a [Inline], Monoid c) + => (a -> c) -> Citation -> c +queryCitation f (Citation _ pref suff _ _ _) = query f pref <> query f suff + +-- | Helper method to walk the elements nested below @'Row'@ nodes. The +-- @'Attr'@ component is not changed by this operation. +walkRowM :: (Walkable a Cell, Monad m) + => (a -> m a) -> Row -> m Row +walkRowM f (Row attr bd) = Row attr <$> walkM f bd + +-- | Query the elements below a 'Row' element. +queryRow :: (Walkable a Cell, Monoid c) + => (a -> c) -> Row -> c +queryRow f (Row _ bd) = query f bd + +-- | Helper method to walk the elements nested below @'TableHead'@ nodes. The +-- @'Attr'@ component is not changed by this operation. +walkTableHeadM :: (Walkable a Row, Monad m) + => (a -> m a) -> TableHead -> m TableHead +walkTableHeadM f (TableHead attr body) = TableHead attr <$> walkM f body + +-- | Query the elements below a 'TableHead' element. +queryTableHead :: (Walkable a Row, Monoid c) + => (a -> c) -> TableHead -> c +queryTableHead f (TableHead _ body) = query f body + +-- | Helper method to walk the elements nested below @'TableBody'@ +-- nodes. The @'Attr'@ and @'RowHeadColumns'@ components are not +-- changed by this operation. +walkTableBodyM :: (Walkable a Row, Monad m) + => (a -> m a) -> TableBody -> m TableBody +walkTableBodyM f (TableBody attr rhc hd bd) = TableBody attr rhc <$> walkM f hd <*> walkM f bd + +-- | Query the elements below a 'TableBody' element. +queryTableBody :: (Walkable a Row, Monoid c) + => (a -> c) -> TableBody -> c +queryTableBody f (TableBody _ _ hd bd) = query f hd <> query f bd + +-- | Helper method to walk the elements nested below @'TableFoot'@ nodes. The +-- @'Attr'@ component is not changed by this operation. +walkTableFootM :: (Walkable a Row, Monad m) + => (a -> m a) -> TableFoot -> m TableFoot +walkTableFootM f (TableFoot attr body) = TableFoot attr <$> walkM f body + +-- | Query the elements below a 'TableFoot' element. +queryTableFoot :: (Walkable a Row, Monoid c) + => (a -> c) -> TableFoot -> c +queryTableFoot f (TableFoot _ body) = query f body + +-- | Helper method to walk the elements nested below 'Cell' +-- nodes. Only the @['Block']@ cell content is changed by this +-- operation. +walkCellM :: (Walkable a [Block], Monad m) + => (a -> m a) -> Cell -> m Cell +walkCellM f (Cell attr ma rs cs content) = Cell attr ma rs cs <$> walkM f content + +-- | Query the elements below a 'Cell' element. +queryCell :: (Walkable a [Block], Monoid c) + => (a -> c) -> Cell -> c +queryCell f (Cell _ _ _ _ content) = query f content + +-- | Helper method to walk the elements nested below 'Caption' +-- nodes. +walkCaptionM :: (Walkable a [Block], Walkable a [Inline], Monad m, Walkable a ShortCaption) + => (a -> m a) -> Caption -> m Caption +walkCaptionM f (Caption mshort body) = Caption <$> walkM f mshort <*> walkM f body + +-- | Query the elements below a 'Cell' element. +queryCaption :: (Walkable a [Block], Walkable a [Inline], Walkable a ShortCaption, Monoid c) + => (a -> c) -> Caption -> c +queryCaption f (Caption mshort body) = query f mshort <> query f body + +-- | Helper method to walk the components of a Pandoc element. +walkPandocM :: (Walkable a Meta, Walkable a [Block], Monad m, + Applicative m, Functor m) + => (a -> m a) -> Pandoc -> m Pandoc +walkPandocM f (Pandoc m bs) = do m' <- walkM f m + bs' <- walkM f bs + return $ Pandoc m' bs' + +-- | Query a pandoc element by recursing first into its @'Meta'@ data +-- and then append the result of recursing into the list of @'Block'@s. +queryPandoc :: (Walkable a Meta, Walkable a [Block], Monoid c) + => (a -> c) -> Pandoc -> c +queryPandoc f (Pandoc m bs) = query f m <> query f bs diff --git a/test/Data/String/QQ.hs b/test/Data/String/QQ.hs new file mode 100644 --- /dev/null +++ b/test/Data/String/QQ.hs @@ -0,0 +1,19 @@ +-- | This module is based off the QQ implementation from string-qq +-- (https://github.com/audreyt/string-qq). +{-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE RankNTypes #-} +module Data.String.QQ (s) where +import Data.String (IsString(..)) +import Language.Haskell.TH.Quote (QuasiQuoter(..)) + +s :: QuasiQuoter +s = QuasiQuoter expr pat typ dec + where + expr = (\a -> [|fromString a|]) . clean + pat = error "Cannot use s as a pattern" + typ = error "Cannot use s as a type" + dec = error "Cannot use s as a dec" + clean = removeCarriageReturns . trimLeadingNewline + removeCarriageReturns = filter (/= '\r') + trimLeadingNewline ('\n':xs) = xs + trimLeadingNewline xs = xs diff --git a/test/test-pandoc-types.hs b/test/test-pandoc-types.hs new file mode 100644 --- /dev/null +++ b/test/test-pandoc-types.hs @@ -0,0 +1,791 @@ +{-# LANGUAGE OverloadedStrings, QuasiQuotes, FlexibleContexts, CPP #-} + +import Text.Pandoc.Arbitrary () +import Text.Pandoc.Definition +import Text.Pandoc.Walk +import Text.Pandoc.Builder (singleton, plain, text, simpleTable, table, emptyCell, + normalizeTableHead, normalizeTableBody, normalizeTableFoot, + emptyCaption, simpleFigureWith) +import qualified Text.Pandoc.Builder as Builder +import Data.Generics +import Data.List (tails) +import Test.HUnit (Assertion, assertEqual, assertFailure) +import Data.Aeson (FromJSON, ToJSON, encode, decode) +import Test.Framework +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.Framework.Providers.HUnit (testCase) +import Test.QuickCheck (forAll, choose, Property, Arbitrary, Testable, arbitrary, Gen) +import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Text as T +import Data.String.QQ +import Data.ByteString.Lazy (ByteString) +import qualified Data.Monoid as Monoid + + +p_walk :: (Typeable a, Walkable a Pandoc) + => (a -> a) -> Pandoc -> Bool +p_walk f d = everywhere (mkT f) d == walk f d + +p_walkList :: (Typeable a, Walkable [a] Pandoc) + => ([a] -> [a]) -> Pandoc -> Bool +p_walkList f d = everywhere (mkT f) d == walk (foldr g []) d + where g x ys = f (x:ys) + +p_query :: (Eq a, Typeable a1, Monoid a, Walkable a1 Pandoc) + => (a1 -> a) -> Pandoc -> Bool +p_query f d = everything mappend (mempty `mkQ` f) d == query f d + +p_queryList :: (Eq a, Typeable a1, Monoid a, Walkable [a1] Pandoc) + => ([a1] -> a) -> Pandoc -> Bool +p_queryList f d = everything mappend (mempty `mkQ` f) d == + query (mconcat . map f . tails) d + +inlineTrans :: Inline -> Inline +inlineTrans (Str xs) = Str $ T.toUpper xs +inlineTrans (Emph xs) = Strong xs +inlineTrans x = x + +inlinesTrans :: [Inline] -> [Inline] +inlinesTrans ys | all whitespaceInline ys = [] + where + whitespaceInline Space = True + whitespaceInline LineBreak = True + whitespaceInline SoftBreak = True + whitespaceInline (Str "") = True + whitespaceInline _ = False +inlinesTrans ys = ys + +blockTrans :: Block -> Block +blockTrans (Plain xs) = Para xs +blockTrans (BlockQuote xs) = Div ("",["special"],[]) xs +blockTrans x = x + +blocksTrans :: [Block] -> [Block] +blocksTrans [CodeBlock {}] = [] +blocksTrans [BlockQuote xs] = xs +blocksTrans [Div _ xs] = xs +blocksTrans xs = xs + +metaValueTrans :: MetaValue -> MetaValue +metaValueTrans (MetaBool x) = MetaBool $ not x +metaValueTrans (MetaString xs) = MetaString $ T.toUpper xs +metaValueTrans x = x + +metaTrans :: Meta -> Meta +metaTrans (Meta metamap) = Meta $ M.mapKeys T.toUpper metamap + +inlineQuery :: Inline -> Text +inlineQuery (Str xs) = xs +inlineQuery _ = "" + +inlinesQuery :: [Inline] -> Monoid.Sum Int +inlinesQuery = Monoid.Sum . length + +blockQuery :: Block -> [Int] +blockQuery (Header lev _ _) = [lev] +blockQuery _ = [] + +blocksQuery :: [Block] -> Monoid.Sum Int +blocksQuery = Monoid.Sum . length + +metaValueQuery :: MetaValue -> Text +metaValueQuery (MetaString xs) = xs +metaValueQuery _ = "" + +metaQuery :: Meta -> Monoid.Sum Int +metaQuery (Meta metamap) = Monoid.Sum $ M.size metamap + +prop_roundtrip :: Pandoc -> Bool +prop_roundtrip doc = case decode $ encode doc :: (Maybe Pandoc) of + Just doc' -> doc == doc' + _ -> False + +testEncode :: ToJSON a => (a, ByteString) -> Assertion +testEncode (doc, j) = assertEqual "Encoding error" (encode doc) j + +testDecode' :: FromJSON a => (a, ByteString) -> Maybe a +testDecode' (_, j) = decode j + +testDecode :: (Show a, Eq a, FromJSON a) => (a, ByteString) -> Assertion +testDecode (doc, j) = + case testDecode' (doc, j) of + Just doc' -> assertEqual "Decoding error" doc' doc + Nothing -> assertFailure "Decoding error" + +testEncodeDecode :: (Show a, Eq a, ToJSON a, FromJSON a) + => String + -> (a, ByteString) + -> Test +testEncodeDecode msg pair = testGroup msg [ testCase "Encoding" $ testEncode pair + , testCase "Decoding" $ testDecode pair + ] + +t_meta :: (Meta, ByteString) +t_meta = ( Meta $ M.fromList [("foo", MetaBool True)] + , [s|{"foo":{"t":"MetaBool","c":true}}|] + ) + +t_metamap :: (MetaValue, ByteString) +t_metamap = ( MetaMap $ + M.fromList [("foo", MetaBool True)] + , [s|{"t":"MetaMap","c":{"foo":{"t":"MetaBool","c":true}}}|] + ) + +t_metalist :: (MetaValue, ByteString) +t_metalist = ( MetaList [MetaBool True, MetaString "baz"] + , [s|{"t":"MetaList","c":[{"t":"MetaBool","c":true},{"t":"MetaString","c":"baz"}]}|] + ) + +t_metabool :: (MetaValue, ByteString) +t_metabool = ( MetaBool False, [s|{"t":"MetaBool","c":false}|] ) + +t_metastring :: (MetaValue, ByteString) +t_metastring = ( MetaString "Hello", [s|{"t":"MetaString","c":"Hello"}|] ) + +t_metainlines :: (MetaValue, ByteString) +t_metainlines = ( MetaInlines [Space, SoftBreak] + , [s|{"t":"MetaInlines","c":[{"t":"Space"},{"t":"SoftBreak"}]}|] + ) + +t_metablocks :: (MetaValue, ByteString) +t_metablocks = ( MetaBlocks [HorizontalRule,HorizontalRule], [s|{"t":"MetaBlocks","c":[{"t":"HorizontalRule"},{"t":"HorizontalRule"}]}|]) + +t_singlequote :: (QuoteType, ByteString) +t_singlequote = (SingleQuote, [s|{"t":"SingleQuote"}|]) + +t_doublequote :: (QuoteType, ByteString) +t_doublequote = (DoubleQuote, [s|{"t":"DoubleQuote"}|]) + +t_authorintext :: (CitationMode, ByteString) +t_authorintext = (AuthorInText, [s|{"t":"AuthorInText"}|]) + +t_suppressauthor :: (CitationMode, ByteString) +t_suppressauthor = (SuppressAuthor, [s|{"t":"SuppressAuthor"}|]) + +t_normalcitation :: (CitationMode, ByteString) +t_normalcitation = (NormalCitation, [s|{"t":"NormalCitation"}|]) + +t_citation :: (Citation, ByteString) +t_citation = ( Citation { citationId = "jameson:unconscious", + citationPrefix = [Str "cf"], + citationSuffix = [Space,Str "123"], + citationMode = NormalCitation, + citationNoteNum = 0, + citationHash = 0} + , [s|{"citationId":"jameson:unconscious","citationPrefix":[{"t":"Str","c":"cf"}],"citationSuffix":[{"t":"Space"},{"t":"Str","c":"123"}],"citationMode":{"t":"NormalCitation"},"citationNoteNum":0,"citationHash":0}|] + ) + +t_displaymath :: (MathType, ByteString) +t_displaymath = ( DisplayMath, [s|{"t":"DisplayMath"}|]) + +t_inlinemath :: (MathType, ByteString) +t_inlinemath = ( InlineMath, [s|{"t":"InlineMath"}|]) + + +t_str :: (Inline, ByteString) +t_str = ( Str "Hello" + , [s|{"t":"Str","c":"Hello"}|] + ) + +t_emph :: (Inline, ByteString) +t_emph = ( Emph [Str "Hello"] + , [s|{"t":"Emph","c":[{"t":"Str","c":"Hello"}]}|] + ) + +t_underline :: (Inline, ByteString) +t_underline = ( Underline [Str "Hello"] + , [s|{"t":"Underline","c":[{"t":"Str","c":"Hello"}]}|] + ) + +t_strong :: (Inline, ByteString) +t_strong = ( Strong [Str "Hello"] + , [s|{"t":"Strong","c":[{"t":"Str","c":"Hello"}]}|] + ) + +t_strikeout :: (Inline, ByteString) +t_strikeout = ( Strikeout [Str "Hello"] + , [s|{"t":"Strikeout","c":[{"t":"Str","c":"Hello"}]}|] + ) + +t_superscript :: (Inline, ByteString) +t_superscript = ( Superscript [Str "Hello"] + , [s|{"t":"Superscript","c":[{"t":"Str","c":"Hello"}]}|] + ) + +t_subscript :: (Inline, ByteString) +t_subscript = ( Subscript [Str "Hello"] + , [s|{"t":"Subscript","c":[{"t":"Str","c":"Hello"}]}|] + ) + +t_smallcaps :: (Inline, ByteString) +t_smallcaps = ( SmallCaps [Str "Hello"] + , [s|{"t":"SmallCaps","c":[{"t":"Str","c":"Hello"}]}|] + ) + +t_quoted :: (Inline, ByteString) +t_quoted = ( Quoted SingleQuote [Str "Hello"] + , [s|{"t":"Quoted","c":[{"t":"SingleQuote"},[{"t":"Str","c":"Hello"}]]}|] + ) + +t_cite :: (Inline, ByteString) +t_cite = ( Cite [Citation { citationId = "jameson:unconscious" + , citationPrefix = [Str "cf"] + , citationSuffix = [Space,Str "12"] + , citationMode = NormalCitation + , citationNoteNum = 0 + , citationHash = 0}] + [ Str "[cf" + , Space + , Str "@jameson:unconscious" + , Space + , Str "12]"] + ,[s|{"t":"Cite","c":[[{"citationId":"jameson:unconscious","citationPrefix":[{"t":"Str","c":"cf"}],"citationSuffix":[{"t":"Space"},{"t":"Str","c":"12"}],"citationMode":{"t":"NormalCitation"},"citationNoteNum":0,"citationHash":0}],[{"t":"Str","c":"[cf"},{"t":"Space"},{"t":"Str","c":"@jameson:unconscious"},{"t":"Space"},{"t":"Str","c":"12]"}]]}|] + ) + +t_code :: (Inline, ByteString) +t_code = ( Code ("", [], [("language", "haskell")]) "foo bar" + , [s|{"t":"Code","c":[["",[],[["language","haskell"]]],"foo bar"]}|] + ) + +t_space :: (Inline, ByteString) +t_space = ( Space, [s|{"t":"Space"}|] ) + +t_softbreak :: (Inline, ByteString) +t_softbreak = ( SoftBreak, [s|{"t":"SoftBreak"}|] ) + +t_linebreak :: (Inline, ByteString) +t_linebreak = ( LineBreak, [s|{"t":"LineBreak"}|] ) + +t_rawinline :: (Inline, ByteString) +t_rawinline = ( RawInline (Format "tex") "\\foo{bar}" + , [s|{"t":"RawInline","c":["tex","\\foo{bar}"]}|] + ) + +t_link :: (Inline, ByteString) +t_link = ( Link ("id",["kls"],[("k1", "v1"), ("k2", "v2")]) + [ Str "a", Space, Str "famous", Space, Str "site"] + ("https://www.google.com","google") + , [s|{"t":"Link","c":[["id",["kls"],[["k1","v1"],["k2","v2"]]],[{"t":"Str","c":"a"},{"t":"Space"},{"t":"Str","c":"famous"},{"t":"Space"},{"t":"Str","c":"site"}],["https://www.google.com","google"]]}|] + ) + +t_image :: (Inline, ByteString) +t_image = ( Image ("id",["kls"],[("k1", "v1"), ("k2", "v2")]) + [ Str "a", Space, Str "famous", Space, Str "image"] + ("my_img.png","image") + , [s|{"t":"Image","c":[["id",["kls"],[["k1","v1"],["k2","v2"]]],[{"t":"Str","c":"a"},{"t":"Space"},{"t":"Str","c":"famous"},{"t":"Space"},{"t":"Str","c":"image"}],["my_img.png","image"]]}|] + ) + +t_note :: (Inline, ByteString) +t_note = ( Note [Para [Str "Hello"]] + , [s|{"t":"Note","c":[{"t":"Para","c":[{"t":"Str","c":"Hello"}]}]}|] + ) + +t_span :: (Inline, ByteString) +t_span = ( Span ("id", ["kls"], [("k1", "v1"), ("k2", "v2")]) [Str "Hello"] + , [s|{"t":"Span","c":[["id",["kls"],[["k1","v1"],["k2","v2"]]],[{"t":"Str","c":"Hello"}]]}|] + ) + +t_plain :: (Block, ByteString) +t_plain = ( Plain [Str "Hello"] + , [s|{"t":"Plain","c":[{"t":"Str","c":"Hello"}]}|] + ) + +t_para :: (Block, ByteString) +t_para = ( Para [Str "Hello"] + , [s|{"t":"Para","c":[{"t":"Str","c":"Hello"}]}|] + ) + +t_lineblock :: (Block, ByteString) +t_lineblock = ( LineBlock [[Str "Hello"], [Str "Moin"]] + , [s|{"t":"LineBlock","c":[[{"t":"Str","c":"Hello"}],[{"t":"Str","c":"Moin"}]]}|] + ) + +t_codeblock :: (Block, ByteString) +t_codeblock = ( CodeBlock ("id", ["kls"], [("k1", "v1"), ("k2", "v2")]) "Foo Bar" + , [s|{"t":"CodeBlock","c":[["id",["kls"],[["k1","v1"],["k2","v2"]]],"Foo Bar"]}|] + ) + +t_rawblock :: (Block, ByteString) +t_rawblock = ( RawBlock (Format "tex") "\\foo{bar}" + , [s|{"t":"RawBlock","c":["tex","\\foo{bar}"]}|] + ) + +t_blockquote :: (Block, ByteString) +t_blockquote = ( BlockQuote [Para [Str "Hello"]] + , [s|{"t":"BlockQuote","c":[{"t":"Para","c":[{"t":"Str","c":"Hello"}]}]}|] + ) + +t_orderedlist :: (Block, ByteString) +t_orderedlist = (OrderedList (1,Decimal,Period) + [[Para [Str "foo"]] + ,[Para [Str "bar"]]] + , [s|{"t":"OrderedList","c":[[1,{"t":"Decimal"},{"t":"Period"}],[[{"t":"Para","c":[{"t":"Str","c":"foo"}]}],[{"t":"Para","c":[{"t":"Str","c":"bar"}]}]]]}|] + ) + +t_bulletlist :: (Block, ByteString) +t_bulletlist = (BulletList + [[Para [Str "foo"]] + ,[Para [Str "bar"]]] + , [s|{"t":"BulletList","c":[[{"t":"Para","c":[{"t":"Str","c":"foo"}]}],[{"t":"Para","c":[{"t":"Str","c":"bar"}]}]]}|] + ) + +t_definitionlist :: (Block, ByteString) +t_definitionlist = (DefinitionList + [([Str "foo"], + [[Para [Str "bar"]]]) + ,([Str "fizz"], + [[Para [Str "pop"]]])] + , [s|{"t":"DefinitionList","c":[[[{"t":"Str","c":"foo"}],[[{"t":"Para","c":[{"t":"Str","c":"bar"}]}]]],[[{"t":"Str","c":"fizz"}],[[{"t":"Para","c":[{"t":"Str","c":"pop"}]}]]]]}|] + ) + +t_header :: (Block, ByteString) +t_header = ( Header 2 ("id", ["kls"], [("k1", "v1"), ("k2", "v2")]) [Str "Head"] + , [s|{"t":"Header","c":[2,["id",["kls"],[["k1","v1"],["k2","v2"]]],[{"t":"Str","c":"Head"}]]}|] + ) + +t_row :: (Row, ByteString) +t_row = (Row ("id",["kls"],[("k1", "v1"), ("k2", "v2")]) + [Cell ("", [], []) AlignRight 2 3 [Para [Str "bar"]]] + ,[s|[["id",["kls"],[["k1","v1"],["k2","v2"]]],[[["",[],[]],{"t":"AlignRight"},2,3,[{"t":"Para","c":[{"t":"Str","c":"bar"}]}]]]]|]) + +t_caption :: (Caption, ByteString) +t_caption = (Caption (Just [Str "foo"]) [Para [Str "bar"]] + ,[s|[[{"t":"Str","c":"foo"}],[{"t":"Para","c":[{"t":"Str","c":"bar"}]}]]|]) + +t_tablehead :: (TableHead, ByteString) +t_tablehead = (TableHead ("id",["kls"],[("k1", "v1"), ("k2", "v2")]) + [Row ("id",["kls"],[("k1", "v1"), ("k2", "v2")]) []] + ,[s|[["id",["kls"],[["k1","v1"],["k2","v2"]]],[[["id",["kls"],[["k1","v1"],["k2","v2"]]],[]]]]|]) + +t_tablebody :: (TableBody, ByteString) +t_tablebody = (TableBody ("id",["kls"],[("k1", "v1"), ("k2", "v2")]) 3 + [Row ("id",["kls"],[("k1", "v1"), ("k2", "v2")]) []] + [Row ("id'",["kls'"],[("k1", "v1"), ("k2", "v2")]) []] + ,[s|[["id",["kls"],[["k1","v1"],["k2","v2"]]],3,[[["id",["kls"],[["k1","v1"],["k2","v2"]]],[]]],[[["id'",["kls'"],[["k1","v1"],["k2","v2"]]],[]]]]|]) + +t_tablefoot :: (TableFoot, ByteString) +t_tablefoot = (TableFoot ("id",["kls"],[("k1", "v1"), ("k2", "v2")]) + [Row ("id",["kls"],[("k1", "v1"), ("k2", "v2")]) []] + ,[s|[["id",["kls"],[["k1","v1"],["k2","v2"]]],[[["id",["kls"],[["k1","v1"],["k2","v2"]]],[]]]]|]) + +t_cell :: (Cell, ByteString) +t_cell = (Cell ("id",["kls"],[("k1", "v1"), ("k2", "v2")]) AlignLeft 1 1 + [Para [Str "bar"]] + ,[s|[["id",["kls"],[["k1","v1"],["k2","v2"]]],{"t":"AlignLeft"},1,1,[{"t":"Para","c":[{"t":"Str","c":"bar"}]}]]|]) + +t_rowheadcolumns :: (RowHeadColumns, ByteString) +t_rowheadcolumns = (1 + ,[s|1|]) + +t_rowspan :: (RowSpan, ByteString) +t_rowspan = (1 + ,[s|1|]) + +t_colspan :: (ColSpan, ByteString) +t_colspan = (1 + ,[s|1|]) + +t_table :: (Block, ByteString) +t_table = ( Table + ("id", ["kls"], [("k1", "v1"), ("k2", "v2")]) + (Caption + (Just [Str "short"]) + [Para [Str "Demonstration" + ,Space + ,Str "of" + ,Space + ,Str "simple" + ,Space + ,Str "table" + ,Space + ,Str "syntax."]]) + [(AlignDefault,ColWidthDefault) + ,(AlignRight,ColWidthDefault) + ,(AlignLeft,ColWidthDefault) + ,(AlignCenter,ColWidthDefault) + ,(AlignDefault,ColWidthDefault)] + (TableHead ("idh", ["klsh"], [("k1h", "v1h"), ("k2h", "v2h")]) + [tRow + [tCell [Str "Head"] + ,tCell [Str "Right"] + ,tCell [Str "Left"] + ,tCell [Str "Center"] + ,tCell [Str "Default"]]]) + [TableBody ("idb", ["klsb"], [("k1b", "v1b"), ("k2b", "v2b")]) 1 + [tRow + [tCell [Str "ihead12"] + ,tCell [Str "i12"] + ,tCell [Str "i12"] + ,tCell [Str "i12"] + ,tCell [Str "i12"]]] + [tRow + [tCell [Str "head12"] + ,tCell' [Str "12"] + ,tCell [Str "12"] + ,tCell' [Str "12"] + ,tCell [Str "12"]] + ,tRow + [tCell [Str "head123"] + ,tCell [Str "123"] + ,tCell [Str "123"] + ,tCell [Str "123"] + ,tCell [Str "123"]] + ,tRow + [tCell [Str "head1"] + ,tCell [Str "1"] + ,tCell [Str "1"] + ,tCell [Str "1"] + ,tCell [Str "1"]]]] + (TableFoot ("idf", ["klsf"], [("k1f", "v1f"), ("k2f", "v2f")]) + [tRow + [tCell [Str "foot"] + ,tCell [Str "footright"] + ,tCell [Str "footleft"] + ,tCell [Str "footcenter"] + ,tCell [Str "footdefault"]]]) + ,[s|{"t":"Table","c":[["id",["kls"],[["k1","v1"],["k2","v2"]]],[[{"t":"Str","c":"short"}],[{"t":"Para","c":[{"t":"Str","c":"Demonstration"},{"t":"Space"},{"t":"Str","c":"of"},{"t":"Space"},{"t":"Str","c":"simple"},{"t":"Space"},{"t":"Str","c":"table"},{"t":"Space"},{"t":"Str","c":"syntax."}]}]],[[{"t":"AlignDefault"},{"t":"ColWidthDefault"}],[{"t":"AlignRight"},{"t":"ColWidthDefault"}],[{"t":"AlignLeft"},{"t":"ColWidthDefault"}],[{"t":"AlignCenter"},{"t":"ColWidthDefault"}],[{"t":"AlignDefault"},{"t":"ColWidthDefault"}]],[["idh",["klsh"],[["k1h","v1h"],["k2h","v2h"]]],[[["id",["kls"],[["k1","v1"],["k2","v2"]]],[[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"Head"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"Right"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"Left"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"Center"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"Default"}]}]]]]]],[[["idb",["klsb"],[["k1b","v1b"],["k2b","v2b"]]],1,[[["id",["kls"],[["k1","v1"],["k2","v2"]]],[[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"ihead12"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"i12"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"i12"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"i12"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"i12"}]}]]]]],[[["id",["kls"],[["k1","v1"],["k2","v2"]]],[[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"head12"}]}]],[["id",["kls"],[["k1","v1"],["k2","v2"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"12"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"12"}]}]],[["id",["kls"],[["k1","v1"],["k2","v2"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"12"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"12"}]}]]]],[["id",["kls"],[["k1","v1"],["k2","v2"]]],[[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"head123"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"123"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"123"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"123"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"123"}]}]]]],[["id",["kls"],[["k1","v1"],["k2","v2"]]],[[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"head1"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"1"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"1"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"1"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"1"}]}]]]]]]],[["idf",["klsf"],[["k1f","v1f"],["k2f","v2f"]]],[[["id",["kls"],[["k1","v1"],["k2","v2"]]],[[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"foot"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"footright"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"footleft"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"footcenter"}]}]],[["a",["b"],[["c","d"],["e","f"]]],{"t":"AlignDefault"},1,1,[{"t":"Plain","c":[{"t":"Str","c":"footdefault"}]}]]]]]]]}|] + ) + where + tCell i = Cell ("a", ["b"], [("c", "d"), ("e", "f")]) AlignDefault 1 1 [Plain i] + tCell' i = Cell ("id", ["kls"], [("k1", "v1"), ("k2", "v2")]) AlignDefault 1 1 [Plain i] + tRow = Row ("id", ["kls"], [("k1", "v1"), ("k2", "v2")]) + +t_figure :: (Block, ByteString) +t_figure = (Figure + ("id", ["kls"], [("k1", "v1"), ("k2", "v2")]) + (Caption (Just [Str "hello"]) [Para [Str "cap content"]]) + [Para [Str "fig content"]] + ,[s|{"t":"Figure","c":[["id",["kls"],[["k1","v1"],["k2","v2"]]],[[{"t":"Str","c":"hello"}],[{"t":"Para","c":[{"t":"Str","c":"cap content"}]}]],[{"t":"Para","c":[{"t":"Str","c":"fig content"}]}]]}|] + ) + +t_div :: (Block, ByteString) +t_div = ( Div ("id", ["kls"], [("k1", "v1"), ("k2", "v2")]) [Para [Str "Hello"]] + , [s|{"t":"Div","c":[["id",["kls"],[["k1","v1"],["k2","v2"]]],[{"t":"Para","c":[{"t":"Str","c":"Hello"}]}]]}|] + ) + +-- headers and rows are padded to a consistent number of +-- cells in order to avoid syntax errors after conversion, see +-- jgm/pandoc#4059. +-- This may change as the table representation changes. +t_tableSan :: Test +t_tableSan = testCase "table sanitisation" assertion + where assertion = assertEqual err expected generated + err = "sanitisation error" + generated = simpleTable + [plain (text "foo"), plain (text "bar")] + [[mempty] + ,[]] + tCell i = Cell nullAttr AlignDefault 1 1 [Plain [Str i]] + emptyRow = Row nullAttr $ replicate 2 emptyCell + expected = singleton (Table + nullAttr + (Caption Nothing []) + [(AlignDefault,ColWidthDefault) + ,(AlignDefault,ColWidthDefault)] + (TableHead nullAttr + [Row nullAttr + [tCell "foo" + ,tCell "bar"]]) + [TableBody nullAttr 0 + [] + [emptyRow + ,emptyRow]] + (TableFoot nullAttr + [])) + +withWidth :: Testable prop => (Int -> prop) -> Property +withWidth = forAll $ choose (2 :: Int, 16) + +widthNormIsIdempotent :: (Arbitrary a, Show a, Eq a) + => (Int -> a -> a) -> Property +widthNormIsIdempotent f = withWidth $ + \n a -> let a' = f n a in f n a' == a' + +p_tableNormHeadIdempotent :: Property +p_tableNormHeadIdempotent = widthNormIsIdempotent normalizeTableHead + +p_tableNormBodyIdempotent :: Property +p_tableNormBodyIdempotent = widthNormIsIdempotent normalizeTableBody + +p_tableNormFootIdempotent :: Property +p_tableNormFootIdempotent = widthNormIsIdempotent normalizeTableFoot + +cellSubset :: Cell -> Cell -> Bool +cellSubset (Cell attr1 align1 rs1 cs1 body1) (Cell attr2 align2 rs2 cs2 body2) + = and [ attr1 == attr2 + , align1 == align2 + , dimValid rs1 rs2 + , dimValid cs1 cs2 + , body1 == body2 ] + where + dimValid x y = (y < 1 && x == 1) || (x >= 1 && x <= y) + +-- True when the first list is an initial segment of the second, +-- modulo cell subsetting and the appending of padding cells onto the +-- second. +cellsSubsetPad :: [Cell] -> [Cell] -> Bool +cellsSubsetPad (x:xs) (y:ys) = cellSubset x y && cellsSubsetPad xs ys +cellsSubsetPad xs _ = all isPadCell xs + where + isPadCell = (== emptyCell) + +-- Only valid for the TableHead and TableFoot. See also +-- p_tableNormBodyIsSubset. +rowSubset :: Row -> Row -> Bool +rowSubset (Row a1 x1) (Row a2 x2) = a1 == a2 && cellsSubsetPad x1 x2 + +-- The remarks in rowSubset apply. +rowsSubset :: [Row] -> [Row] -> Bool +rowsSubset (x:xs) (y:ys) = rowSubset x y && rowsSubset xs ys +rowsSubset [] _ = True +rowsSubset (_:_) [] = False + +normIsSubset :: (Arbitrary a, Show a, Eq a) + => (Int -> a -> a) + -> (a -> [Row]) + -> Property +normIsSubset f proj = withWidth $ + \n a -> let a' = f n a in proj a' `rowsSubset` proj a + +p_tableNormHeadIsSubset :: Property +p_tableNormHeadIsSubset = normIsSubset normalizeTableHead thproj + where + thproj (TableHead _ r) = r + +-- Checking that each row is a subset of its unnormalized version is a +-- little onerous in the TableBody (because of the row head/row body +-- distinction), so we settle for testing it only for the first row of +-- the intermediate body. The intermediate head is still checked +-- fully. +p_tableNormBodyIsSubset :: Property +p_tableNormBodyIsSubset = withWidth $ + \n tb -> checkBody n (normalizeTableBody n tb) tb + where + cellLength (Cell _ _ _ (ColSpan w) _) = w + cellLengths = sum . map cellLength + gatherLen n = gatherLen' n 0 + gatherLen' n count (c:cs) | count < n + = let (beg, end) = gatherLen' n (count + cellLength c) cs + in (c : beg, end) + gatherLen' _ _ cs = ([], cs) + -- Gather as much of the head as we can from the new and old rows, + -- then make sure the dimensions line up and the subsetting is + -- correct. + checkRow n rhc (Row _ r') (Row _ r) + = let (rhead', rbody') = gatherLen rhc r' + (rhead, rbody) = gatherLen rhc r + in and [ cellLengths rhead' == rhc + , rhc + cellLengths rbody' == n + , cellsSubsetPad rhead' rhead + , cellsSubsetPad rbody' rbody ] + checkRows n rhc (r':_) (r:_) = checkRow n rhc r' r + checkRows _ _ [] [] = True + checkRows _ _ _ _ = False + checkBody n (TableBody _ (RowHeadColumns rhc) th' tb') (TableBody _ _ th tb) + = rowsSubset th' th && checkRows n rhc tb' tb + +p_tableNormFootIsSubset :: Property +p_tableNormFootIsSubset = normIsSubset normalizeTableFoot tfproj + where + tfproj (TableFoot _ r) = r + +-- True when the first row in a section (table head, table foot, +-- intermediate header, body of table body) has the correct +-- width. Only with the first row is it easy to check. +firstRowCorrectWidth :: Int -> [Row] -> [Row] -> Bool +firstRowCorrectWidth n (Row _ cs:_) (_:_) = n == sum (map cellLength cs) + where cellLength (Cell _ _ _ (ColSpan w) _) = w +firstRowCorrectWidth _ [] [] = True +firstRowCorrectWidth _ _ _ = False + +testRowCorrectWidth :: (Arbitrary a, Show a, Eq a) + => (Int -> a -> a) + -> (a -> [Row]) + -> Property +testRowCorrectWidth f proj = withWidth $ + \n a -> let a' = f n a in firstRowCorrectWidth n (proj a') (proj a) + +p_tableNormHeadRowWidth :: Property +p_tableNormHeadRowWidth = testRowCorrectWidth normalizeTableHead thproj + where + thproj (TableHead _ r) = r + +p_tableNormBodyRowWidth :: Property +p_tableNormBodyRowWidth = withWidth $ + \n tb -> compBody n tb $ normalizeTableBody n tb + where + compBody n (TableBody _ _ th tb) (TableBody _ _ th' tb') + = firstRowCorrectWidth n th' th && firstRowCorrectWidth n tb' tb + +p_tableNormFootRowWidth :: Property +p_tableNormFootRowWidth = testRowCorrectWidth normalizeTableFoot tfproj + where + tfproj (TableFoot _ r) = r + +t_tableNormExample :: Test +t_tableNormExample = testCase "table normalization example" assertion + where + assertion = assertEqual "normalization error" expected generated + cl a h w = Cell (a, [], []) AlignDefault h w [] + rws = map $ Row nullAttr + th = TableHead nullAttr . rws + tb n x y = TableBody nullAttr n (rws x) (rws y) + tf = TableFoot nullAttr . rws + initialHeads = + [[cl "a" 1 1,cl "b" 3 2] + ,[cl "c" 2 2 ,cl "d" 1 1] + ] + finalHeads = + [[cl "a" 1 1, cl "b" 2 2] + ,[cl "c" 1 1] + ] + initialTB = tb 1 + [[] + ,[cl "g" (-7) 0,cl "h" 4 1]] + [[cl "e" 4 3 ,cl "f" 4 3] + ,[] + ,[emptyCell] + ] + finalTB = tb 1 + [[emptyCell,emptyCell,emptyCell] + ,[cl "g" 1 1,cl "h" 1 1,emptyCell]] + [[cl "e" 3 1,cl "f" 3 2] + ,[] + ,[]] + spec = replicate 3 (AlignDefault, ColWidthDefault) + expected = singleton $ Table nullAttr + emptyCaption + spec + (th finalHeads) + [finalTB] + (tf finalHeads) + generated = table emptyCaption spec (th initialHeads) [initialTB] (tf initialHeads) + +p_figureRepresentation :: Property +p_figureRepresentation = forAll (arbitrary :: Gen [Inline]) $ \figureCaption -> + simpleFigureWith + ("test", [], []) + (Builder.fromList figureCaption) + "url" + "title" == + Builder.fromList + [Figure + nullAttr + (Caption Nothing [Plain figureCaption | not (null figureCaption)]) + [Plain [Image ("test", [], []) mempty ("url", "title") ]]] + +tests :: [Test] +tests = + [ testGroup "Walk" + [ testProperty "p_walk inlineTrans" (p_walk inlineTrans) + , testProperty "p_walk blockTrans" (p_walk blockTrans) + , testProperty "p_walk metaValueTrans" (p_walk metaValueTrans) + , testProperty "p_walk metaTrans" (p_walk metaTrans) + , testProperty "p_query inlineQuery" (p_query inlineQuery) + , testProperty "p_query blockQuery" (p_query blockQuery) + , testProperty "p_query metaValueQuery" (p_query metaValueQuery) + , testProperty "p_query metaQuery" (p_query metaQuery) + , testProperty "p_walkList inlinesTrans" (p_walkList inlinesTrans) + , testProperty "p_queryList inlinesQuery" (p_queryList inlinesQuery) + , testProperty "p_walkList blocksTrans" (p_walkList blocksTrans) + , testProperty "p_queryList blocksQuery" (p_queryList blocksQuery) + ] + , testGroup "JSON" + [ testGroup "encoding/decoding properties" + [ testProperty "round-trip" prop_roundtrip + ] + , testGroup "JSON encoding/decoding" + [ testGroup "Meta" + [ testEncodeDecode "Meta" t_meta + , testEncodeDecode "MetaMap" t_metamap + , testEncodeDecode "MetaList" t_metalist + , testEncodeDecode "MetaBool" t_metabool + , testEncodeDecode "MetaString" t_metastring + , testEncodeDecode "MetaInlines" t_metainlines + , testEncodeDecode "MetaBlocks" t_metablocks + ] + , testGroup "QuoteType" + [ testEncodeDecode "SingleQuote" t_singlequote + , testEncodeDecode "DoubleQuote" t_doublequote + ] + , testGroup "CitationType" + [ testEncodeDecode "AuthorInText" t_authorintext + , testEncodeDecode "SuppressAuthor" t_suppressauthor + , testEncodeDecode "NormalCitation" t_normalcitation + ] + , testEncodeDecode "Citation" t_citation + , testGroup "MathType" + [ testEncodeDecode "DisplayMath" t_displaymath + , testEncodeDecode "InlineMath" t_inlinemath + ] + , testGroup "Inline" + [ testEncodeDecode "Str" t_str + , testEncodeDecode "Emph" t_emph + , testEncodeDecode "Underline" t_underline + , testEncodeDecode "Strong" t_strong + , testEncodeDecode "Strikeout" t_strikeout + , testEncodeDecode "Superscript" t_superscript + , testEncodeDecode "Subscript" t_subscript + , testEncodeDecode "SmallCaps" t_smallcaps + , testEncodeDecode "Quoted" t_quoted + , testEncodeDecode "Cite" t_cite + , testEncodeDecode "Code" t_code + , testEncodeDecode "Space" t_space + , testEncodeDecode "SoftBreak" t_softbreak + , testEncodeDecode "LineBreak" t_linebreak + , testEncodeDecode "RawInline" t_rawinline + , testEncodeDecode "Link" t_link + , testEncodeDecode "Image" t_image + , testEncodeDecode "Note" t_note + , testEncodeDecode "Span" t_span + ] + , testGroup "Block" + [ testEncodeDecode "Plain" t_plain + , testEncodeDecode "Para" t_para + , testEncodeDecode "LineBlock" t_lineblock + , testEncodeDecode "CodeBlock" t_codeblock + , testEncodeDecode "RawBlock" t_rawblock + , testEncodeDecode "BlockQuote" t_blockquote + , testEncodeDecode "OrderedList" t_orderedlist + , testEncodeDecode "BulletList" t_bulletlist + , testEncodeDecode "DefinitionList" t_definitionlist + , testEncodeDecode "Header" t_header + , testEncodeDecode "Table" t_table + , testEncodeDecode "Figure" t_figure + , testEncodeDecode "Div" t_div + ] + , testGroup "Table" + [ testEncodeDecode "Row" t_row + , testEncodeDecode "Caption" t_caption + , testEncodeDecode "TableHead" t_tablehead + , testEncodeDecode "TableBody" t_tablebody + , testEncodeDecode "TableFoot" t_tablefoot + , testEncodeDecode "Cell" t_cell + , testEncodeDecode "RowHeadColumns" t_rowheadcolumns + , testEncodeDecode "RowSpan" t_rowspan + , testEncodeDecode "ColSpan" t_colspan + ] + ] + ] + , testGroup "Table normalization" + [ testProperty "p_tableNormHeadIdempotent" p_tableNormHeadIdempotent + , testProperty "p_tableNormBodyIdempotent" p_tableNormBodyIdempotent + , testProperty "p_tableNormFootIdempotent" p_tableNormFootIdempotent + , testProperty "p_tableNormHeadIsSubset" p_tableNormHeadIsSubset + , testProperty "p_tableNormBodyIsSubset" p_tableNormBodyIsSubset + , testProperty "p_tableNormFootIsSubset" p_tableNormFootIsSubset + , testProperty "p_tableNormHeadRowWidth" p_tableNormHeadRowWidth + , testProperty "p_tableNormBodyRowWidth" p_tableNormBodyRowWidth + , testProperty "p_tableNormFootRowWidth" p_tableNormFootRowWidth + ] + , t_tableSan + , t_tableNormExample + , testGroup "Figure" + [ testProperty "p_figureRepresentation figure representation" p_figureRepresentation ] + ] + + +main :: IO () +main = defaultMain tests +