I am currently building a  markdown to html parser using haskell and this is the code I have so far. It works and has no syntax or compilation errors, however the output is not matching the expected output. Can you spot what is wrong and help me fix all the errors. the output must match the expected output EXACTLY, including newline spaces, the < !doctype> stuff and spaces etc.


There are no syntax errors anymore, but there seems to be a fair few logical errors. I will give you the expected output of the markdown files we are parsing, and the actual output we are getting. You will be able to tell that clearly something is wrong.  if your output is correct (i.e., matches the expected output exactly), the diff file will be completely empty as there is no difference between your output and the expected output. Your output for Part B should include everything in expected output (i.e., it should include the <!DOCTYPE html> and whatnot). Please figure out what is wrong and correct the mistakes:



expected blockquotes:
<!DOCTYPE html>
<html lang="en">

<head>
    <meta charset="UTF-8">
    <title>Test</title>
</head>

<body>
    <blockquote>
        <p>This is a block quote.</p>
        <p>It can <strong>span</strong> multiple lines.</p>
    </blockquote>
</body>

</html>

actual blockquotes:
diff --git "a/examples\\expected_output\\blockquotes.html" "b/examples\\output\\blockquotes.html"
index 02666f2..ea696a6 100644
--- "a/examples\\expected_output\\blockquotes.html"
+++ "b/examples\\output\\blockquotes.html"
@@ -1,16 +1,4 @@
-<!DOCTYPE html>
-<html lang="en">
-
-<head>
-    <meta charset="UTF-8">
-    <title>Test</title>
-</head>
-
-<body>
-    <blockquote>
-        <p>This is a block quote.</p>
-        <p>It can <strong>span</strong> multiple lines.</p>
-    </blockquote>
-</body>
-
-</html>
+<blockquote>
+<p>This is a block quote.</p>
+<p>It can <strong>span</strong> multiple lines.</p>
+</blockquote>


expected code md:
<!DOCTYPE html>
<html lang="en">

<head>
    <meta charset="UTF-8">
    <title>Test</title>
</head>

<body>
    <pre><code class="language-haskell">main :: IO ()
main = do
    putStrLn "Never gonna give you up"
    putStrLn "Never gonna let you down"
    putStrLn "Never gonna run around and desert you"</code></pre>
</body>

</html>

actual code md output:
diff --git "a/examples\\expected_output\\code.html" "b/examples\\output\\code.html"
index ca901bf..f8c2252 100644
--- "a/examples\\expected_output\\code.html"
+++ "b/examples\\output\\code.html"
@@ -1,17 +1,6 @@
-<!DOCTYPE html>
-<html lang="en">
-
-<head>
-    <meta charset="UTF-8">
-    <title>Test</title>
-</head>
-
-<body>
-    <pre><code class="language-haskell">main :: IO ()
+<pre><code class="language-haskell">main :: IO ()
 main = do
-    putStrLn "Never gonna give you up"
-    putStrLn "Never gonna let you down"
-    putStrLn "Never gonna run around and desert you"</code></pre>
-</body>
-
-</html>
+putStrLn "Never gonna give you up"
+putStrLn "Never gonna let you down"
+putStrLn "Never gonna run around and desert you"
+</code></pre>
\ No newline at end of file

expected footnotes:

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

<head>
    <meta charset="UTF-8">
    <title>Test</title>
</head>

<body>
    <p id="fn1">My reference.</p>
    <p id="fn2">Another reference.</p>
    <p id="fn3">The 2 spaces after the colon should be ignored</p>
</body>

</html>


