Base for a new Parser structure.

spago.dhall

@@ -16,6 +16,7 @@ to generate this file without the comments in this block.
   , "console"
   , "control"
   , "effect"
+  , "either"
   , "integers"
   , "maybe"
   , "prelude"

src/DomainParser.purs

@@ -1,8 +1,7 @@
 -- | `DomainParser` is a simple parser for domain names as described in RFC 1035.
 module DomainParser where
 
-import Prelude
---import Prelude (bind, discard, pure, show, ($), (<>), (>))
+import Prelude (class Monoid, bind, mempty, not, pure, ($), (&&), (*>), (<<<), (<>), (==), (>))
 
 import Control.Lazy (defer)
 import Data.Maybe (Maybe(..))
@@ -14,7 +13,7 @@ import Data.String.CodeUnits as CU
 import Control.Alt ((<|>))
 import Control.Plus (empty)
 
-import Parser
+import Parser (Parser(..), alphanum, char, letter, many1, parse, string)
 
 -- | From RFC 1035: <let-dig> ::= <letter> | <digit>
 let_dig :: Parser Char

src/Main.purs

@@ -1,9 +1,9 @@
 module Main where
 
-import Parser
-import DomainParser
+import Parser (Parser, parse)
+import DomainParser (domain, label, ldh_str, sub_eof, subdomain)
 
-import Prelude (Unit, discard, show, ($), (==), (<>))
+import Prelude (Unit, discard, show, ($), (<>))
 
 import Effect (Effect)
 import Effect.Console (log)

src/Parser.purs

@@ -8,134 +8,159 @@ import Control.Plus (class Plus, empty)
 
 import Data.Array as A
 import Data.Int as Int
+import Data.Either (Either(..))
 import Data.Maybe (Maybe(..))
 import Data.String.CodeUnits (uncons, toCharArray, fromCharArray)
-import Data.Tuple (Tuple(..))
+-- import Data.Tuple (Tuple(..))
 
 import BaseFunctions (concat, isAlpha, isAlphaNum, isDigit, isLower, isSpace, isUpper)
 
-newtype Parser v = Parser (String -> Maybe (Tuple v String))
-parse :: forall a. Parser a -> (String -> Maybe (Tuple a String))
+type Input = String
+type Size = Int
+type Position = Int
+data DomainError
+  = SubdomainTooLarge Position Size
+  | DomainTooLarge Size
+  | InvalidCharacter Position
+type Error e = { pos :: Position, input :: Input, error :: Maybe e }
+type Value v = { pos :: Position, input :: Input, result :: v }
+type Result e v = Either (Error e) (Value v)
+
+newtype Parser e v = Parser (Input -> Result e v)
+--newtype Parser v = Parser (String -> Maybe (Tuple v String))
+parse :: forall e v. Parser e v -> (Input -> Result e v)
 parse (Parser p) = p
 
-item :: Parser Char
+failError :: forall e v. Position -> Input -> Maybe e -> Result e v
+failError pos input error = Left { pos: pos, error: error, input: input }
+
+fail :: forall e v. Position -> Input -> Result e v
+fail pos input = failError pos input Nothing
+
+success :: forall e v. Position -> Input -> v -> Result e v
+success pos input v = Right { pos: pos, input: input, result: v }
+
+item :: forall e. Parser e Char
 item = Parser p
   where p str = case uncons str of
-                  Nothing -> Nothing
-                  Just { head: x, tail: xs } -> Just (Tuple x xs)
+                  Nothing                    -> fail 0 str
+                  Just { head: x, tail: xs } -> success 1 xs x
 
-instance functorParser :: Functor Parser where
+instance functorParser :: Functor (Parser e) where
+  map :: forall a b. (a -> b) -> Parser e a -> Parser e b
   map f (Parser p) =
-    Parser $ \s0 -> do
-      (Tuple x s1) <- p s0
-      pure (Tuple (f x) s1)
+    Parser $ \s0 -> case p s0 of
+      Right { pos: pos, input: input, result: v } -> success pos input (f v)
+      Left  { pos: pos, input: input, error: e }  -> failError pos input e
 
-instance applyParser :: Apply Parser where
+instance applyParser :: Apply (Parser e) where
   apply (Parser p1) (Parser p2)
-    = Parser $ \str -> case p1 str of
-        Nothing -> Nothing
-        Just (Tuple x1 xs1) -> case p2 xs1 of
-          Nothing -> Nothing
-          Just (Tuple x2 xs2) -> Just (Tuple (x1 x2) xs2)
+    = Parser $ \s0 -> case p1 s0 of
+        Left error -> Left error
+        Right { pos: pos1, input: s1, result: r1 } -> case p2 s1 of
+          Left error -> Left error
+          Right { pos: pos2, input: s2, result: r2 } -> success (pos1 + pos2) s2 (r1 r2)
 
