From 9db2c42f4880362cf098358de830415c14f6878c Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 25 Dec 2015 17:56:13 +0000 Subject: Cleaned tree for rewrite --- bbcode/src/BBCode/Syntax.hs | 108 -------------------------------------------- 1 file changed, 108 deletions(-) delete mode 100644 bbcode/src/BBCode/Syntax.hs (limited to 'bbcode/src/BBCode/Syntax.hs') 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) }) -- cgit v1.2.3