actual footnotes:
diff --git "a/examples\\expected_output\\footnotes.html" "b/examples\\output\\footnotes.html"
index 330c5d5..7d37565 100644
--- "a/examples\\expected_output\\footnotes.html"
+++ "b/examples\\output\\footnotes.html"
@@ -1,15 +1 @@
-<!DOCTYPE html>
-<html lang="en">
-
-<head>
-    <meta charset="UTF-8">
-    <title>Test</title>
-</head>
-
-<body>
-    <p id="fn1">My reference.</p>
-    <p id="fn2">Another reference.</p>
-    <p id="fn3">The 2 spaces after the colon should be ignored</p>
-</body>
-
-</html>
+<sup><a id="1" href="#ref1">1</a></sup>
\ No newline at end of file


expected free_Text:
<!DOCTYPE html>
<html lang="en">

<head>
    <meta charset="UTF-8">
    <title>Test</title>
</head>

<body>
    <p>Here is some <strong>markdown</strong></p>
    <p>More lines here</p>
    <p>Text</p>
</body>

</html>


actual free text:
diff --git "a/examples\\expected_output\\free_text.html" "b/examples\\output\\free_text.html"
index d178a3b..e39da25 100644
--- "a/examples\\expected_output\\free_text.html"
+++ "b/examples\\output\\free_text.html"
@@ -1,15 +1 @@
-<!DOCTYPE html>
-<html lang="en">
-
-<head>
-    <meta charset="UTF-8">
-    <title>Test</title>
-</head>
-
-<body>
-    <p>Here is some <strong>markdown</strong></p>
-    <p>More lines here</p>
-    <p>Text</p>
-</body>
-
-</html>
+Here is some <strong>markdown</strong>
\ No newline at end of file


expected heading:

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

<head>
    <meta charset="UTF-8">
    <title>Test</title>
</head>

<body>
    <h1>Heading 1</h1>
    <h2>Heading 2</h2>
    <h3>Heading 3</h3>
    <h4>Heading 4</h4>
    <h5>Heading 5</h5>
    <h6>Heading 6</h6>
    <h1>Alternative Heading 1</h1>
    <h2>Heading level 2</h2>
    <h1><strong>Bolded Heading 1</strong></h1>
</body>

</html>


actual heading:

diff --git "a/examples\\expected_output\\heading.html" "b/examples\\output\\heading.html"
index 573dafa..ac06cdc 100644
--- "a/examples\\expected_output\\heading.html"
+++ "b/examples\\output\\heading.html"
@@ -1,21 +1 @@
-<!DOCTYPE html>
-<html lang="en">
-
-<head>
-    <meta charset="UTF-8">
-    <title>Test</title>
-</head>
-
-<body>
-    <h1>Heading 1</h1>
-    <h2>Heading 2</h2>
-    <h3>Heading 3</h3>
-    <h4>Heading 4</h4>
-    <h5>Heading 5</h5>
-    <h6>Heading 6</h6>
-    <h1>Alternative Heading 1</h1>
-    <h2>Heading level 2</h2>
-    <h1><strong>Bolded Heading 1</strong></h1>
-</body>
-
-</html>
+<h1>Heading 1</h1>
\ No newline at end of file


expected images:

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

<head>
    <meta charset="UTF-8">
    <title>Test</title>
</head>

<body>
    <img src="image.png" alt="Alt Text" title="Caption Text">
</body>

</html>


actual images:

diff --git "a/examples\\expected_output\\images.html" "b/examples\\output\\images.html"
index 55b5731..1b3ea3e 100644
--- "a/examples\\expected_output\\images.html"
+++ "b/examples\\output\\images.html"
@@ -1,13 +1 @@
-<!DOCTYPE html>
-<html lang="en">
-
-<head>
-    <meta charset="UTF-8">
-    <title>Test</title>
-</head>
-
-<body>
-    <img src="image.png" alt="Alt Text" title="Caption Text">
-</body>
-
-</html>
+<img src="image.png" alt="Alt Text" title="Caption Text" />
\ No newline at end of file

expected ordered list:

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

<head>
    <meta charset="UTF-8">
    <title>Test</title>
</head>

