module Split (Split(..),Delims,split,unsplit,joinDoc,joinCode,joinDebug) where

import Regex (mkRegex,isMatch)

data Split
    = Code  String
    | Delim String
    | Doc   String
    | Blank String
    | Ext   String
    | Shell (IO String)

type Delims = (String,String,String,String)

split :: Bool -> Delims -> String -> [Split]
split isCode (start,end,xstart,xend) text = startFilt $ lines text
    where

    startFilt = if isCode then inCode else inDoc

    startDoc, endDoc, startExt, endExt :: String -> Bool

    startDoc x = isMatch x $ mkRegex start
    endDoc   x = isMatch x $ mkRegex end
    endExt   x = isMatch x $ mkRegex xend
    startExt x = if null xstart
        then False
        else isMatch x $ mkRegex xstart

    isBlank :: String -> Bool
    isBlank  x = all (`elem` " \t") x

    inCode, inDoc, inExt :: [String] -> [Split]

    inCode [] = []
    inCode (x:xt)
        | startDoc x = Delim x : inDoc  xt
        | startExt x = Ext   x : inExt  xt
        | isBlank  x = Blank x : inCode xt
        | otherwise  = Code  x : inCode xt

    inDoc [] = []
    inDoc (x:xt)
        | endDoc x  = Delim x : inCode xt
        | isBlank x = Blank x : inDoc  xt
        | otherwise = Doc   x : inDoc  xt

    inExt [] = []
    inExt (x:xt)
        | endExt x  = Ext x : inCode xt
        | otherwise = Ext x : inExt  xt

unsplit :: [Split] -> IO String
unsplit xs =

    let f :: Split -> IO ShowS
        f x = let ln s = s ++ "\n"
                  io s  = return (ln s ++)
              in case x of
                  Code s  -> io s
                  Delim s -> io s
                  Doc s   -> io s
                  Blank s -> io s
                  Ext s   -> io s
                  Shell y -> do { s <- y; io s }

        g :: IO ShowS -> IO ShowS -> IO ShowS
        g x y = do { s <- x; t <- y; return (s . t) }

    in do s <- foldr1 g $ map f xs
          return (s [])

joinDoc :: [Split] -> IO String
joinDoc text = (unsplit . preCode) text
    where

    startCode, endCode, blank :: Split
    startCode = Doc "\n<pre class=\"code\">"
    endCode   = Doc "</pre>\n"
    blank     = Doc ""

    preCode, preDoc, inCode, inDoc, skipCode, skipDoc :: [Split] -> [Split]
    
    preCode [] = [blank]
    preCode (x:xt) = case x of
        Code  _ -> startCode : x : inCode xt
        Delim _ -> preDoc xt
        Doc   _ -> x : inDoc xt
        Shell _ -> x : inDoc xt
        _       -> preCode xt

    preDoc [] = [blank]
    preDoc (x:xt) = case x of
        Code  _ -> startCode : x : inCode xt
        Delim _ -> preCode xt
        Doc   _ -> x : inDoc xt
        Shell _ -> x : inDoc xt
        _       -> preDoc xt

    inCode [] = [endCode]
    inCode (x:xt) = case x of
        Code  _ -> x : inCode xt
        Delim _ -> endCode : preDoc xt
        Doc   _ -> endCode : x : inDoc xt
        Shell _ -> endCode : x : inDoc xt
        Blank _ -> skipCode xt
        Ext   _ -> inCode xt

    inDoc [] = [blank]
    inDoc (x:xt) = case x of
        Code  _ -> startCode : x : inCode xt
        Delim _ -> preCode xt
        Doc   _ -> x : inDoc xt
        Shell _ -> x : inDoc xt
        Blank _ -> skipDoc xt
        Ext   _ -> inDoc xt

    skipCode [] = [endCode]
    skipCode (x:xt) = case x of
        Code  _ -> blank : x : inCode xt
        Delim _ -> endCode : preDoc xt
        Doc   _ -> endCode : x : inDoc xt
        Shell _ -> endCode : x : inDoc xt
        _       -> skipCode xt

    skipDoc [] = [blank]
    skipDoc (x:xt) = case x of
        Code  _ -> startCode : x : inCode xt
        Delim _ -> preCode xt
        Doc   _ -> blank : x : inDoc xt
        Shell _ -> blank : x : inDoc xt
        _       -> skipDoc xt

joinCode :: [Split] -> String
joinCode text = (unlines . inCode) text
    where
    
    inCode, inDoc :: [Split] -> [String]

    inCode [] = []
    inCode (x:xt) = case x of
        Code  s -> s : inCode xt
        Blank s -> s : inCode xt
        _       -> inDoc xt

    inDoc [] = []
    inDoc (x:xt) = case x of
        Code  s -> s : inCode xt
        Delim _ -> inCode xt
        _       -> inDoc xt

joinDebug :: [Split] -> String
joinDebug text = (unlines . tag) text
    where
    
    tag :: [Split] -> [String]
    tag [] = []
    tag (x:xt) = t : tag xt where
        t = case x of
            Code  s -> "C " ++ s
            Delim s -> "= " ++ s
            Doc   s -> "D " ++ s
            Blank s -> "B " ++ s
            Ext   s -> "E " ++ s
            Shell _ -> "S"