Moved Printout.BBCode to own module

5 files changed, 8 insertions, 240 deletions

diff --git a/spec/src/Thermoprint/Printout/BBCode.hs b/spec/src/Thermoprint/Printout/BBCode.hs
deleted file mode 100644
index ce2aa43..0000000
--- a/spec/src/Thermoprint/Printout/BBCode.hs
+++ /dev/null
@@ -1,145 +0,0 @@
-{-# 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/spec/src/Thermoprint/Printout/BBCode/Attribute.hs b/spec/src/Thermoprint/Printout/BBCode/Attribute.hs
deleted file mode 100644
index 538cca2..0000000
--- a/spec/src/Thermoprint/Printout/BBCode/Attribute.hs
+++ /dev/null
@@ -1,39 +0,0 @@
-{-# 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/spec/test/Thermoprint/Printout/BBCodeSpec.hs b/spec/test/Thermoprint/Printout/BBCodeSpec.hs
deleted file mode 100644
index f3f1840..0000000
--- a/spec/test/Thermoprint/Printout/BBCodeSpec.hs
+++ /dev/null
@@ -1,42 +0,0 @@
-{-# 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/spec/thermoprint-spec.cabal b/spec/thermoprint-spec.cabal
index 5624a3b..21ed439 100644
--- a/spec/thermoprint-spec.cabal
+++ b/spec/thermoprint-spec.cabal
@@ -19,10 +19,9 @@ cabal-version:       >=1.10
 library
   hs-source-dirs:      src
   exposed-modules:     Thermoprint.Printout
-                     , Thermoprint.Printout.BBCode
                      , Thermoprint.Identifiers
                      , Thermoprint.API
-  other-modules:       Thermoprint.Printout.BBCode.Attribute
+  -- other-modules:       
   -- other-extensions:    
   extensions:          DeriveGeneric
                      , DeriveAnyClass
@@ -33,7 +32,6 @@ library
                      , GADTs
                      , DefaultSignatures
   build-depends:       base >=4.8.1 && <5
-                     , bbcode -any
                      , containers >=0.5.6 && <1
                      , text >=1.2.1 && <2
                      , bytestring >=0.10.6 && <1
@@ -46,7 +44,6 @@ library
                      , aeson >=0.9.0 && <1
                      , base64-bytestring >=1.0.0 && <2
                      , encoding >=0.8 && <1
-                     , case-insensitive >=1.2 && <2
   -- hs-source-dirs:      
   default-language:    Haskell2010
 
@@ -63,6 +60,4 @@ Test-Suite tests
                      , hspec >=2.2.1 && <3
                      , QuickCheck >=2.8.1 && <3
                      , quickcheck-instances >=0.3.11 && <4
-                     , aeson >=0.9.0 && <1
-                     , containers >=0.5.6 && <1
-                     , text >=1.2.1 && <2
\ No newline at end of file
+                     , aeson >=0.9.0 && <1
\ No newline at end of file
diff --git a/spec/thermoprint-spec.nix b/spec/thermoprint-spec.nix
index 0e548a6..5a89bcf 100644
--- a/spec/thermoprint-spec.nix
+++ b/spec/thermoprint-spec.nix
@@ -1,16 +1,15 @@
-{ mkDerivation, aeson, base, base64-bytestring, bbcode, bytestring
-, Cabal, cabal-test-quickcheck, case-insensitive, containers
-, deepseq, encoding, hspec, QuickCheck, quickcheck-instances
-, servant, stdenv, text
+{ mkDerivation, aeson, base, base64-bytestring, bytestring, Cabal
+, cabal-test-quickcheck, containers, deepseq, encoding, hspec
+, QuickCheck, quickcheck-instances, servant, stdenv, text
 }:
 mkDerivation {
   pname = "thermoprint-spec";
   version = "2.0.0";
   src = ./.;
   libraryHaskellDepends = [
-    aeson base base64-bytestring bbcode bytestring Cabal
-    cabal-test-quickcheck case-insensitive containers deepseq encoding
-    QuickCheck quickcheck-instances servant text
+    aeson base base64-bytestring bytestring Cabal cabal-test-quickcheck
+    containers deepseq encoding QuickCheck quickcheck-instances servant
+    text
   ];
   testHaskellDepends = [
     aeson base hspec QuickCheck quickcheck-instances