<body>
    <ol>
        <li>Item 1
            <ol>
                <li>Sub Item 1</li>
                <li>Sub Item 2</li>
                <li>Sub Item 3</li>
            </ol>
        </li>
        <li><strong>Bolded Item 2</strong></li>
        <li>Item 3</li>
        <li>Item 4</li>
    </ol>
</body>

</html>


actual ordered list:

diff --git "a/examples\\expected_output\\ordered_list.html" "b/examples\\output\\ordered_list.html"
index 0c41095..ef0ebba 100644
--- "a/examples\\expected_output\\ordered_list.html"
+++ "b/examples\\output\\ordered_list.html"
@@ -1,24 +1,8 @@
-<!DOCTYPE html>
-<html lang="en">
-
-<head>
-    <meta charset="UTF-8">
-    <title>Test</title>
-</head>
-
-<body>
-    <ol>
-        <li>Item 1
-            <ol>
-                <li>Sub Item 1</li>
-                <li>Sub Item 2</li>
-                <li>Sub Item 3</li>
-            </ol>
-        </li>
-        <li><strong>Bolded Item 2</strong></li>
-        <li>Item 3</li>
-        <li>Item 4</li>
-    </ol>
-</body>
-
-</html>
+<ol>
+<li>Item 1</li>
+<ol>
+<li>Sub Item 1</li><li>Sub Item 2</li><li>Sub Item 3</li></ol>
+</li><li><strong>Bolded Item 2</strong></li>
+<li>Item 3</li>
+<li>Item 4</li>
+</ol>


expected tables:

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

<head>
    <meta charset="UTF-8">
    <title>Test</title>
</head>

<body>
    <table>
        <thead>
            <tr>
                <th>Tables</th>
                <th>Are</th>
                <th>Cool</th>
            </tr>
        </thead>
        <tbody>
            <tr>
                <td>here</td>
                <td>is</td>
                <td>data</td>
            </tr>
            <tr>
                <td>here</td>
                <td>is</td>
                <td>data</td>
            </tr>
            <tr>
                <td>here</td>
                <td>is also</td>
                <td><strong>bolded data</strong></td>
            </tr>
        </tbody>
    </table>
</body>

</html>


actual tables:

diff --git "a/examples\\expected_output\\tables.html" "b/examples\\output\\tables.html"
index 70fde47..1bf1c72 100644
--- "a/examples\\expected_output\\tables.html"
+++ "b/examples\\output\\tables.html"
@@ -1,38 +1,19 @@
-<!DOCTYPE html>
-<html lang="en">
-
-<head>
-    <meta charset="UTF-8">
-    <title>Test</title>
-</head>
-
-<body>
-    <table>
-        <thead>
-            <tr>
-                <th>Tables</th>
-                <th>Are</th>
-                <th>Cool</th>
-            </tr>
-        </thead>
-        <tbody>
-            <tr>
-                <td>here</td>
-                <td>is</td>
-                <td>data</td>
-            </tr>
-            <tr>
-                <td>here</td>
-                <td>is</td>
-                <td>data</td>
-            </tr>
-            <tr>
-                <td>here</td>
-                <td>is also</td>
-                <td><strong>bolded data</strong></td>
-            </tr>
-        </tbody>
-    </table>
-</body>
-
-</html>
+<table>
+<tr>
+    <th>Tables        </th>
+    <th>Are           </th>
+    <th>Cool  </th>
+</tr><tr>
+    <td>here          </td>
+    <td>is            </td>
+    <td>data  </td>
+</tr><tr>
+    <td>here          </td>
+    <td>is            </td>
+    <td>data  </td>
+</tr><tr>
+    <td>here </td>
+    <td>is also </td>
+    <td><strong>bolded data</strong></td>
+    <td> </td>
+</tr></table>
\ No newline at end of file


Assignment.hs:

-- Assignment.hs

module Assignment (markdownParser, convertADTHTML) where

import           Control.Applicative (Alternative (..), some, many, optional)
import           Data.Char           (isSpace)
import           Instances           (Parser (..))
import           Parser              (string, satisfy, space, is, digit, eof)

