for Assignment.hs:

{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
{-# LANGUAGE LambdaCase #-}

module task (markdownParser, convertADTHTML, getTime) where
import Debug.Trace (trace)
import Data.Time.Clock (getCurrentTime)
import Data.Time.Format (defaultTimeLocale, formatTime)
import Instances (ParseError(..), ParseResult(..), Parser(..), parse)

import Parser hiding (unexpectedCharParser)

import Control.Monad (guard)
import Control.Applicative (Alternative(..), optional,many)
import Data.Char (isDigit, isSpace)
import Data.Maybe (fromMaybe)
import Data.Functor (void)

-- Define the ADT
data ADT = Document [Block]
  deriving (Show, Eq)

try :: Parser a -> Parser a
try (Parser p) = Parser $ \input ->
  case p input of
    Error e -> Error e
    Result newInput a -> Result newInput a

choice :: [Parser a] -> Parser a
choice = foldr (<|>) empty

endOfLineOrEOF :: Parser ()
endOfLineOrEOF = void eol <|> eof

lookAhead :: Parser a -> Parser a
lookAhead (Parser p) = Parser $ \input ->
    case p input of
        Error e    -> Error e
        Result _ x -> Result input x

many1 :: Alternative f => f a -> f [a]
many1 p = (:) <$> p <*> many p

sepBy :: Parser a -> Parser sep -> Parser [a]
sepBy p sep = sepBy1 p sep <|> pure []

data Block
    = Paragraph [Inline]
    | Heading Int [Inline]
    | BlockQuote [Block]
    | CodeBlock (Maybe String) String
    | OrderedList [ListItem]
    | FootnoteReference Int String
    | Table TableRow [TableRow]
    deriving (Show, Eq)

data ListItem = ListItem [Block]
    deriving (Show, Eq)

data TableRow = TableRow [[Inline]]
    deriving (Show, Eq)

data Inline
    = Plain String
    | Italic [Inline]
    | Bold [Inline]
    | Strikethrough [Inline]
    | Link [Inline] String
    | Image String String (Maybe String)
    | InlineCode String
    | Footnote Int
    deriving (Show, Eq)

-- Utility functions
space1 :: Parser String
space1 = some (satisfy (\c -> isSpace c && c /= '\n' && c /= '\r'))

-- | Parses an end-of-line sequence.
-- Handles Unix (\n), Windows (\r\n), and old Mac (\r) line endings.
eol :: Parser ()
eol = 
      (void (string "\r\n"))    -- Windows-style EOL
  <|> (void (is '\n'))         -- Unix-style EOL
  <|> (void (is '\r'))         -- Old Mac-style EOL

anyChar :: Parser Char
anyChar = satisfy (const True)

anyCharButNewline :: Parser Char
anyCharButNewline = satisfy (\c -> c /= '\n' && c /= '\r')

skipMany :: Parser a -> Parser ()
skipMany p = void (many p)

manyTill :: Parser a -> Parser end -> Parser [a]
manyTill p end = scan
  where
    scan = (end *> pure []) <|> (p >>= \x -> (x:) <$> scan)

sepBy1 :: Parser a -> Parser sep -> Parser [a]
sepBy1 p sep = (:) <$> p <*> many (sep *> p)

-- Part A: Parsing Markdown

markdownParser :: Parser ADT
markdownParser = do
  blocks <- sepEndBy1 blockParser (some eol)
  eof
  return $ Document blocks

blockParser :: Parser Block
blockParser = choice
  [ try headingParser
  , try codeBlockParser
  , try blockQuoteParser
  , try orderedListParser
  , try footnoteReferenceParser
  , try tableParser
  , try imageBlockParser
  , paragraphParser
  ]

-- Adjusted headingParser to handle setext-style headings
headingParser :: Parser Block
headingParser = try atxHeadingParser <|> try setextHeadingParser

headingStartParser :: Parser ()
headingStartParser = lookAhead $ do
    optional inlineSpace
    (do
        hashes <- some (is '#')
        guard (length hashes <= 6)
        space1
        return ())
    <|>
    (do
        content <- inlineContentLine
        eol
        skipMany (satisfy isSpace)
        c <- satisfy (\c -> c == '=' || c == '-')
        cs <- many (satisfy (\x -> x == c))
        skipMany (satisfy isSpace)
        endOfLineOrEOF
        guard (length (c:cs) >= 2)
        return ())

atxHeadingParser :: Parser Block
atxHeadingParser = do
    optional inlineSpace
    hashes <- some (is '#')  -- Capture the number of `#`
    guard (length hashes <= 6)  -- Ensure valid heading level
    space1  -- Require at least one space
    content <- manyTill inlineElement (lookAhead eol <|> try eof)  -- Parse heading content up to end of line or EOF
    return $ Heading (length hashes) content



setextHeadingParser :: Parser Block
setextHeadingParser = do
    content <- some inlineElement  -- Ensure non-empty content
    eol  -- Expect a newline
    skipMany (satisfy isSpace)  -- Skip spaces
    c <- satisfy (\c -> c == '=' || c == '-')  -- Check for '=' or '-'
    rest <- many (satisfy (\x -> x == c || isSpace x))  -- Capture the rest of the line
    guard (all (\x -> x == c || isSpace x) (c:rest))  -- Ensure separator line has only c and spaces
    endOfLineOrEOF  -- Ensure the block ends correctly
    let level = if c == '=' then 1 else 2  -- Determine heading level
    return $ Heading level content


blockQuoteParser :: Parser Block
blockQuoteParser = do
    blocks <- some blockQuoteBlock
    return $ BlockQuote blocks

blockQuoteBlock :: Parser Block
blockQuoteBlock = do
    optional (satisfy isSpace)
    is '>'
    optional (is ' ')
    content <- manyTill anyChar (lookAhead eol <|> eof)
    _ <- optional eol
    parsedContent <- parseInlineContent content
    return $ Paragraph parsedContent

codeBlockParser :: Parser Block
codeBlockParser = do
    optional inlineSpace
    string "```"
    lang <- optional (some (satisfy (/= '\n')))
    eol
    code <- manyTill anyChar (try $ optional inlineSpace *> string "```" *> endOfLineOrEOF)
    return $ CodeBlock lang code

orderedListParser :: Parser Block
orderedListParser = do
    items <- some orderedListItemParser
    return $ OrderedList items

orderedListItemParser :: Parser ListItem
orderedListItemParser = do
    optional inlineSpace
    numStr <- some digit
    is '.'
    space1
    content <- manyTill anyCharButNewline (lookAhead eol <|> eof)
    _ <- optional eol
    subItems <- optional (try orderedListParser)
    parsedContent <- parseBlocks content
    let subBlocks = fromMaybe [] (subItems >>= \case (OrderedList items) -> Just (concatMap (\(ListItem bs) -> bs) items); _ -> Nothing)
    return $ ListItem (parsedContent ++ subBlocks)

footnoteReferenceParser :: Parser Block
footnoteReferenceParser = do
    optional inlineSpace
    is '['
    is '^'
    numStr <- some digit
    is ']'
    is ':'
    skipMany (satisfy isSpace)  -- Ignore spaces after colon
    content <- manyTill anyChar (lookAhead eol <|> eof)  -- Capture the content
    let num = read numStr
    return $ FootnoteReference num (trim content)

trim :: String -> String
trim = f . f
  where f = reverse . dropWhile isSpace

paragraphParser :: Parser Block
paragraphParser = do
  notFollowedBy footnoteRefStartParser
  notFollowedBy tableStartParser -- Prevent parsing tables as paragraphs
  notFollowedBy headingStartParser -- Prevent headings being parsed as paragraphs
  contentLine <- inlineContentLine
  return $ Paragraph contentLine

sepByAtLeast2 :: Parser a -> Parser sep -> Parser [a]
sepByAtLeast2 p sep = do
    a <- p
    sep
    b <- p
    rest <- many (sep *> p)
    return (a : b : rest)

tableStartParser :: Parser ()
tableStartParser = lookAhead $ do
    skipMany (satisfy isSpace)
    optional (is '|')
    cells <- sepByAtLeast2 (many (satisfy (\c -> c /= '|' && c /= '\n'))) (is '|')
    optional (is '|')
    eol
    skipMany (satisfy isSpace)
    optional (is '|')
    optional inlineSpace
    c <- satisfy (\c -> c == '-' || c == ':')
    cs <- many (satisfy (\c -> c == '-' || c == ':' || isSpace c))
    optional (is '|')
    return ()



tableParser :: Parser Block
tableParser = try $ do
    skipMany (satisfy isSpace)
    header <- tableRowParser
    separator
    rows <- many tableRowParser
    return $ Table header rows

separator :: Parser ()
separator = do
    skipMany (satisfy isSpace)
    optional (is '|')
    sepBy1 separatorCell (optional inlineSpace *> is '|' *> optional inlineSpace)
    optional (is '|')
    eol
    return ()

separatorCell :: Parser ()
separatorCell = do
    optional inlineSpace
    many1 (is '-')
    optional inlineSpace
    return ()


sepEndBy1 :: Parser a -> Parser sep -> Parser [a]
sepEndBy1 p sep = do
    first <- p
    rest <- many (sep *> p)
    optional sep
    return (first : rest)

tableRowParser :: Parser TableRow
tableRowParser = do
    skipMany (satisfy isSpace)
    optional (is '|')
    -- Use sepEndBy1 to handle trailing '|'
    cells <- sepEndBy1 cellParser (optional inlineSpace *> is '|' *> optional inlineSpace)
    optional (is '|') -- Optional trailing '|', do not treat as another cell
    eol
    return $ TableRow cells


cellParser :: Parser [Inline]
cellParser = do
    optional inlineSpace
    content <- many (satisfy (\c -> c /= '|' && c /= '\n'))
    optional inlineSpace
    let trimmedContent = trim content
    guard (not (null trimmedContent))
    case parse (inlineContent <* eof) trimmedContent of
        Result _ inlines -> return inlines
        _ -> return [Plain trimmedContent]

-- Inline parsing
inlineContent :: Parser [Inline]
inlineContent = many inlineElement

inlineContentLine :: Parser [Inline]
inlineContentLine = some inlineElement <* (lookAhead (eol <|> eof))  -- Changed from 'manyTill' to 'some'


inlineElement :: Parser Inline
inlineElement = choice
    [ try boldParser
    , try italicParser
    , try strikethroughParser
    , try imageParser
    , try linkParser
    , try inlineCodeParser
    , footnoteParser  -- Moved footnoteParser before plainParser
    , plainParser
    ]

plainParser :: Parser Inline
plainParser = do
    c <- satisfy (\c -> c `notElem` "_*~`[!]^\n\r")
    rest <- many (satisfy (\c -> c `notElem` "_*~`[!]^\n\r"))
    return $ Plain (c:rest)

italicParser :: Parser Inline
italicParser = do
    is '_'
    content <- inlineContentTill (is '_')
    return $ Italic content

boldParser :: Parser Inline
boldParser = do
    string "**"
    content <- inlineContentTill (string "**")
    return $ Bold content

strikethroughParser :: Parser Inline
strikethroughParser = do
    string "~~"
    content <- inlineContentTill (string "~~")
    return $ Strikethrough content

inlineCodeParser :: Parser Inline
inlineCodeParser = do
    is '`'
    content <- many (satisfy (/= '`'))
    is '`'
    return $ InlineCode content

footnoteParser :: Parser Inline
footnoteParser = do
    is '['
    is '^'
    numStr <- some digit
    is ']'
    let num = read numStr
    return $ Footnote num

linkParser :: Parser Inline
linkParser = do
    is '['
    linkText <- inlineContentTill (is ']')
    is ']'
    is '('
    url <- some (satisfy (\c -> not (isSpace c) && c /= ')'))
    _ <- optional (is ' ' *> is '"' *> many (satisfy (/= '"')) <* is '"')
    is ')'
    return $ Link linkText url

spaceNotNewline1 :: Parser ()
spaceNotNewline1 = do
    satisfy (\c -> isSpace c && c /= '\n' && c /= '\r')
    skipMany (satisfy (\c -> isSpace c && c /= '\n' && c /= '\r'))
    return ()

imageParser :: Parser Inline
imageParser = do
    is '!'
    is '['
    altText <- many (satisfy (/= ']'))
    is ']'
    is '('
    url <- some (satisfy (\c -> not (isSpace c) && c /= ')'))
    spaceNotNewline1
    is '"'
    caption <- many (satisfy (/= '"'))
    is '"'
    is ')'
    return $ Image altText url (Just caption)

inlineContentTill :: Parser a -> Parser [Inline]
inlineContentTill end = manyTill inlineElement (try end)

parseInlineContent :: String -> Parser [Inline]
parseInlineContent s = case parse (inlineContent <* eof) s of
    Result _ inlines -> return inlines
    _ -> empty


parseBlocks :: String -> Parser [Block]
parseBlocks s = case parse markdownParser s of
    Result _ (Document blocks) -> return blocks
    _ -> return []

-- Convert Inline to Text
inlineToText :: Inline -> String
inlineToText (Plain text) = text
inlineToText (Italic inlines) = concatMap inlineToText inlines
inlineToText (Bold inlines) = concatMap inlineToText inlines
inlineToText (Strikethrough inlines) = concatMap inlineToText inlines
inlineToText (Link inlines _) = concatMap inlineToText inlines
inlineToText (InlineCode text) = text
inlineToText (Footnote n) = show n
inlineToText _ = ""

-- Part B: Conversion between Markdown and HTML
getTime :: IO String
getTime = formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S" <$> getCurrentTime

convertADTHTML :: ADT -> String
convertADTHTML (Document blocks) =
  "<!DOCTYPE html>\n" ++
  "<html lang=\"en\">\n\n" ++
  "<head>\n" ++
  "    <meta charset=\"UTF-8\">\n" ++
  "    <title>Converted HTML</title>\n" ++
  "</head>\n\n" ++
  "<body>\n" ++
  concatMap convertBlockHTML blocks ++
  "</body>\n\n" ++
  "</html>"

convertBlockHTML :: Block -> String
convertBlockHTML (Heading level inlines) =
  "    <h" ++ show level ++ ">" ++ concatMap convertInlineHTML inlines ++ "</h" ++ show level ++ ">\n"
convertBlockHTML (BlockQuote blocks) =
  "    <blockquote>\n" ++ concatMap convertBlockHTMLIndented blocks ++ "    </blockquote>\n"
convertBlockHTML (CodeBlock mLang code) =
  let classAttr = maybe "" (\lang -> " class=\"language-" ++ lang ++ "\"") mLang
      escapedCode = escapeHTMLCode code
  in "    <pre><code" ++ classAttr ++ ">" ++ escapedCode ++ "</code></pre>\n"
convertBlockHTML (FootnoteReference n text) =
  "    <p id=\"fn" ++ show n ++ "\">" ++ escapeHTML text ++ "</p>\n"
convertBlockHTML (OrderedList items) =
  "    <ol>\n" ++ concatMap convertListItemHTML items ++ "    </ol>\n"
convertBlockHTML (Table header rows) =
    let numColumns = length (tableRowCells header)
    in "    <table>\n" ++
       "        <thead>\n            <tr>\n" ++
       concatMap (\cell -> "                <th>" ++ concatMap convertInlineHTML cell ++ "</th>\n") (tableRowCells header) ++
       "            </tr>\n        </thead>\n" ++
       "        <tbody>\n" ++ concatMap (convertTableRowHTML numColumns) rows ++
       "        </tbody>\n    </table>\n"
convertBlockHTML (Paragraph [Image alt src mTitle]) =
  "    <img src=\"" ++ escapeURL src ++ "\" alt=\"" ++ escapeHTML alt ++ "\"" ++
  maybe "" (\title -> " title=\"" ++ escapeHTML title ++ "\"") mTitle ++ ">\n"
convertBlockHTML (Paragraph inlines) =
  "    <p>" ++ concatMap convertInlineHTML inlines ++ "</p>\n"


convertBlockHTMLIndented :: Block -> String
convertBlockHTMLIndented block = indent (convertBlockHTML block)

convertTableRowHTML :: Int -> TableRow -> String
convertTableRowHTML numColumns (TableRow cells) =
    let cellsToRender = take numColumns cells
    in "            <tr>\n" ++
       concatMap (\cell -> "                <td>" ++ concatMap convertInlineHTML cell ++ "</td>\n") cellsToRender ++
       "            </tr>\n"


tableRowCells :: TableRow -> [[Inline]]
tableRowCells (TableRow cells) = cells

convertListItemHTML :: ListItem -> String
convertListItemHTML (ListItem blocks) =
  "        <li>\n" ++ concatMap convertBlockHTMLIndented blocks ++ "        </li>\n"

convertInlineHTML :: Inline -> String
convertInlineHTML (Plain text) = escapeHTML text
convertInlineHTML (Italic inlines) = "<em>" ++ concatMap convertInlineHTML inlines ++ "</em>"
convertInlineHTML (Bold inlines) = "<strong>" ++ concatMap convertInlineHTML inlines ++ "</strong>"
convertInlineHTML (Strikethrough inlines) = "<del>" ++ concatMap convertInlineHTML inlines ++ "</del>"
convertInlineHTML (Link inlines url) = "<a href=\"" ++ escapeURL url ++ "\">" ++ concatMap convertInlineHTML inlines ++ "</a>"
convertInlineHTML (Image alt src mTitle) =
  "<img src=\"" ++ escapeURL src ++ "\" alt=\"" ++ escapeHTML alt ++ "\"" ++
  maybe "" (\title -> " title=\"" ++ escapeHTML title ++ "\"") mTitle ++ ">"
convertInlineHTML (InlineCode text) = "<code>" ++ escapeHTML text ++ "</code>"
convertInlineHTML (Footnote n) = "<sup><a id=\"fn" ++ show n ++ "ref\" href=\"#fn" ++ show n ++ "\">" ++ show n ++ "</a></sup>"

escapeHTML :: String -> String
escapeHTML = concatMap (\c -> case c of
    '&' -> "&amp;"
    '<' -> "&lt;"
    '>' -> "&gt;"
    '"' -> "&quot;"
    '\''-> "&#39;"
    _   -> [c])

escapeHTMLCode :: String -> String
escapeHTMLCode = concatMap (\c -> case c of
    '&' -> "&amp;"
    '<' -> "&lt;"
    '>' -> "&gt;"
    _   -> [c])

escapeURL :: String -> String
escapeURL = escapeHTML -- simplistic, should encode special URL characters

indent :: String -> String
indent = unlines . map ("        " ++) . lines

-- Added notFollowedBy function
-- Correct implementation of notFollowedBy
notFollowedBy :: Parser a -> Parser ()
notFollowedBy p = lookAhead (try p *> empty <|> pure ())

-- Defined footnoteRefStartParser
footnoteRefStartParser :: Parser ()
footnoteRefStartParser = do
    optional inlineSpace
    is '['
    is '^'
    some digit
    is ']'
    is ':'
    return ()

-- Added Image Block Parser
imageBlockParser :: Parser Block
imageBlockParser = do
    optional inlineSpace
    img <- imageParser
    optional inlineSpace
    eol <|> eof
    return $ Paragraph [img]

with Parser:

{-# OPTIONS_GHC -Wno-missing-export-lists #-}
-- | Implementation of a parser-combinator.
module Parser where

import           Control.Applicative
import           Data.Char           (isAlpha, isDigit, isLower, isSpace,
                                      isUpper)
import           Instances           (ParseError (..), ParseResult (..),
                                      Parser (..), readInt)

-- $setup
-- >>> import Instances (isErrorResult, parse)


-- | -------------------------------------------------
-- | --------------- Core parsers --------------------
-- | -------------------------------------------------

-- | Return a parser that always fails with the given error.
--
-- >>> isErrorResult (parse (failed UnexpectedEof) "abc")
-- True
failed :: ParseError -> Parser a
failed = Parser . const . Error

-- | Produces a parser that always fails with 'UnexpectedChar' using the given
-- character.
unexpectedCharParser :: Char -> Parser a
unexpectedCharParser = Parser . const . Error . UnexpectedChar

-- | Return a parser that succeeds with a character off the input or fails with
-- an error if the input is empty.
--
-- >>> parse char "abc"
-- Result >bc< 'a'
--
-- >>> isErrorResult (parse char "")
-- True
char :: Parser Char
char = Parser f
  where
    f ""       = Error UnexpectedEof
    f (x : xs) = Result xs x

-- | Parse numbers as int until non-digit

---- >>> parse int "abc"
-- Result >bc< 'a'
--
-- >>> isErrorResult (parse int "")
-- True
--
-- >>> isErrorResult (parse int "a")
-- True
int :: Parser Int
int = Parser f
  where
    -- This is okay because the case statement is small
    f "" = Error UnexpectedEof
    f x = case readInt x of
      Just (v, rest) -> Result rest v
      Nothing        -> Error $ UnexpectedChar (head x)

-- | Write a parser that asserts that there is no remaining input.
--
-- >>> parse eof ""
-- Result >< ()
--
-- >>> isErrorResult (parse eof "abc")
-- True
eof :: Parser ()
eof = Parser f
  where
    f "" = Result "" ()
    f x  = Error $ ExpectedEof x

-- | -------------------------------------------------
-- | --------------- Satisfy parsers -----------------
-- | -------------------------------------------------
-- | All of these parsers use the `satisfy` parser!
-- | Return a parser that produces a character but fails if:
--
--   * the input is empty; or
--
--   * the character does not satisfy the given predicate.
--
-- >>> parse (satisfy isUpper) "Abc"
-- Result >bc< 'A'
--
-- >>> isErrorResult (parse (satisfy isUpper) "abc")
-- True
satisfy :: (Char -> Bool) -> Parser Char
satisfy f = char >>= f'
  where
    -- This is okay because guards are small
    f' c
      | f c = pure c
      | otherwise = unexpectedCharParser c

-- | Return a parser that produces the given character but fails if:
--
--   * the input is empty; or
--
--   * the produced character is not equal to the given character.
--
-- >>> parse (is 'c') "c"
-- Result >< 'c'
--
-- >>> isErrorResult (parse (is 'c') "")
-- True
--
-- >>> isErrorResult (parse (is 'c') "b")
-- True
is :: Char -> Parser Char
is = satisfy . (==)

-- | Return a parser that produces any character but fails if:
--
--   * the input is empty; or
--
--   * the produced character is equal to the given character.
--
-- >>> parse (isNot 'c') "b"
-- Result >< 'b'
--
-- >>> isErrorResult (parse (isNot 'c') "")
-- True
--
-- >>> isErrorResult (parse (isNot 'c') "c")
-- True
isNot :: Char -> Parser Char
isNot = satisfy . (/=)

-- | Write a function that parses one of the characters in the given string.
--
-- /Hint/: What does `elem` do? What are its parameters?
--
-- >>> parse (oneof "abc") "bcdef"
-- Result >cdef< 'b'
--
-- >>> isErrorResult (parse (oneof "abc") "def")
-- True
oneof :: String -> Parser Char
oneof = satisfy . flip elem

-- | Write a function that parses any character, but fails if it is in the
-- given string.
--
-- /Hint/: What does `notElem` do? What are its parameters?
--
-- >>> parse (noneof "bcd") "abc"
-- Result >bc< 'a'
--
-- >>> isErrorResult (parse (noneof "abcd") "abc")
-- True
noneof :: String -> Parser Char
noneof = satisfy . flip notElem

-- | Return a parser that produces a character between '0' and '9' but fails if
--
--   * the input is empty; or
--
--   * the produced character is not a digit.
--
-- /Hint/: Use the 'isDigit' function
digit :: Parser Char
digit = satisfy isDigit

-- | Return a parser that produces a space character but fails if
--
--   * the input is empty; or
--
--   * the produced character is not a space.
--
-- /Hint/: Use the 'isSpace' function
space :: Parser Char
space = satisfy isSpace

-- | Return a parser that produces a lower-case character but fails if:
--
--   * the input is empty; or
--
--   * the produced character is not lower-case.
--
-- /Hint/: Use the 'isLower' function
lower :: Parser Char
lower = satisfy isLower

-- | Return a parser that produces an upper-case character but fails if:
--
--   * the input is empty; or
--
--   * the produced character is not upper-case.
--
-- /Hint/: Use the 'isUpper' function
upper :: Parser Char
upper = satisfy isUpper

-- | Return a parser that produces an alpha character but fails if:
--
--   * the input is empty; or
--
--   * the produced character is not alpha.
--
-- /Hint/: Use the 'isAlpha' function
alpha :: Parser Char
alpha = satisfy isAlpha

-- | Write a parser that will parse zero or more spaces (including newlines)
--
-- /Hint/: Remember the `space` parser!
--
-- >>> parse spaces " abc"
-- Result >abc< " "
--
-- >>> parse spaces "abc"
-- Result >abc< ""
spaces :: Parser String
spaces = many space

-- | Return a parser that produces one or more space characters (consuming
-- until the first non-space) but fails if:
--
--   * the input is empty; or
--
--   * the first produced character is not a space.
--
-- /Hint/: Remember the `space` parser!
--
-- >>> parse spaces1 " abc"
-- Result >abc< " "
--
-- >>> isErrorResult $ parse spaces1 "abc"
-- True
spaces1 :: Parser String
spaces1 = some space


-- | Write a parser that will parse zero or more spaces (not including newlines)
--
-- The possible whitespace characters: \t, \r, \f, \v, and a space character.
--
-- >>> parse inlineSpace " abc"
-- Result >abc< " "
--
-- >>> parse inlineSpace "abc"
-- Result >abc< ""
inlineSpace :: Parser String
inlineSpace = many (oneof "\t\r\f\v ")

-- | Write a function that parses the given string (fails otherwise).
--
-- /Hint/: Use 'is' and 'traverse'.
--
-- >>> parse (string "abc") "abcdef"
-- Result >def< "abc"
--
-- >>> isErrorResult (parse (string "abc") "bcdef")
-- True
string :: String -> Parser String
string = traverse is

-- | -------------------------------------------------
-- | --------------- Token parsers -------------------
-- | -------------------------------------------------

-- | Write a function that applies the given parser, then parses 0 or more
-- spaces, then produces the result of the original parser.
--
-- /Hint/: You can use the Monad instance or Applicatives
--
-- >>> parse (tok (is 'a')) "a bc"
-- Result >bc< 'a'
--
-- >>> parse (tok (is 'a')) "abc"
-- Result >bc< 'a'
tok :: Parser a -> Parser a
tok = (<* spaces)

-- tok p = do
--   r <- p
--   spaces
--   pure r

-- | Write a function that parses the given char followed by 0 or more spaces.
--
-- /Hint/: Remember the `is` parser
--
-- >>> parse (charTok 'a') "abc"
-- Result >bc< 'a'
--
-- >>> isErrorResult (parse (charTok 'a') "dabc")
-- True
charTok :: Char -> Parser Char
charTok = tok . is

-- | Write a parser that parses a comma ',' followed by 0 or more spaces.
--
-- /Hint/: We just implemented `charTok`
--
-- >>> parse commaTok ",123"
-- Result >123< ','
--
-- >>> isErrorResult( parse commaTok "1,23")
-- True
commaTok :: Parser Char
commaTok = charTok ','

-- | Write a function that parses the given string, followed by 0 or more
-- spaces.
--
-- /Hint/: Remember the `string` parser
--
-- >>> parse (stringTok "abc") "abc  "
-- Result >< "abc"
--
-- >>> isErrorResult (parse (stringTok "abc") "bc  ")
-- True
stringTok :: String -> Parser String
stringTok = tok . string

with main.js:

import { fromEvent, merge } from "rxjs";
import { map, mergeScan, first } from "rxjs/operators";
import { ajax } from "rxjs/ajax";
import { type Observable } from "rxjs";
import { State } from "./types";

import hljs from "highlight.js/lib/core";
import javascript from "highlight.js/lib/languages/javascript";
import python from "highlight.js/lib/languages/python";
import haskell from "highlight.js/lib/languages/haskell";

// Register the languages with highlight.js
hljs.registerLanguage("javascript", javascript);
hljs.registerLanguage("python", python);
hljs.registerLanguage("haskell", haskell);

const markdownInput = document.getElementById(
    "markdown-input"
) as HTMLTextAreaElement;
const checkbox = document.querySelector('input[name="checkbox"]')!;
const saveButton = document.createElement("button");
saveButton.textContent = "Save HTML";

// Insert the button into the HTML document
const outputSection = document.getElementById("output-section");
if (outputSection) {
    outputSection.appendChild(saveButton);
}

const titleInput = document.createElement("input");
titleInput.placeholder = "Enter title...";
titleInput.style.display = "block";

// Insert title input field into the output section
if (outputSection) {
    outputSection.insertBefore(titleInput, outputSection.firstChild);
}

// Type to represent actions on the state
type Action = (s: State) => State;

// Reset state helper function
const resetState: Action = (s) => ({ ...s, save: false });

// Observable for input events on the markdown text area
const input$: Observable<Action> = fromEvent<KeyboardEvent>(
    markdownInput,
    "input"
).pipe(
    map((event) => (event.target as HTMLInputElement).value),
    map((value) => (s) => ({ ...s, markdown: value }))
);

// Observable for checkbox changes
const checkboxStream$: Observable<Action> = fromEvent(checkbox, "change").pipe(
    map((event) => (event.target as HTMLInputElement).checked),
    map((value) => (s) => ({ ...s, renderHTML: value }))
);

// Observable for title input changes
const titleInput$: Observable<Action> = fromEvent<KeyboardEvent>(
    titleInput,
    "input"
).pipe(
    map((event) => (event.target as HTMLInputElement).value),
    map((title) => (s) => ({ ...s, title }))
);

// Observable for save button click
const saveClick$: Observable<Action> = fromEvent(saveButton, "click").pipe(
    map(() => (s) => ({ ...s, save: true }))
);

// Function to send the Markdown to the backend and get HTML
function getHTML(s: State): Observable<State> {
    return ajax<{ html: string }>({
        url: "/api/convertMD",
        method: "POST",
        headers: {
            "Content-Type": "application/x-www-form-urlencoded",
        },
        body: s.markdown,
    }).pipe(
        map((response) => response.response),
        map((data) => ({ ...s, HTML: data.html })),
        first()
    );
}

// Function to save the HTML
function saveHTML(s: State): Observable<State> {
    return ajax({
        url: `/api/saveHTML`,
        method: "POST",
        headers: {
            "Content-Type": "application/json",
        },
        body: JSON.stringify({
            html: s.HTML,
            title: s.title,
        }),
    }).pipe(
        map(() => {
            alert("HTML successfully saved!");
            return { ...s, save: false };
        }),
        first()
    );
}

// Initial state
const initialState: State = {
    markdown: "",
    HTML: "",
    renderHTML: true,
    save: false,
    title: "Converted HTML",
};

// Main function to manage the stream and UI updates
function main() {
    merge(input$, checkboxStream$, titleInput$, saveClick$)
        .pipe(
            mergeScan((acc: State, reducer: Action) => {
                const updatedState = reducer(acc);

                if (updatedState.save) {
                    return saveHTML(updatedState);
                } else {
                    return getHTML(updatedState);
                }
            }, initialState)
        )
        .subscribe((state) => {
            const htmlOutput = document.getElementById("html-output");
            if (htmlOutput) {
                htmlOutput.innerHTML = "";
                htmlOutput.textContent = "";

                if (state.renderHTML) {
                    const highlight =
                        '<link rel="stylesheet" href="https://unpkg.com/@highlightjs/cdn-assets@11.3.1/styles/default.min.css" />';
                    htmlOutput.innerHTML = highlight + state.HTML;

                    const blocks = htmlOutput.querySelectorAll("pre code");
                    blocks.forEach((block) =>
                        hljs.highlightElement(block as HTMLElement)
                    );
                } else {
                    htmlOutput.textContent = state.HTML;
                }
            }

            // Update the document title
            document.title = state.title;
        });
}

// Initialize the main function on window load
if (typeof window !== "undefined") {
    window.onload = main;
}
// Initialize the main function on window load
if (typeof window !== "undefined") {
    window.onload = main;
}


with main.hs:

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}
module Main (main) where

-- import Assignment (markdownParser)

import           Assignment              (convertADTHTML, markdownParser)
import           Data.Aeson              (object, (.=))
import           Data.Aeson.Key          (fromString)
import           Data.Text.Lazy          (Text, pack, unpack)
import           Data.Text.Lazy.Encoding (decodeUtf8)
import           Instances               (ParseResult (Result), parse)
import           Web.Scotty              (ActionM, body, json, post, scotty)
import GHC.Generics (Generic)
import Control.Monad.IO.Class (liftIO)
import System.Directory (createDirectoryIfMissing)


data SaveRequest = SaveRequest
    { html :: String
    , title :: String
    } deriving (Show, Eq, Generic)

instance FromJSON SaveRequest
instance ToJSON SaveRequest


getResult :: ParseResult a -> (a -> String) -> String
getResult (Result _ a) f = f a
getResult _ _            = ""

-- Magic code to convert key, value pairs to JSON to send back to the server
jsonResponse :: [(String, String)] -> ActionM ()
jsonResponse pairs =
  json $ object [fromString key .= ((pack value) :: Text) | (key, value) <- pairs]


main :: IO ()
main = scotty 3000 $ do
    post "/api/convertMD" $ do
        requestBody <- body
        -- Convert the raw request body from ByteString to Text
        let requestBodyText = decodeUtf8 requestBody
            -- Convert the Text to String
            str = unpack requestBodyText
            -- Parse the Markdown string using 'markdownParser' and apply 'convertADTHTML'
            converted_html = getResult (parse markdownParser str) convertADTHTML

        -- Respond with the converted HTML as JSON
        jsonResponse [("html", converted_html)]
    
    post "/api/saveHTML" $ do
        requestBody <- body
        let maybeSaveReq = decode requestBody :: Maybe SaveRequest
        case maybeSaveReq of
            Just saveReq -> do
                currentTime <- liftIO getTime
                let safeTime = map (\c -> if c == ':' then '-' else c) currentTime
                    filename = "saved_html/saved_" ++ safeTime ++ ".html"
                liftIO $ do
                    createDirectoryIfMissing True "saved_html" -- Ensure the directory exists
                    writeFile filename (html saveReq)
                jsonResponse [("status", "success"), ("filename", filename)]
            Nothing ->
                jsonResponse [("status", "error"), ("message", "Invalid request body")]


and index.html:

<!DOCTYPE html>
<html lang="en">

<head>
    <meta charset="UTF-8">
    <meta name="viewport" content="width=device-width, initial-scale=1.0">
    <title>Markdown to HTML Converter</title>
    <link rel="stylesheet" href="/style.css">
</head>

<body>
    <header>
        <h1>Markdown to HTML Converter</h1>
    </header>

    <main>
        <div id="container" style="display: flex; width: 100%;">
            <section id="input-section" style="flex: 1; padding-right: 10px;">
                <h2>Enter Markdown:</h2>
                <textarea id="markdown-input" placeholder="Enter your Markdown here..." style="width: 100%;"></textarea>
                <!-- New Title Input Box -->
                <h3>Page Title:</h3>
                <input type="text" id="title-input" placeholder="Enter page title..." style="width: 100%;">
                <!-- New Save Button -->
                <button id="save-button">Save HTML</button>
            </section>
            <section id="output-section" style="flex: 1; padding-left: 10px;">
                <h2>HTML Output:</h2>
                <div id="html-output"></div>
                <label><input type="checkbox" name="checkbox" checked>Render HTML</label>
            </section>
        </div>
    </main>
    <footer>
        <p>Developed by Your Name</p>
    </footer>
    <script src="./src/main.ts" type="module"></script>
</body>

</html>

and index .js:


<!DOCTYPE html>
<html lang="en">

<head>
    <meta charset="UTF-8">
    <meta name="viewport" content="width=device-width, initial-scale=1.0">
    <title>Markdown to HTML Converter</title>
    <link rel="stylesheet" href="/style.css">
</head>

<body>
    <header>
        <h1>Markdown to HTML Converter</h1>
    </header>

    <main>
        <div id="container" style="display: flex; width: 100%;">
            <section id="input-section" style="flex: 1; padding-right: 10px;">
                <h2>Enter Markdown:</h2>
                <textarea id="markdown-input" placeholder="Enter your Markdown here..." style="width: 100%;"></textarea>
            </section>
            <section id="output-section" style="flex: 1; padding-left: 10px;">
                <h2>HTML Output:</h2>
                <div id="html-output"></div>
                <label><input type="checkbox" name="checkbox" checked>Render HTML</label>
            </section>
        </div>
    </main>
    <footer>
        <p>Developed by Your Name</p>
    </footer>
    <script src="./src/main.ts" type="module"></script>
</body>

</html>


this is spec.hs:

import           Assignment           (convertADTHTML, markdownParser)
import           Control.Exception    (IOException, try)
import           Control.Monad        (mapM_, (>>), (>>=))
import           Data.List            (isPrefixOf)
import           Instances            (ParseResult (Error, Result), parse)
import           System.FilePath      (joinPath, replaceExtension,
                                       splitDirectories, splitFileName,
                                       takeFileName, (</>))

import           System.Directory     (createDirectoryIfMissing)
import           System.FilePath.Glob (glob)
import           System.IO            (IOMode (WriteMode), withFile)
import           System.IO.Error      (isDoesNotExistError)
import           System.Process       (StdStream (UseHandle), createProcess,
                                       proc, std_out, waitForProcess)

-- Function to replace a substring with another substring in a string
replaceSubstring :: String -> String -> String -> String
replaceSubstring _ _ [] = []
replaceSubstring from to str@(x : xs)
  | from `isPrefixOf` str = to ++ replaceSubstring from to (drop (length from) str)
  | otherwise = x : replaceSubstring from to xs

processFile :: FilePath -> FilePath -> IO ()
processFile inputFile outputFile  = do
  putStrLn $ "Starting " ++ inputFile
  result <- try (readFile inputFile) :: IO (Either IOException String)
  case result of
    Left e
      | isDoesNotExistError e -> putStrLn $ "File not found: " ++ inputFile
      | otherwise -> putStrLn $ "Error reading file " ++ inputFile ++ ": " ++ show e
    Right contents -> do
      let parsed = parse markdownParser contents
      case parsed of
        Result _ adt -> do
          let prettyOutput = convertADTHTML adt
          writeFile outputFile prettyOutput
          putStrLn $ "Processed: " ++ inputFile
        _ -> putStrLn $ "Invalid ParseResult for file " ++ inputFile

mkFolderIfNotExists :: FilePath -> IO ()
mkFolderIfNotExists = createDirectoryIfMissing True


gitDiffNoIndex :: FilePath -> FilePath -> IO ()
gitDiffNoIndex file1 file2 = do
    mkFolderIfNotExists "./examples/diff_output"
    let outputFile = genOutputName "diff_output" "diff" file1

    withFile outputFile WriteMode $ \handle -> do
      -- Create a process for git diff --no-index
      (_, _, _, processHandle) <- createProcess (proc "git" ["--no-pager", "diff", "--no-index", "--no-ext-diff", file1, file2])
                                                   { std_out = UseHandle handle }


      -- Wait for the process to complete but ignore the exit code
      _ <- waitForProcess processHandle
      return ()

genOutputName :: FilePath -> String -> String -> FilePath
genOutputName outputFolder extension file = replaceExtension (replaceFolderAtIndex file 1 outputFolder) extension

replaceFolderAtIndex :: FilePath -> Int -> String -> FilePath
replaceFolderAtIndex filePath index newFolder = joinPath (replaceAtIndex index newFolder (splitDirectories dirPath)) </> fileName
  where
    -- Split the file path into directory and file components
    dirPath = fst $ splitFileName filePath
    fileName = takeFileName filePath

    -- Replace the folder at the specified index using zipWith
    replaceAtIndex :: Int -> String -> [FilePath] -> [FilePath]
    replaceAtIndex idx newVal = zipWith (\i folder -> if i == idx then newVal else folder) [0..]

checkADTShow :: IO ()
checkADTShow = do
  let markdownStr = "test **bold**"
  putStrLn "Testing ADT's Show instance:"
  putStrLn $ "Input string: " ++ markdownStr
  putStrLn $ case parse markdownParser markdownStr of
    Error _      -> "Parse error"
    Result _ adt -> "Result: " ++ show adt

main :: IO ()
main = do
  checkADTShow

  putStrLn ""
  putStrLn "Testing example inputs:"
  files <- glob "examples/input/*.md"
  let outputFiles = map (genOutputName "output" "html") files
  let expectedOutput = map (genOutputName "expected_output" "html") files

  mapM_ (uncurry processFile) (zip files outputFiles)
  mapM_ (uncurry gitDiffNoIndex) (zip expectedOutput outputFiles)




lets do part C :

Part C (6 marks): Adding extra functionality to the webpage
This task involves changing the webpage to include extra capabilities allowing a more
feature-full UI. You will not be marked on the layout, or ease of use of features, as long
as they are clearly visible to your marker, e.g., a button should be clearly visible on the
screen. This task will involve some light additions to both the HTML page and
TypeScript code. This will likely involve creating an observable stream for the data,
merging it into the subscription stream, and sending the information to the Haskell
backend. The communicated information between the Haskell backend and the
webpage will need to be updated to include additional information that the user wants
the engine to achieve.
● A button must be added to the webpage for saving, where the converted HTML
is saved using Haskell. The user does not need to be prompted for a file name,
and the HTML should be saved according to the current time, formatted in ISO
8601 format for the current date and time: YYYY-MM-DDTHH:MM:SS. The
function getTime is provided which will provide you this time in an IO String
format.
● A separate input box, to allow the user to change the title of the page, instead of
the default Converted HTML.

Concentrate on part C , modify the code as required, with justification, make efficient use of existing code, do not delete existing code, ensure code is efficient and readable. Emphasis on use existing code, with existing imports for main.ts. I want it to be simple yet efficient, but dont overly complicate it . Constrainst ; make use of existing code and imports. Now concentrate on the Main.hs, Do not use create directory if missing , use a simpler logic, rely less on additional imports. Use the gettime from Assignment. Constraint you cannot modify spec.hs, work around it.