mirror of
https://github.com/The1Penguin/org-to-mafiauniverse.git
synced 2024-11-21 17:58:12 +00:00
122 lines
4.1 KiB
Haskell
122 lines
4.1 KiB
Haskell
module Main where
|
|
|
|
import Control.Applicative hiding (some)
|
|
import Control.Monad
|
|
import Data.Functor
|
|
import Data.Void
|
|
import System.Environment
|
|
import System.Exit
|
|
import Text.Megaparsec
|
|
import Text.Megaparsec.Char
|
|
|
|
type Parser = Parsec Void String
|
|
|
|
data URL = Img String | Vid String | Website String
|
|
deriving (Show)
|
|
|
|
data Info =
|
|
Bread String |
|
|
List [Info] |
|
|
Header String |
|
|
Subheader String |
|
|
Subsubheader String |
|
|
Image URL |
|
|
Video URL |
|
|
Link URL Info |
|
|
Spoiler [Info]
|
|
|
|
instance Show Info where
|
|
show :: Info -> String
|
|
show info = case info of
|
|
Bread text -> text ++ "\n"
|
|
List texts -> "[LIST]" ++ concatMap ((++) "[*] " . show) texts ++ "[/LIST]\n"
|
|
Header text -> "[TITLE]" ++ text ++ "[/TITLE]\n"
|
|
Subheader text -> "[SIZE=4]" ++ text ++ "[/SIZE]\n"
|
|
Subsubheader text -> "[SIZE=2]" ++ text ++ "[/SIZE]\n"
|
|
Image (Img url) -> "[IMG]" ++ url ++ "[/IMG]\n"
|
|
Video (Vid url) -> "[VIDEO]" ++ url ++ "[/VIDEO]\n"
|
|
Link (Website url) inf -> "[URL=\"" ++ url ++ "\"]" ++ show inf ++ "[/URL]\n"
|
|
Spoiler inf -> "[SPOILER]" ++ concatMap show inf ++ "[/SPOILER]\n"
|
|
_ -> error "Something went wrong with showing the parsed information"
|
|
|
|
newtype Post = Post [Info]
|
|
|
|
instance Show Post where
|
|
show :: Post -> String
|
|
show (Post a) = concatMap show a
|
|
|
|
reduce :: [Info] -> [Info]
|
|
reduce [] = []
|
|
reduce ((List x) : (List y) : xs) = reduce $ List (x++y) : xs
|
|
reduce ((Spoiler x) : (Spoiler y) : xs) = Spoiler (x++y) : reduce xs
|
|
reduce ((Spoiler x) : y : xs) = reduce $ Spoiler (reduce $ x ++ [y]) : xs
|
|
reduce (x:xs) = x: reduce xs
|
|
|
|
parseHelper :: Parser a -> String -> a
|
|
parseHelper parser x = case parse parser "" x of
|
|
Left bundle -> error $ errorBundlePretty bundle
|
|
Right text -> text
|
|
|
|
parseFile :: String -> Post
|
|
parseFile = Post . reduce . map (parseHelper fileParser) . dropWhile (/= "") . lines
|
|
|
|
fileParser :: Parser Info
|
|
fileParser =
|
|
try $
|
|
choice [
|
|
Header <$> (string' "* " >> takeRest),
|
|
Subheader <$> (string' "** " >> takeRest),
|
|
Subsubheader <$> (string' "*** " >> takeRest),
|
|
List . (: []) . Bread <$> (string' "- " >> takeRest),
|
|
-- Image and video needs to know if it is a image or video
|
|
Image <$> between (string' "[[") (string' "]]") parseLink,
|
|
Video <$> between (string' "[[") (string' "]]") parseLink,
|
|
-- (takeWhileP Nothing (/= ']')),
|
|
Spoiler . (: []) . Bread <$> (string' "#+BEGIN" >> return ""),
|
|
Spoiler . (: []) . Bread <$> (string' "#+END" >> return ""),
|
|
Bread <$> takeRest
|
|
]
|
|
|
|
parseLink :: Parser URL
|
|
parseLink = try $ choice [
|
|
do
|
|
scheme <- string' "https://"
|
|
auth <- takeWhileP Nothing (/= '/')
|
|
path <- takeWhileP Nothing (/= '.')
|
|
typ <- try $ string' ".jpg" <|> string ".jpeg" <|> string' ".png" <|> string ".gif"
|
|
return $ Img $ scheme ++ auth ++ path ++ typ,
|
|
do
|
|
scheme <- string' "https://"
|
|
auth <- try $ string' "youtu.be" <|> string' "youtube.com"
|
|
path <- takeRest
|
|
return $ Vid $ scheme ++ auth ++ path,
|
|
Website <$> takeRest
|
|
]
|
|
|
|
parseCli :: [String] -> IO Post
|
|
parseCli [] = return $ Post [usage]
|
|
parseCli [x] =
|
|
if head x /= '-'
|
|
then parseFile <$> readFile x
|
|
else return $ useArgs $ parseHelper argParse x
|
|
parseCli [x, _] = return $ useArgs $ parseHelper argParse x
|
|
parseCli _ = fail "Too many arugemnts"
|
|
|
|
argParse :: Parser String
|
|
argParse = string "-" >> some alphaNumChar
|
|
|
|
useArgs :: String -> Post
|
|
useArgs [] = Post [Bread ""]
|
|
useArgs ('h' : _) = Post [usage]
|
|
useArgs ('v' : _) = Post [version]
|
|
useArgs (_ : xs) = useArgs xs
|
|
|
|
usage :: Info
|
|
usage = Bread "Usage: otm [-hv] [file]"
|
|
|
|
version :: Info
|
|
version = Bread "otm 0.1"
|
|
|
|
main :: IO ()
|
|
main = putStr . show =<< parseCli =<< getArgs
|