-- | Represents an item in an ordered list.
data ListItem = ListItem [ADT]
    deriving (Show, Eq)

-- | Algebraic Data Type representing various Markdown elements.
data ADT
    = Empty
    | Freetext [ADT]                -- ^ Holds multiple ADT elements
    | Text String
    | Italic ADT
    | Bold ADT
    | Strikethrough ADT
    | Link String String           -- ^ Link text and URL
    | InlineCode String
    | Footnote Int
    | Image String String String   -- ^ Alt text, URL, Caption
    | FootnoteReference Int String
    | Heading Int ADT              -- ^ Heading level and content
    | BlockQuote [ADT]
    | CodeBlock (Maybe String) String -- ^ Optional language and code
    | OrderedList [ListItem]
    | Table [ADT] [ADT]
    deriving (Show, Eq)


-- | Concatenates multiple ADTs into a single ADT.
concatTexts :: [ADT] -> ADT
concatTexts []     = Empty
concatTexts [x]    = x
concatTexts xs     = Freetext xs

-- | Main markdown parser combining all individual parsers
markdownParser :: Parser ADT
markdownParser = do
    elements <- some (headingParser
                   <|> alternativeHeadingParser
                   <|> blockQuoteParser
                   <|> codeBlockParser
                   <|> orderedListParser
                   <|> italicParser
                   <|> boldParser
                   <|> strikethroughParser
                   <|> linkParser
                   <|> inlineCodeParser
                   <|> footnoteParser
                   <|> imageParser
                   <|> plainTextParser
                   )
    eof
    return $ Freetext elements

-- | Converts an ADT to its corresponding HTML representation.
convertADTHTML :: ADT -> String
convertADTHTML adt = htmlBoilerplate ++ convertCoreADTHTML adt ++ htmlBoilerplateEnd
  where
    htmlBoilerplate = "<!DOCTYPE html>\n<html lang=\"en\">\n\n<head>\n    <meta charset=\"UTF-8\">\n    <title>Test</title>\n</head>\n\n<body>\n"
    htmlBoilerplateEnd = "</body>\n\n</html>\n"

convertCoreADTHTML :: ADT -> String
convertCoreADTHTML Empty = ""
convertCoreADTHTML (Freetext elements) = concatMap convertCoreADTHTML elements
convertCoreADTHTML (Text txt) = txt
convertCoreADTHTML (Italic a) = "<em>" ++ convertCoreADTHTML a ++ "</em>"
convertCoreADTHTML (Bold a) = "<strong>" ++ convertCoreADTHTML a ++ "</strong>"
convertCoreADTHTML (Strikethrough a) = "<del>" ++ convertCoreADTHTML a ++ "</del>"
convertCoreADTHTML (Link text url) = "<a href=\"" ++ url ++ "\">" ++ text ++ "</a>"
convertCoreADTHTML (InlineCode code) = "<code>" ++ code ++ "</code>"
convertCoreADTHTML (Footnote num) = "<sup>[" ++ show num ++ "]</sup>"
convertCoreADTHTML (Image alt url caption) =
    "<img src=\"" ++ url ++ "\" alt=\"" ++ alt ++ "\" title=\"" ++ caption ++ "\" />"
convertCoreADTHTML (FootnoteReference num ref) =
    "<p id=\"ref" ++ show num ++ "\">" ++ ref ++ "</p>"
convertCoreADTHTML (Heading level content) =
    "<h" ++ show level ++ ">" ++ convertCoreADTHTML content ++ "</h" ++ show level ++ ">"
convertCoreADTHTML (BlockQuote blocks) =
    "    <blockquote>\n" ++ concatMap convertBlockQuoteLine blocks ++ "    </blockquote>\n"
  where
    convertBlockQuoteLine :: ADT -> String
    convertBlockQuoteLine (Freetext contents) =
        "        <p>" ++ concatMap convertCoreADTHTML contents ++ "</p>\n"
    convertBlockQuoteLine _ = ""