-instance applicativeParser :: Applicative Parser where
-  pure a = Parser $ \str -> Just (Tuple a str)
+instance applicativeParser :: Applicative (Parser e) where
+  pure a = Parser $ \str -> success 0 str a
 
-instance bindParser :: Bind Parser where
-  bind (Parser p) f = Parser $ \str -> case p str of
-    Nothing -> Nothing
-    Just (Tuple x xs) ->
-      let (Parser p2) = f x
-      in p2 xs
+instance bindParser :: Bind (Parser e) where
+  bind (Parser p) f = Parser $ \s0 -> case p s0 of
+    Left error -> Left error
+    Right { pos: _, input: input, result: result } ->
+      let (Parser p2) = f result
+      in p2 input
 
-instance altParser :: Alt Parser where
-  alt :: forall a. Parser a -> Parser a -> Parser a
+instance altParser :: Alt (Parser e) where
+  alt :: forall v. Parser e v -> Parser e v -> Parser e v
   alt (Parser p1) (Parser p2) = Parser p
     where
       p stream = case p1 stream of
-        Nothing -> p2 stream
+        Left { pos: pos, error: error, input: input } -> case error of
+          Nothing -> p2 stream
+          _ -> failError pos input error
         right -> right
 
-instance plusParser :: Plus Parser where
-  empty :: forall a. Parser a
-  empty = Parser \_ -> Nothing
+instance plusParser :: Plus (Parser e) where
+  empty :: forall v. Parser e v
+  empty = Parser \input -> fail 0 input
 
-instance alternativeParser :: Alternative Parser
+instance alternativeParser :: Alternative (Parser e)
 
-instance lazyParser :: Lazy (Parser a) where
+instance lazyParser :: Lazy (Parser e v) where
   defer f = Parser \str -> parse (f unit) str
 
 -- Generic parsing functions.
 
-sat :: (Char -> Boolean) -> Parser Char
+sat :: forall e. (Char -> Boolean) -> Parser e Char
 sat p = do x <- item
            if p x then pure x else empty
 
-digit :: Parser Char
+digit :: forall e. Parser e Char
 digit = sat isDigit
 
-lower :: Parser Char
+lower :: forall e. Parser e Char
 lower = sat isLower
 
-upper :: Parser Char
+upper :: forall e. Parser e Char
 upper = sat isUpper
 
-letter :: Parser Char
+letter :: forall e. Parser e Char
 letter = sat isAlpha
 
-alphanum :: Parser Char
+alphanum :: forall e. Parser e Char
 alphanum = sat isAlphaNum
 
-char :: Char -> Parser Char
+char :: forall e. Char -> Parser e Char
 char x = sat (_ == x)
 
-string :: String -> Parser String
+string :: forall e. String -> Parser e String
 string str = case A.uncons (toCharArray str) of
-  Nothing -> Parser \stream -> Just (Tuple "" stream)
+  Nothing -> Parser \stream -> success 0 stream ""
   Just { head: x, tail: xs } -> do c <- char x
                                    rest <- string (fromCharArray xs)
                                    pure (concat c rest)
 
-ident :: Parser String
+ident :: forall e. Parser e String
 ident = do x  <- lower
            xs <- A.many alphanum
            pure (fromCharArray $ A.cons x xs)
 
-nat :: Parser Int
+nat :: forall e. Parser e Int
 nat = do xs <- A.some digit
          case Int.fromString (fromCharArray xs) of
            Nothing -> empty
            Just x -> pure x
 
-int :: Parser Int
+int :: forall e. Parser e Int
 int = do _ <- char '-'
          n <- nat
          pure (-n)
        <|> nat
 
-space :: Parser Unit
+space :: forall e. Parser e Unit
 space = do _ <- A.many (sat isSpace)
            pure unit
 
-token :: forall a. Parser a -> Parser a
+token :: forall e a. Parser e a -> Parser e a
 token p = do space
              v <- p
              _ <- space
              pure v
 
-identifier :: Parser String
+identifier :: forall e. Parser e String
 identifier = token ident
 
-natural :: Parser Int
+natural :: forall e. Parser e Int
 natural = token nat
 
-integer :: Parser Int
+integer :: forall e. Parser e Int
 integer = token int
 
-symbol :: String -> Parser String
+symbol :: forall e. String -> Parser e String
 symbol xs = token (string xs)
 
-many1 :: forall a. Parser a -> Parser (Array a)
+many1 :: forall e v. Parser e v -> Parser e (Array v)
 many1 p = do first <- p
              rest <- A.many p
              pure $ A.cons first rest