Moved Printout.BBCode to own module

8 files changed, 325 insertions, 0 deletions

diff --git a/tp-bbcode/LICENSE b/tp-bbcode/LICENSE
new file mode 100644
index 0000000..4ad71e2
--- /dev/null
+++ b/tp-bbcode/LICENSE
@@ -0,0 +1,27 @@
+Statement of Purpose
+
+The laws of most jurisdictions throughout the world automatically confer exclusive Copyright and Related Rights (defined below) upon the creator and subsequent owner(s) (each and all, an "owner") of an original work of authorship and/or a database (each, a "Work").
+
+Certain owners wish to permanently relinquish those rights to a Work for the purpose of contributing to a commons of creative, cultural and scientific works ("Commons") that the public can reliably and without fear of later claims of infringement build upon, modify, incorporate in other works, reuse and redistribute as freely as possible in any form whatsoever and for any purposes, including without limitation commercial purposes. These owners may contribute to the Commons to promote the ideal of a free culture and the further production of creative, cultural and scientific works, or to gain reputation or greater distribution for their Work in part through the use and efforts of others.
+
+For these and/or other purposes and motivations, and without any expectation of additional consideration or compensation, the person associating CC0 with a Work (the "Affirmer"), to the extent that he or she is an owner of Copyright and Related Rights in the Work, voluntarily elects to apply CC0 to the Work and publicly distribute the Work under its terms, with knowledge of his or her Copyright and Related Rights in the Work and the meaning and intended legal effect of CC0 on those rights.
+
+1. Copyright and Related Rights. A Work made available under CC0 may be protected by copyright and related or neighboring rights ("Copyright and Related Rights"). Copyright and Related Rights include, but are not limited to, the following:
+
+the right to reproduce, adapt, distribute, perform, display, communicate, and translate a Work;
+moral rights retained by the original author(s) and/or performer(s);
+publicity and privacy rights pertaining to a person's image or likeness depicted in a Work;
+rights protecting against unfair competition in regards to a Work, subject to the limitations in paragraph 4(a), below;
+rights protecting the extraction, dissemination, use and reuse of data in a Work;
+database rights (such as those arising under Directive 96/9/EC of the European Parliament and of the Council of 11 March 1996 on the legal protection of databases, and under any national implementation thereof, including any amended or successor version of such directive); and
+other similar, equivalent or corresponding rights throughout the world based on applicable law or treaty, and any national implementations thereof.
+2. Waiver. To the greatest extent permitted by, but not in contravention of, applicable law, Affirmer hereby overtly, fully, permanently, irrevocably and unconditionally waives, abandons, and surrenders all of Affirmer's Copyright and Related Rights and associated claims and causes of action, whether now known or unknown (including existing as well as future claims and causes of action), in the Work (i) in all territories worldwide, (ii) for the maximum duration provided by applicable law or treaty (including future time extensions), (iii) in any current or future medium and for any number of copies, and (iv) for any purpose whatsoever, including without limitation commercial, advertising or promotional purposes (the "Waiver"). Affirmer makes the Waiver for the benefit of each member of the public at large and to the detriment of Affirmer's heirs and successors, fully intending that such Waiver shall not be subject to revocation, rescission, cancellation, termination, or any other legal or equitable action to disrupt the quiet enjoyment of the Work by the public as contemplated by Affirmer's express Statement of Purpose.
+
+3. Public License Fallback. Should any part of the Waiver for any reason be judged legally invalid or ineffective under applicable law, then the Waiver shall be preserved to the maximum extent permitted taking into account Affirmer's express Statement of Purpose. In addition, to the extent the Waiver is so judged Affirmer hereby grants to each affected person a royalty-free, non transferable, non sublicensable, non exclusive, irrevocable and unconditional license to exercise Affirmer's Copyright and Related Rights in the Work (i) in all territories worldwide, (ii) for the maximum duration provided by applicable law or treaty (including future time extensions), (iii) in any current or future medium and for any number of copies, and (iv) for any purpose whatsoever, including without limitation commercial, advertising or promotional purposes (the "License"). The License shall be deemed effective as of the date CC0 was applied by Affirmer to the Work. Should any part of the License for any reason be judged legally invalid or ineffective under applicable law, such partial invalidity or ineffectiveness shall not invalidate the remainder of the License, and in such case Affirmer hereby affirms that he or she will not (i) exercise any of his or her remaining Copyright and Related Rights in the Work or (ii) assert any associated claims and causes of action with respect to the Work, in either case contrary to Affirmer's express Statement of Purpose.
+
+4. Limitations and Disclaimers.
+
+No trademark or patent rights held by Affirmer are waived, abandoned, surrendered, licensed or otherwise affected by this document.
+Affirmer offers the Work as-is and makes no representations or warranties of any kind concerning the Work, express, implied, statutory or otherwise, including without limitation warranties of title, merchantability, fitness for a particular purpose, non infringement, or the absence of latent or other defects, accuracy, or the present or absence of errors, whether or not discoverable, all to the greatest extent permissible under applicable law.
+Affirmer disclaims responsibility for clearing rights of other persons that may apply to the Work or any use thereof, including without limitation any person's Copyright and Related Rights in the Work. Further, Affirmer disclaims responsibility for obtaining any necessary consents, permissions or other rights required for any use of the Work.
+Affirmer understands and acknowledges that Creative Commons is not a party to this document and has no duty or obligation with respect to this CC0 or use of the Work.
\ No newline at end of file
diff --git a/tp-bbcode/Setup.hs b/tp-bbcode/Setup.hs
new file mode 100644
index 0000000..9a994af
--- /dev/null
+++ b/tp-bbcode/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/tp-bbcode/src/Thermoprint/Printout/BBCode.hs b/tp-bbcode/src/Thermoprint/Printout/BBCode.hs
new file mode 100644
index 0000000..ce2aa43
--- /dev/null
+++ b/tp-bbcode/src/Thermoprint/Printout/BBCode.hs
@@ -0,0 +1,145 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE GADTs #-}
+
+-- | Use 'Text.BBCode' to parse BBCode
+module Thermoprint.Printout.BBCode
+       ( bbcode
+       , BBCodeError(..)
+       , TreeError(..)
+       , SemanticError(..)
+       ) where
+
+import Data.Text (Text)
+import Data.Map (Map)
+
+import qualified Data.Text.Lazy as Lazy (Text)
+import qualified Data.Text.Lazy as TL (fromStrict)
+
+import Data.Sequence (Seq)
+import qualified Data.Sequence as Seq (fromList, singleton)
+
+import Data.CaseInsensitive (CI)
+import qualified Data.CaseInsensitive as CI
+
+import GHC.Generics (Generic)
+import Control.Exception (Exception)
+import Data.Typeable (Typeable)
+
+import Data.Bifunctor (bimap, first)
+import Control.Monad (join)
+
+import Data.List (groupBy)
+
+import Text.BBCode (DomForest, DomTree(..), TreeError(..))
+import qualified Text.BBCode as Raw (bbcode, BBCodeError(..))
+
+import Thermoprint.Printout
+
+import Thermoprint.Printout.BBCode.Attribute
+
+-- ^ We replicate 'Raw.BBCodeError' but add a new failure mode documenting incompatibly of the parsed syntax tree with our document format
+data BBCodeError = LexerError String -- ^ Error while parsing input to stream of tokens
+                 | TreeError TreeError -- ^ Error while parsing stream of tokens to syntax tree
+                 | SemanticError SemanticError -- ^ Error while mapping syntax tree to document format
+                 deriving (Show, Eq, Generic, Typeable)
+
+instance Exception BBCodeError
+
+morph' :: Raw.BBCodeError -> BBCodeError
+-- ^ Transform 'Raw.BBCodeError' to 'BBCodeError'
+morph' (Raw.LexerError x) = LexerError x
+morph' (Raw.TreeError x)  = TreeError x
+
+-- | An error ocurred while parsing the DOM-Forest (`['DomTree']`)
+data SemanticError = BlockInLineContext -- ^ A 'Block' structure was encountered when a 'Line' was expected
+                   | LineInBlockContext -- ^ A 'Line' structure was encountered when a 'Block' was expected
+                   | UnmappedBlockElement Text -- ^ We encountered an 'Element' that, in a 'Block' context, does not map to any structure
+                   | UnmappedLineElement Text -- ^ We encountered an 'Element' that, in a 'Line' context, does not map to any structure
+  deriving (Show, Eq, Generic, Typeable)
+
+instance Exception SemanticError
+
+-- | Result of parsing a single 'DomTree'
+data ParseResult = RBlock Block -- ^ Parses only as 'Block'
+                 | RLine Line -- ^ Parses only as 'Line'
+                 | RAmbiguous Block Line -- ^ Parses as either 'Block' or 'Line' depending on context
+                 | RNoParse SemanticError SemanticError -- ^ Does not parse as either 'Block' or 'Line'
+                 deriving (Show)
+
+-- | Current parser context
+data Context a where
+  BlockCtx :: Context Block
+  LineCtx  :: Context Line
+
+extract :: Context a -> ParseResult -> Either SemanticError a
+-- ^ Extract information from a 'ParseResult' given 'Context'
+extract BlockCtx (RBlock b)        = Right b
+extract LineCtx  (RLine l)         = Right l
+extract BlockCtx (RAmbiguous b _)  = Right b
+extract LineCtx  (RAmbiguous _ l)  = Right l
+extract BlockCtx (RNoParse bErr _) = Left bErr
+extract LineCtx  (RNoParse _ lErr) = Left lErr
+extract BlockCtx _                 = Left LineInBlockContext
+extract LineCtx  _                 = Left BlockInLineContext
+
+hasBlockCtx :: ParseResult -> Bool
+-- ^ Result can be 'extract'ed in a 'Block' 'Context'
+hasBlockCtx (RLine _) = False
+hasBlockCtx _         = True
+
+hasLineCtx :: ParseResult -> Bool
+-- ^ Result can be 'extract'ed in a 'Line' 'Context'
+hasLineCtx (RBlock _) = False
+hasLineCtx _          = True
+
+bbcode :: Text -> Either BBCodeError Printout
+-- ^ Parse BBCode
+bbcode = join . fmap (first SemanticError) . bimap morph' morph . Raw.bbcode
+
+morph :: DomForest -> Either SemanticError Printout
+-- ^ Parse a list of paragraphs
+--
+-- Since we permit only cooked input via 'Raw' 'Paragraph' is identical to 'Block'
+morph = fmap Seq.fromList . mapM (\t -> Seq.singleton . Cooked <$> parse BlockCtx t)
+
+parseDom :: DomTree -> ParseResult
+-- ^ Invoke 'asLine' and 'asBlock' to parse a single 'DomTree'
+parseDom (Content t) = either RBlock (\l -> RAmbiguous (Line l) l) . text . TL.fromStrict $ t
+parseDom (Element t attrs cs)
+  | Right blockParse' <- blockParse
+  , Right lineParse' <- lineParse   = RAmbiguous blockParse' lineParse'
+  | Right blockParse' <- blockParse = RBlock blockParse'
+  | Right lineParse' <- lineParse   = RLine lineParse'
+  | Left bErr <- blockParse
+  , Left lErr <- lineParse          = RNoParse bErr lErr
+  where
+    blockParse = asBlock t cs attrs
+    lineParse  = asLine t cs attrs
+
+mergeResult :: Monoid a => Context a -> [ParseResult] -> Either SemanticError a
+-- ^ Merge a list of 'ParseResults' in a certain 'Context'
+mergeResult _        []                        = Right mempty
+mergeResult ctx      (amb@(RAmbiguous _ _):xs) = mappend <$> extract ctx amb <*> mergeResult ctx xs 
+mergeResult ctx      (err@(RNoParse _ _):_)    = extract ctx err
+mergeResult ctx      (x:xs)                    = mappend <$> extract ctx x <*> mergeResult ctx xs
+
+parse :: Monoid a => Context a -> [DomTree] -> Either SemanticError a
+-- ^ Parse a list of 'DomTree's in a certain 'Context'
+--
+-- @parse ctx = 'mergeResult' ctx . map 'parseDom'@
+parse BlockCtx = fmap mconcat . mapM mergeResult' . groupBy sameCtx . map parseDom
+  where
+    sameCtx a b = (hasLineCtx a && hasLineCtx b) || (hasBlockCtx a && hasBlockCtx b)
+    mergeResult' xs
+      | hasLineCtx `all` xs = Line <$> mergeResult LineCtx xs
+      | otherwise           = mergeResult BlockCtx xs
+parse ctx      = mergeResult ctx . map parseDom
+
+asBlock :: CI Text -> [DomTree] -> Map (CI Text) Text -> Either SemanticError Block
+asBlock "VSpace" _  = Right . VSpace . lookupAttr "height" True 1
+asBlock t        _  = const $ Left . UnmappedBlockElement . CI.original $ t
+
+asLine :: CI Text -> [DomTree] -> Map (CI Text) Text -> Either SemanticError Line
+asLine "HSpace"  _  = Right . HSpace . lookupAttr "width" True 1
+asLine t         _  = const $ Left . UnmappedLineElement . CI.original $ t
diff --git a/tp-bbcode/src/Thermoprint/Printout/BBCode/Attribute.hs b/tp-bbcode/src/Thermoprint/Printout/BBCode/Attribute.hs
new file mode 100644
index 0000000..538cca2
--- /dev/null
+++ b/tp-bbcode/src/Thermoprint/Printout/BBCode/Attribute.hs
@@ -0,0 +1,39 @@
+{-# LANGUAGE DefaultSignatures #-}
+
+-- | Parsing attributes
+module Thermoprint.Printout.BBCode.Attribute
+       ( Attribute(..)
+       , lookupAttr
+       ) where
+
+import Data.Text (Text)
+import qualified Data.Text as T (unpack, empty)
+
+import Data.Map (Map)
+import qualified Data.Map as Map (lookup)
+
+import Data.CaseInsensitive (CI)
+import qualified Data.CaseInsensitive as CI
+  
+import Text.Read (readMaybe)
+import Data.Maybe (fromMaybe)
+
+import Control.Applicative (Alternative(..))
+
+-- | We build our own version of 'Read' so we can override the presentation used
+--
+-- We provide a default implementation for 'Read a => Attribute a'
+class Attribute a where
+  attrRead :: Text -> Maybe a
+  default attrRead :: Read a => Text -> Maybe a
+  attrRead = readMaybe . T.unpack
+
+instance Attribute Integer
+
+lookupAttr :: Attribute a => CI Text -> Bool -> a -> Map (CI Text) Text -> a
+-- ^ Extract an attribute by name -- the 'Bool' attribute specifies whether we additionally accept the empty string as key
+lookupAttr t emptyOk def attrs = fromMaybe def $ (emptyOk' $ Map.lookup t attrs) >>= attrRead
+  where
+    emptyOk'
+      | emptyOk   = (<|> Map.lookup (CI.mk T.empty) attrs)
+      | otherwise = id
diff --git a/tp-bbcode/test/Spec.hs b/tp-bbcode/test/Spec.hs
new file mode 100644
index 0000000..a824f8c
--- /dev/null
+++ b/tp-bbcode/test/Spec.hs
@@ -0,0 +1 @@
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
diff --git a/tp-bbcode/test/Thermoprint/Printout/BBCodeSpec.hs b/tp-bbcode/test/Thermoprint/Printout/BBCodeSpec.hs
new file mode 100644
index 0000000..f3f1840
--- /dev/null
+++ b/tp-bbcode/test/Thermoprint/Printout/BBCodeSpec.hs
@@ -0,0 +1,42 @@
+{-# LANGUAGE OverloadedStrings, OverloadedLists #-}
+{-# LANGUAGE StandaloneDeriving #-}
+
+module Thermoprint.Printout.BBCodeSpec (spec) where
+
+import Test.Hspec
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck.Instances
+
+import Thermoprint.Printout.BBCode
+import Thermoprint.Printout
+
+import Data.Text (Text)
+
+import Control.Monad (zipWithM_)
+import Data.Monoid ((<>))
+import Data.Function (on)
+
+import qualified Data.Sequence as Seq (fromList)
+
+instance Eq Block where
+  (==) = (==) `on` cotext
+deriving instance Eq Chunk
+
+spec :: Spec
+spec = do
+  zipWithM_ example [1..] examples
+    where
+      example n (s, ts) = let str = "Example " <> show n
+                          in specify str $ bbcode s == (pOut <$> ts)
+
+pOut :: [Block] -> Printout
+pOut = pure . Seq.fromList . map Cooked
+
+examples :: [(Text, Either BBCodeError [Block])]
+examples = [ ("Hello World!"
+             , Right [Line (JuxtaPos [word "Hello", HSpace 1, word "World!"])])
+           , ("Hello [hspace width=2/] World!"
+             , Right [Line (JuxtaPos [word "Hello", HSpace 4, word "World!"])])
+           ]
+  where
+    word = (\(Right l) -> l) . text
diff --git a/tp-bbcode/thermoprint-bbcode.cabal b/tp-bbcode/thermoprint-bbcode.cabal
new file mode 100644
index 0000000..b9cb655
--- /dev/null
+++ b/tp-bbcode/thermoprint-bbcode.cabal
@@ -0,0 +1,50 @@
+-- Initial thermoprint-bbcode.cabal generated by cabal init.  For further 
+-- documentation, see http://haskell.org/cabal/users-guide/
+
+name:                thermoprint-bbcode
+version:             0.0.0
+synopsis:            Parse bbcode for use in thermoprint
+-- description:         
+homepage:            http://dirty-haskell.org/tags/thermoprint.html
+license:             PublicDomain
+license-file:        LICENSE
+author:              Gregor Kleen
+maintainer:          aethoago@141.li
+-- copyright:           
+category:            Text
+build-type:          Simple
+-- extra-source-files:  
+cabal-version:       >=1.10
+
+library
+  exposed-modules:     Thermoprint.Printout.BBCode
+  other-modules:       Thermoprint.Printout.BBCode.Attribute
+  extensions:          OverloadedStrings
+                     , OverloadedLists
+  -- other-extensions:    
+  build-depends:       base >=4.8.1 && <5
+                     , thermoprint-spec ==2.0.*
+                     , bbcode >=3.0 && <4
+                     , containers -any
+                     , text -any
+                     , case-insensitive -any
+  hs-source-dirs:      src
+  default-language:    Haskell2010
+
+Test-Suite tests
+  type:                exitcode-stdio-1.0
+  hs-source-dirs:      test
+  main-is:             Spec.hs
+  ghc-options:         -threaded -with-rtsopts=-N
+  extensions:          StandaloneDeriving
+                     , OverloadedStrings
+                     , OverloadedLists
+  build-depends:       base >=4.8.1 && <5
+                     , thermoprint-bbcode -any
+                     , thermoprint-spec ==2.0.*
+                     , hspec >=2.2.1 && <3
+                     , QuickCheck >=2.8.1 && <3
+                     , quickcheck-instances >=0.3.11 && <4
+                     , aeson >=0.9.0 && <1
+                     , containers -any
+                     , text -any
\ No newline at end of file
diff --git a/tp-bbcode/thermoprint-bbcode.nix b/tp-bbcode/thermoprint-bbcode.nix
new file mode 100644
index 0000000..9a48152
--- /dev/null
+++ b/tp-bbcode/thermoprint-bbcode.nix
@@ -0,0 +1,19 @@
+{ mkDerivation, aeson, base, bbcode, case-insensitive, containers
+, hspec, QuickCheck, quickcheck-instances, stdenv, text
+, thermoprint-spec
+}:
+mkDerivation {
+  pname = "thermoprint-bbcode";
+  version = "0.0.0";
+  src = ./.;
+  libraryHaskellDepends = [
+    base bbcode case-insensitive containers text thermoprint-spec
+  ];
+  testHaskellDepends = [
+    aeson base containers hspec QuickCheck quickcheck-instances text
+    thermoprint-spec
+  ];
+  homepage = "http://dirty-haskell.org/tags/thermoprint.html";
+  description = "Parse bbcode for use in thermoprint";
+  license = stdenv.lib.licenses.publicDomain;
+}