convertCoreADTHTML (CodeBlock lang code) =
    "<pre><code" ++ maybe "" (\l -> " class=\"language-" ++ l ++ "\"") lang ++ ">" ++ code ++ "</code></pre>"
convertCoreADTHTML (OrderedList items) =
    "    <ol>\n" ++ concatMap convertListItem items ++ "    </ol>\n"
  where
    convertListItem (ListItem adts) = "        <li>" ++ concatMap convertCoreADTHTML adts ++ "</li>\n"

convertCoreADTHTML (Table headers rows) =
    "<table>\n" ++ convertHeaders headers ++ convertRows rows ++ "</table>\n"
  where
    convertHeaders :: [ADT] -> String
    convertHeaders hs = "    <tr>\n" ++ concatMap (\h -> "        <th>" ++ convertCoreADTHTML h ++ "</th>\n") hs ++ "    </tr>\n"
        
    convertRows :: [ADT] -> String
    convertRows rs = concatMap convertRow rs
      where
        convertRow (Freetext cells) =
            "    <tr>\n" ++ concatMap (\c -> "        <td>" ++ convertCoreADTHTML c ++ "</td>\n") cells ++ "    </tr>\n"
        convertRow _ = ""

-- | Parser for italic text: _text_
italicParser :: Parser ADT
italicParser = do
    _ <- is '_'
    content <- many (italicParser <|> boldParser <|> strikethroughParser 
                       <|> linkParser
                       <|> inlineCodeParser
                       <|> footnoteParser
                       <|> imageParser
                       <|> plainTextParser)
    _ <- is '_'
    return $ Italic (concatTexts content)

-- | Parser for bold text: **text**
boldParser :: Parser ADT
boldParser = do
    _ <- string "**"
    content <- many (italicParser <|> boldParser <|> strikethroughParser 
                       <|> linkParser
                       <|> inlineCodeParser
                       <|> footnoteParser
                       <|> imageParser
                       <|> plainTextParser)
    _ <- string "**"
    return $ Bold (concatTexts content)

-- | Parser for strikethrough text: ~~text~~
strikethroughParser :: Parser ADT
strikethroughParser = do
    _ <- string "~~"
    content <- many (italicParser <|> boldParser <|> strikethroughParser 
                       <|> linkParser
                       <|> inlineCodeParser
                       <|> footnoteParser
                       <|> imageParser
                       <|> plainTextParser)
    _ <- string "~~"
    return $ Strikethrough (concatTexts content)

-- | Parser for inline code: `code`
inlineCodeParser :: Parser ADT
inlineCodeParser = do
    _ <- is '`'
    code <- some (satisfy (/= '`'))
    _ <- is '`'
    return $ InlineCode code

-- | Parser for links: [text](URL)
linkParser :: Parser ADT
linkParser = do
    _ <- is '['
    linkText <- many (satisfy (/= ']'))
    _ <- is ']'
    _ <- is '('
    url <- many (satisfy (/= ')'))
    _ <- is ')'
    return $ Link linkText url

-- | Parser for footnotes: [^1]
footnoteParser :: Parser ADT
footnoteParser = do
    _ <- string "[^"
    numStr <- some digit
    _ <- is ']'
    return $ Footnote (read numStr)

-- | Parser for images: ![Alt](URL "Caption")
imageParser :: Parser ADT
imageParser = do
    _ <- string "![" 
    altText <- some (satisfy (/= ']'))
    _ <- is ']'
    _ <- is '('
    url <- many (satisfy (`notElem` [' ', ')']))
    _ <- is '\"'
    caption <- many (satisfy (/= '\"'))
    _ <- is '\"'
    _ <- is ')'
    return $ Image altText url caption

