viewing paste script_commands.html | Haskell

Posted on the
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135
module Main where
 
{-
    Parses rAthenas script_commands.txt and builds a HTML page from it
    
    If you want to add types, you need to change
    - Content data type
    - addContent function
    - parseContent function
    - printContent function
    - Add a function which gives the layout
    
    If you want to change how anything is viewed, go to the bottom and
     change p<Type>
-}
 
import System.IO
import Data.List
import Data.Char
import Control.Monad    (when)
 
data Content = Title String Content
             | Text  String Content
             | Code  String Content
             | Desc  String Content
             | Def String String Content
             | EOC -- End of Content
  deriving (Eq, Show)
 
  
{- MAIN PART -}
 
-- Takes care of file handle, function that is run with .exe
main :: IO ()
main = do doc <- openFile "script_commands.txt" ReadMode
          web <- openFile "script_commands.html" WriteMode
          
          hSetEncoding doc utf8_bom
          hSetEncoding web utf8_bom
          contentStr <- hGetContents doc
          let content = lines $ safeHTML contentStr
          
          let (about, rest) = toNextTitle content
          printTitle web "rAthena Script Documentation"
          printContent web $ foldr addContent EOC $ map (\x->(Text x EOC)) about
          
          parse web rest
          putStrLn "Done parsing 'script_commands.txt'"
          hClose web
          hClose doc
          
-- Escapes HTML signs so they are visible as text
safeHTML :: String -> String
safeHTML []      = []
safeHTML ('&':s) = "&amp;" ++ safeHTML s
safeHTML ('<':s) = "&lt;"  ++ safeHTML s
safeHTML ('>':s) = "&gt;"  ++ safeHTML s
safeHTML ( c :s) = c        : safeHTML s
          
          
{- GOOD TO HAVE FUNCTIONS PART -}
 
-- Removes whitespace on both sides of string
clean :: String -> String
clean = reverse . clean' . reverse . clean'
  where clean' = dropWhile (\x -> x == ' ' || x == '\t')
  
-- Adds Content, in the order given
addContent :: Content -> Content -> Content
addContent EOC end = end
addContent (Title s content) end = Title s $ addContent content end
addContent (Text  s content) end = Text  s $ addContent content end
addContent (Code  s content) end = Code  s $ addContent content end
addContent (Desc  s content) end = Desc  s $ addContent content end
addContent (Def s1 s2 content) end = Def s1 s2 $ addContent content end
 
-- Gets all content to the next title
-- A title is the line above a line made of arbita '-------'
toNextTitle :: [String] -> ([String],[String])
toNextTitle c = (take (delimPos - 1) c, drop (delimPos - 1) c)
  where checkDelim r = [] /= (filter (/='-') . clean . sort) r || clean r == []
        delimPos = length $ takeWhile (checkDelim) c
 
 
{- PARSING PART -}
 
-- Function that reads content and parses what it gets
parse :: Handle -> [String] -> IO ()
parse web []         = return ()                                   -- Near EOF
parse web (s:[])     = printContent web $ parseContent [s]         -- Near EOF
parse web (s1:s2:[]) = printContent web $ parseContent $ s1:[s2]   -- Near EOF
parse web (s:d:c) = do when (or $ map isAlpha s) $ printTitle web s -- Print the title
                       let (content, rest) = toNextTitle c          -- Get the content
                       printContent web $ parseContent content      -- Parse and print the content
                       parse web rest   --^ Recursive call
 
-- Converts text to the different Content types
parseContent :: [String] -> Content
parseContent []    = EOC
parseContent t@(s:c)
  | clean s == []    = Text s EOC `addContent` parseContent c
  | take 2 s == "**" = Title (drop 2 s) EOC `addContent` parseContent c
  | head s == '*'    = Code (tail s) EOC `addContent` parseContent c
  | take 4 s == "    " = Desc (drop 4 s) EOC `addContent` parseContent c
  | otherwise        = Text s EOC `addContent` parseContent c
  
{- PRINTING PART -}
 
-- Print string to file
pF :: Handle -> String -> IO ()
pF = hPutStrLn
 
-- Handles the type of print and calls the right function
printContent :: Handle -> Content -> IO ()
printContent _ EOC = return ()
printContent web (Title s c)   = do pF web $ pTitle s;   printContent web c
printContent web (Text s c)    = do pF web $ pText s;    printContent web c
printContent web (Code s c)    = do pF web $ pCode s;    printContent web c
printContent web (Desc s c)    = do pF web $ pDesc s;    printContent web c
printContent web (Def s1 s2 c) = do pF web $ pDef s1 s2; printContent web c
 
-- Print with 1 parameter
pTitle, pText, pCode, pDesc :: String -> String
pTitle s = "<b>" ++ s ++ "</b><br />"
pText  s = s ++ "<br />"
pCode  s = "<font color=\"#FF0000\">" ++ s ++ "</font><br />"
pDesc  s = "<font color=\"#CCCCCC\">" ++ s ++ "</font><br />"
 
-- Print with 2 parameters
pDef :: String -> String -> String
pDef s1 s2 = s1 ++ " -|- " ++ s2 ++ "<br />"
 
-- Prints title
printTitle :: Handle -> String -> IO ()
printTitle web title = pF web $ "<h1>" ++ title ++ "</h1>"
Viewed 945 times, submitted by Guest.