X-Git-Url: https://ruin.nu/git/?a=blobdiff_plain;f=Wiki.hs;h=2de6f920cde32ec3baeb96a9c8774c3299c35f92;hb=58e04761af30e092662dac331493200ccca48650;hp=c531f8ac271c90d9bad964bced24d963ffe7209d;hpb=a7ff060c616ef83fcd3fac49ba1ef874c44ab8b1;p=yawbih.git diff --git a/Wiki.hs b/Wiki.hs index c531f8a..2de6f92 100644 --- a/Wiki.hs +++ b/Wiki.hs @@ -1,10 +1,11 @@ module Wiki ( - Backend (getCurrent,getList,get,setCurrent,update) + Backend (getCurrent,getList,get,setCurrent,update,listKeys) ,PGB ,createPGB - ,Markup (Text, Paragraph, Link, Bold, Emph, Heading, Url, Underline, Strike) + ,Markup (Text, Paragraph, Link, Bold, Emph, Heading, Url, Underline, Strike, Pre,List) ,Document ,wikiParser + ,htmlOutput ) where @@ -28,6 +29,9 @@ class Backend a where --Keyword -> Full text -> id update :: a -> String -> String -> String -> String -> IO String + --[Keyword] + listKeys :: a -> IO [String] + data Markup = Text String | Paragraph | Link String String @@ -37,68 +41,37 @@ data Markup = Text String | Url String | Underline [Markup] | Strike [Markup] + | Pre String + | List [[Markup]] type Document = [Markup] -wikiParser :: GenParser Char st Document -wikiParser = do - s <- pMain - ss <- (wikiParser <|> return []) - return (s:ss) - -pPara = do - pEol - pEol - return (Paragraph) - +wikiParser :: Parser Document +wikiParser = many1 pMain -pSpace = do - space - return (Text " ") - -pEol = char '\n' <|> do - char '\r' - char '\n' - -pLinkParser = do try (string "]]" >> return ([],[])) - <|> try (do - string " | " - d <- pString "]]" - return ([],d)) - <|> (do - c <- anyChar - (l,d) <- pLinkParser - return (c:l,d)) +pPara :: Parser Markup +pPara = count 2 pEol >> return (Paragraph) +pLink :: Parser Markup pLink = do string "[[" - (l,d) <- pLinkParser + (l,d) <- pLinkContent case d of [] -> return (Link l l) _ -> return (Link l d) -pBold = pS "**" (\s -> Bold s) -pEmph = pS "//" (\s -> Emph s) -pUnderline = pS "__" (\s -> Underline s) -pStrike = pS "--" (\s -> Strike s) - -pS s f = do - string s - s <- pStopAt s - return (f s) +pList :: Parser Markup +pList = do + list <- many1 $ try pListItem + return (List list) -pStopAt xs = do - try (string xs >> return []) <|> (do - s <- pMain - ss <- pStopAt xs - return (s:ss)) - -pString xs = do - try (string xs >> return []) <|> (do - s <- anyChar - ss <- pString xs - return (s:ss)) +pListItem :: Parser [Markup] +pListItem = do + many1 pEol + char '*' + many pOneLine +pHeading :: Parser Markup pHeading = do many1 pEol level <- many1 $ char '=' @@ -106,41 +79,105 @@ pHeading = do s <- pStopAt (' ':level) return (Heading (length level) s) +pURL :: Parser Markup pURL = do proto <- many1 letter string "://" s <- many1 (alphaNum <|> oneOf "?.:&-/") return (Url (proto++"://"++s)) + +pMail :: Parser Markup +pMail = do + user <- many1 (alphaNum <|> oneOf ".-_") + char '@' + server <- many1 (alphaNum <|> oneOf ".-_") + return (Url ("mailto:"++user++"@"++server)) -pMain = try (pHeading) - <|> (try (pPara) - <|> pSpace - <|> try(pBold) - <|> try(pEmph) - <|> try(pUnderline) - <|> try(pStrike) - <|> try (pLink) - <|> try (pURL) - <|> pOtherChar - <|> pText) +pPre :: Parser Markup +pPre = string "
" >> do
+	s <- pString "
" + return (Pre s) + +pBold,pEmph,pUnderline,pStrike :: Parser Markup +pBold = pS "**" (\s -> Bold s) +pEmph = pS "//" (\s -> Emph s) +pUnderline = pS "__" (\s -> Underline s) +pStrike = pS "--" (\s -> Strike s) +pS s f = string s >> do + s <- pStopAt s + return (f s) + +pOtherChar :: Parser Markup pOtherChar = do - c <- oneOf "*,;.:!?[]()'\"=-%$£<>/\\|" + c <- noneOf "\n\r" return (Text (c:[])) +pText :: Parser Markup pText = do - t <- many1 alphaNum--(noneOf ['\n','\r','[',']']) + t <- many1 alphaNum return (Text t) +pLinkContent :: Parser (String, String) +pLinkContent = do try (string "]]" >> return ([],[])) + <|> try (do + string " | " + d <- pString "]]" + return ([],d)) + <|> (do + c <- anyChar + (l,d) <- pLinkContent + return (c:l,d)) + +pStopAt :: String -> Parser Document +pStopAt xs = pUntil pOneLine xs + +pString :: String -> Parser String +pString xs = pUntil anyChar xs + +pEol :: Parser Markup +pEol = do + (string "\n" <|> string "\r\n") + return (Text "\r\n") + +pUntil :: Parser a -> String -> Parser [a] +pUntil p xs = manyTill p (try $ string xs) + +pMain :: Parser Markup +pMain = choice [ + try (pHeading) + ,try pList + ,try (pPara) + ,try(pPre) + ,try(pBold) + ,try(pEmph) + ,try(pUnderline) + ,try(pStrike) + ,try (pLink) + ,try (pURL) + ,try (pMail) + ,pText + ,pOtherChar + ,pEol + ] + +pOneLine = choice [ + try pBold + ,try pEmph + ,try pUnderline + ,try pStrike + ,try pLink + ,try pURL + ,try pMail + ,pText + ,pOtherChar + ] newtype PGB = PGB DBService createPGB :: String -> String -> String -> String -> IO PGB createPGB host database user password = let db = createDBService host database "" user password Nothing in return (PGB db) - -testDB = createPGB "wave" "wiki" "wiki" "12wiki34db" - instance Backend PGB where getCurrent (PGB db) key = do @@ -183,9 +220,30 @@ instance Backend PGB where [[id]] <- selectReturnTuples db $ "SELECT currval('fulltexts_id_seq')" setCurrent (PGB db) key id return id - + + listKeys (PGB db) = do + list <- selectReturnTuples db $ "SELECT keyword FROM current keyword ORDER BY lower(keyword)" + case list of + [[]] -> return [] + _ -> mapM (\[key] -> return key) list tov :: String -> String tov s = '\'':escapeQuery s++"'" - +toHtml :: [Markup] -> String +toHtml [] = [] +toHtml ((Paragraph):xs) = "

\n"++toHtml xs +toHtml ((Text s):xs) = s++toHtml xs +toHtml ((Link l d):xs) = ""++toHtml xs +toHtml ((Bold d):xs) = ""++toHtml d++""++toHtml xs +toHtml ((Emph d):xs) = ""++toHtml d++""++toHtml xs +toHtml ((Underline d):xs) = ""++toHtml d++""++toHtml xs +toHtml ((Strike d):xs) = ""++toHtml d++""++toHtml xs +toHtml ((Heading n d):xs) = "\n"++toHtml d++"\n"++toHtml xs +toHtml ((Url l):xs) = ""++toHtml xs +toHtml ((Pre s):xs) = "

"++s++"
"++toHtml xs +toHtml ((List l):xs) = ""++toHtml xs + +htmlOutput s = case parse wikiParser "" s of + Right n -> putStr (toHtml n) + Left e -> print e