-- | Parser for headings using hash syntax: # Heading 1
headingParser :: Parser ADT
headingParser = do
    hashes <- some (is '#')
    _ <- is ' '
    content <- many (italicParser <|> boldParser <|> strikethroughParser 
                       <|> linkParser 
                       <|> inlineCodeParser 
                       <|> footnoteParser 
                       <|> imageParser 
                       <|> plainTextParser)
    return $ Heading (length hashes) (concatTexts content)

-- | Parser for alternative heading syntax (Level 1 and 2)
alternativeHeadingParser :: Parser ADT
alternativeHeadingParser = level1Parser <|> level2Parser

-- | Parser for Level 1 heading using ====
level1Parser :: Parser ADT
level1Parser = do
    content <- many (italicParser <|> boldParser <|> strikethroughParser 
                     <|> linkParser 
                     <|> inlineCodeParser 
                     <|> footnoteParser 
                     <|> imageParser 
                     <|> plainTextParser)
    _ <- some (is '=')
    return $ Heading 1 (concatTexts content)

-- | Parser for Level 2 heading using ----
level2Parser :: Parser ADT
level2Parser = do
    content <- many (italicParser <|> boldParser <|> strikethroughParser 
                     <|> linkParser 
                     <|> inlineCodeParser 
                     <|> footnoteParser 
                     <|> imageParser 
                     <|> plainTextParser)
    _ <- some (is '-')
    return $ Heading 2 (concatTexts content)


-- | Parser for block quotes, grouping multiple lines into one BlockQuote
blockQuoteParser :: Parser ADT
blockQuoteParser = do
    -- Parse one or more lines starting with '>'
    blocks <- some quoteLine
    return $ BlockQuote blocks
  where
    -- Parser for a single block quote line
    quoteLine :: Parser ADT
    quoteLine = do
        _ <- is '>'                      -- Match '>'
        _ <- many (satisfy isSpace)      -- Ignore spaces after '>'
        content <- many (italicParser 
                     <|> boldParser 
                     <|> strikethroughParser 
                     <|> linkParser 
                     <|> inlineCodeParser 
                     <|> footnoteParser 
                     <|> imageParser 
                     <|> plainTextParser)
        _ <- is '\n'                      -- Match newline
        return $ Freetext content

-- | Parser for code blocks
codeBlockParser :: Parser ADT
codeBlockParser = do
    _ <- string "```"
    lang <- optional (many (satisfy (/= '\n')))
    _ <- is '\n'
    code <- manyTill (satisfy (/= '`')) (string "```")
    return $ CodeBlock lang code

-- | Parser for ordered lists
orderedListParser :: Parser ADT
orderedListParser = do
    items <- some listItemParser
    return $ OrderedList items

-- | Helper parser for list items
listItemParser :: Parser ListItem
listItemParser = do
    num <- some digit
    _ <- is '.'
    _ <- some space
    content <- many (italicParser <|> boldParser <|> strikethroughParser 
                     <|> linkParser 
                     <|> inlineCodeParser 
                     <|> footnoteParser 
                     <|> imageParser 
                     <|> plainTextParser)
    _ <- is '\n'
    return $ ListItem content

-- | Parser for plain text without any modifiers
plainTextParser :: Parser ADT
plainTextParser = do
    txt <- some (satisfy (`notElem` ['_', '*', '~', '[', ']', '(', ')', '`', '!', '#', '>', '\n']))
    return $ Text txt

-- | Parser that consumes input until a specified ending parser succeeds.
manyTill :: Parser a -> Parser end -> Parser [a]
manyTill p end = go []
  where
    go acc = (end *> pure (reverse acc)) <|> ((:) <$> p <*> go acc)


instances.hs:

