Cleaned tree for rewrite

3 files changed, 0 insertions, 272 deletions

diff --git a/bbcode/src/BBCode.hs b/bbcode/src/BBCode.hs
deleted file mode 100644
index 087842f..0000000
--- a/bbcode/src/BBCode.hs
+++ /dev/null
@@ -1,120 +0,0 @@
-{-# LANGUAGE OverloadedStrings, OverloadedLists, RankNTypes, ImpredicativeTypes #-}
-
-module BBCode
-       ( parse
-       , make
-       ) where
-
-import Thermoprint
-
-import BBCode.Tokenizer
-import BBCode.Syntax
-
-import Data.Maybe
-import Data.Monoid
-import Data.Either
-import Data.Bifunctor
-import Data.List
-import Data.Ord
-import Data.Foldable
-
-import Data.Function (on)
-
-import           Data.CaseInsensitive  ( CI )
-import qualified Data.CaseInsensitive as CI
-
-import           Data.Map  ( Map )
-import qualified Data.Map as Map
-
-import Prelude hiding (takeWhile)
-
-import Debug.Trace
-
-knownTags :: Map (CI String) (Either (Block String -> Block String) (Inline String -> Inline String))
-knownTags = [ ("center", Left Center)
-            , ("u", Right Underline)
-            ]
-
-isBlock, isInline :: String -> Bool
-isBlock = testTag isLeft
-isInline = testTag isRight
-testTag f k = fromMaybe False (f <$> Map.lookup (CI.mk k) knownTags)
-
-data Decorated c = Decorated c [String]
-                 deriving (Show, Eq)
-
-make :: Block String -> String
-make (Over blocks) = concat $ map make blocks
-make (Center block) = "[center]" ++ make block ++ "[/center]\n"
-make (Paragraph inline) = make' inline ++ "\n"
-
-make' :: Inline String -> String
-make' (Beside inlines) = concat $ map make' inlines
-make' (Underline inline) = "[u]" ++ make' inline ++ "[/u]"
-make' (Cooked c) = c
-make' (Raw _) = error "Cannot transform block containing raw data to bbcode"
-
-parse :: String -> Either String (Block String)
-parse input = massage <$> ((remerge . blockify <$> (tokenize input >>= treeify)) >>= semantics)
-
-massage :: Block String -> Block String
-massage (Over [x]) = massage x
-massage (Over xs) = Over $ map massage xs
-massage (Center x) = Center $ massage x
-massage (Paragraph x) = Paragraph $ massage' x
-
-massage' :: Inline String -> Inline String
-massage' (Beside [x]) = massage' x
-massage' (Beside xs) = Beside $ map massage' xs
-massage' (Underline x) = Underline $ massage' x
-massage' z = z
-
-blockify :: ContentForest -> [Decorated String]
-blockify = map sortDeco . concat . map (blockify' [])
-  where
-    blockify' _ Empty = []
-    blockify' initial (Content str) = [str `Decorated` initial]
-    blockify' initial (Tagged cs tag) = concat $ map (blockify' $ tag : initial) cs
-    sortDeco :: Decorated c -> Decorated c
-    sortDeco (Decorated c tags) = Decorated c $ (nubBy ((==) `on` CI.mk) . sortBy blockiness) tags
-    blockiness :: String -> String -> Ordering
-    blockiness a b = comparing isBlock a b <> comparing CI.mk a b -- sort also alphabetically for the benefit of remerge
-
-remerge :: [Decorated String] -> ContentForest
-remerge [] = []
-remerge [(Decorated c deco)] = [appEndo applyDeco $ Content c]
-  where
-    applyDeco = foldMap (\t -> Endo (\c -> Tagged [c] t)) $ reverse deco
-remerge xs = concat $ map toTree $ groupLasts xs
-  where
-    groupLasts = groupBy ((==) `on` (listToMaybe . reverse . (\(Decorated _ ds) -> ds)))
-    -- toTree :: [Decorated String] -> [ContentTree]
-    toTree [] = []
-    toTree (x@(Decorated _ []):xs) = map (Content . (\(Decorated c []) -> c)) (x:xs)
-    toTree (x@(Decorated _ ds):xs) = [Tagged content tag]
-      where
-        tag = last ds
-        content = concat $ map toTree $ groupLasts $ map stripLast (x:xs)
-        stripLast (Decorated c ds) = Decorated c (init ds)
-
-unknownTag :: forall a. String -> Either String a
-unknownTag tag = Left $ "Unknown tag: " ++ tag
-
-semantics :: ContentForest -> Either String (Block String)
-semantics forest = Over <$> mapM semantics' forest
-
-semantics' :: ContentTree -> Either String (Block String)
-semantics' Empty = Right $ Over []
-semantics' (Content str) = Right $ Paragraph (Cooked str)
-semantics' (Tagged cs tag) = case Map.lookup (CI.mk tag) knownTags of
-  Nothing -> unknownTag tag
-  Just (Left f) -> Over . map f <$> mapM semantics' cs
-  Just (Right f) -> Paragraph . Beside . map f<$> mapM iSemantics cs
-
-iSemantics :: ContentTree -> Either String (Inline String)
-iSemantics Empty = Right $ Beside []
-iSemantics (Content str) = Right $ Cooked str
-iSemantics (Tagged cs tag) = case Map.lookup (CI.mk tag) knownTags of
-  Nothing -> unknownTag tag
-  Just (Left f) -> error "Known inline tag sorted within block"
-  Just (Right f) -> Beside . map f <$> mapM iSemantics cs
diff --git a/bbcode/src/BBCode/Syntax.hs b/bbcode/src/BBCode/Syntax.hs
deleted file mode 100644
index a196e05..0000000
--- a/bbcode/src/BBCode/Syntax.hs
+++ /dev/null
@@ -1,108 +0,0 @@
-{-# LANGUAGE RecordWildCards #-}
-
-module BBCode.Syntax
-       ( treeify
-       , ContentForest
-       , ContentTree(..)
-       ) where
-
-import BBCode.Tokenizer (Token(..))
-
-import Data.Foldable
-import Data.Bifunctor
-import Data.Monoid
-
-import Control.Monad.State
-import Control.Monad.Trans
-import Control.Monad
-  
-import           Data.CaseInsensitive  ( CI )
-import qualified Data.CaseInsensitive as CI
-
-import Data.Function (on)
-
-type ContentForest = [ContentTree]
-data ContentTree = Content String
-                 | Tagged [ContentTree] String
-                 | Empty
-                 deriving (Show, Eq)
-
-data Step = Down [ContentTree] [ContentTree] String
-          deriving (Show)
-
-data Zipper = Zipper
-              { hole :: String
-              , prevs :: [ContentTree]
-              , steps :: [Step]
-              }
-              deriving (Show)
-
-type Parser = StateT Zipper (Either String)
-abort :: String -> Parser a
-abort = lift . Left
-
-
-treeify :: [Token] -> Either String ContentForest
-treeify tokenStream = second (postProcess . unZip) $ execStateT (mapM_ incorporate tokenStream) (Zipper "" [] [])
-
-postProcess :: ContentForest -> ContentForest
-postProcess forest = do
-  tree <- forest
-  let
-    tree' = postProcess' tree
-  guard $ tree' /= Empty
-  return tree'
-  where
-    postProcess' :: ContentTree -> ContentTree
-    postProcess' (Content "") = Empty
-    postProcess' (Tagged [] _) = Empty
-    postProcess' (Tagged cs t) = Tagged [c' | c <- cs, let c' = postProcess' c, c' /= Empty ] t
-    postProcess' x = x
-
-unZip :: Zipper -> ContentForest
-unZip Zipper{..} = reverse (apply hole steps : prevs)
-
-apply :: String -> [Step] -> ContentTree
-apply hole steps = hole `apply'` (reverse steps)
-apply' "" [] = Empty
-apply' hole [] = Content hole
-apply' hole (Down pres posts tag:steps) = Tagged (reverse pres ++ [hole `apply` steps] ++ posts) tag
-
-incorporate :: Token -> Parser ()
-incorporate (Text str) = append str
-incorporate (Whitespace str)
-  | delimitsPar str = do
-      currSteps <- gets steps
-      if null currSteps then
-        modify (\Zipper{..} -> Zipper { hole = "", steps = [], prevs = (hole `apply` steps : prevs) })
-        else
-        append str
-  | otherwise = append str
-  where
-    delimitsPar str = (sum . map (const (1 :: Integer)) . filter (== '\n') $ str) >= 1
-incorporate (TagOpen tagName) = modify $ (\z@(Zipper{..}) -> z { steps = (Down [] [] tagName : steps) })
-incorporate (TagClose tagName) = do
-  currSteps <- gets steps
-  case currSteps of
-    [] -> abort $ "Closing unopenend tag: " ++ tagName
-    (Down pres posts tagName':s) -> if ((==) `on` CI.mk) tagName tagName' then
-                                      goUp
-                                    else
-                                       abort $ "Mismatched tags: [" ++ tagName' ++ "]...[/" ++ tagName ++ "]"
-
-append :: String -> Parser ()
-append str = modify (\z@(Zipper{..}) -> z { hole = hole ++ str })
-
-goUp :: Parser ()
-goUp = do
-  (Down pres posts tagName:s) <- gets steps
-  hole <- gets hole
-  let
-    steppedHole = Tagged (reverse pres ++ [Content hole] ++ posts) tagName
-  case s of
-    [] -> modify $ (\z@(Zipper{..}) -> Zipper { hole = "", prevs = steppedHole : prevs, steps = [] })
-    (t:ts) -> do
-      let
-        (Down pres posts tagName) = t
-        t' = Down (steppedHole : pres) posts tagName
-      modify $ (\z -> z { hole = "", steps = (t':ts) })
diff --git a/bbcode/src/BBCode/Tokenizer.hs b/bbcode/src/BBCode/Tokenizer.hs
deleted file mode 100644
index c860c7c..0000000
--- a/bbcode/src/BBCode/Tokenizer.hs
+++ /dev/null
@@ -1,44 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module BBCode.Tokenizer
-       ( Token(..)
-       , tokenize
-       ) where
-
-import qualified Data.Text.Lazy as TL
-import qualified Data.Text as T
-
-import Control.Applicative
-import Data.Attoparsec.Text.Lazy
-
-import Data.Char (isSpace)
-import Data.Monoid (mconcat)
-
-data Token = Text String
-           | Whitespace String
-           | TagOpen String
-           | TagClose String
-           deriving (Show, Read, Eq)
-
-tokenize :: String -> Either String [Token]
-tokenize = eitherResult . parse (tokenize' <* endOfInput) . TL.pack
-
-tokenize' :: Parser [Token]
-tokenize' = many $ choice [ whitespace
-                          , Text . T.unpack <$> ("\\" *> "[")
-                          , tagClose
-                          , tagOpen
-                          , text
-                          ]
-
-whitespace :: Parser Token
-whitespace = Whitespace <$> many1 space
-
-tagOpen :: Parser Token
-tagOpen = TagOpen . T.unpack <$> ("[" *> takeWhile1 (/= ']') <* "]")
-
-tagClose :: Parser Token
-tagClose = TagClose . T.unpack <$> ("[/" *> takeWhile1 (/= ']') <* "]")
-
-text :: Parser Token
-text = Text . T.unpack <$> takeWhile1 (\c -> not (isSpace c) && notInClass "[" c)