{-# LANGUAGE InstanceSigs #-}

module Instances (ParseResult (Result, Error), Parser (..), readInt, ParseError(..), isErrorResult) where

import           Control.Applicative (Alternative (..))

-- $setup
-- >>> let p = \n -> Parser (\x -> Result x n)
-- >>> let add = \n -> \m -> Parser (\x -> Result x (n+m))

data ParseError
  = UnexpectedEof
  | ExpectedEof Input
  | UnexpectedChar Char
  | UnexpectedString String
  deriving (Eq, Show)

data ParseResult a
  = Error ParseError
  | Result Input a
  deriving (Eq)

type Input = String

newtype Parser a = Parser {parse :: Input -> ParseResult a}

-- Result Instances

instance Show a => Show (ParseResult a) where
  show :: ParseResult a -> String
  show (Result i a) = "Result >" ++ i ++ "< " ++ show a
  show (Error UnexpectedEof) = "Unexpected end of stream"
  show (Error (UnexpectedChar c)) = "Unexpected character: " ++ show [c]
  show (Error (UnexpectedString s)) = "Unexpected string: " ++ show s
  show (Error (ExpectedEof i)) =
    "Expected end of stream, but got >" ++ show i ++ "<"

instance Functor ParseResult where
  fmap :: (a -> b) -> ParseResult a -> ParseResult b
  fmap f (Result i a) = Result i (f a)
  fmap _ (Error e)    = Error e

-- Parser Instances

-- | Functor instance for a parser
--
-- >>> parse ((+1) <$> Parser (`Result` 1)) "hello"
-- Result >hello< 2

--  >>> parse ((+1) <$> Parser (const (Error UnexpectedEof))) "hello"
-- Unexpected end of stream
instance Functor Parser where
  fmap :: (a -> b) -> Parser a -> Parser b
  fmap f (Parser p) = Parser (fmap f . p)

-- | Implement this before Applicative Parser!
--
-- >>> parse (p 1 >>= add 2) ""
-- Result >< 3
--
-- prop> \i j -> parse (p i >>= add j) "" == Result "" (i + j)
instance Monad Parser where
  (>>=) :: Parser a -> (a -> Parser b) -> Parser b
  (>>=) (Parser p) f = Parser $ \i -> case p i of
    Result rest x -> parse (f x) rest
    Error e       -> Error e

-- |
--
-- >>> parse (Parser (`Result` (+1)) <*> Parser (`Result` 1)) "hello"
-- Result >hello< 2
--
-- >>> parse (pure (+1) <*> Parser (`Result` 1)) "hello"
-- Result >hello< 2
--
-- >>> parse (pure (+1) <*> (pure 1 :: Parser Int)) "hello"
-- Result >hello< 2
instance Applicative Parser where
  -- creates a Parser that always succeeds with the given input
  pure :: a -> Parser a
  pure = Parser . flip Result

  -- or
  (<*>) :: Parser (a -> b) -> Parser a -> Parser b
  (<*>) p q = p >>= (<$> q)

-- |
--
-- 'Alternative' is used for parsers that support choice (alternative) and
-- failure (empty). In the context of this 'Parser' type:
--
-- 1. 'empty' represents a parser that always fails
--
-- 2. '<|>' combines two parsers. It tries the first parser on the input,
-- and if it fails it tries the second parser.
--
-- see https://tgdwyer.github.io/haskell3/#alternative
--
-- >>> parse (pure 1 <|> empty) "world, hello!"
-- Result >world, hello!< 1
-- >>> parse (empty <|> pure 1) "world"
-- Result >world< 1
instance Alternative Parser where
  empty :: Parser a
  empty = Parser $ const (Error UnexpectedEof)

  (<|>) :: Parser a -> Parser a -> Parser a
  (<|>) pa pb = Parser $ \x -> case parse pa x of
    Error _ -> parse pb x
    r       -> r

-- Support functions

isErrorResult :: ParseResult a -> Bool
isErrorResult (Error _) = True
isErrorResult _         = False

readInt :: String -> Maybe (Int, String)
readInt s = case reads s of
  [(x, rest)] -> Just (x, rest)
  _           -> Nothing


Parser.hs:

{-# 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