diff --git a/spago.dhall b/spago.dhall index 5282eda..2732509 100644 --- a/spago.dhall +++ b/spago.dhall @@ -16,6 +16,7 @@ to generate this file without the comments in this block. , "console" , "control" , "effect" + , "either" , "integers" , "maybe" , "prelude" diff --git a/src/DomainParser.purs b/src/DomainParser.purs index 82651d8..4b3a8d2 100644 --- a/src/DomainParser.purs +++ b/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 :: Parser Char diff --git a/src/Main.purs b/src/Main.purs index c7a13c1..9c040c0 100644 --- a/src/Main.purs +++ b/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) diff --git a/src/Parser.purs b/src/Parser.purs index e1d6b72..94954d3 100644 --- a/src/Parser.purs +++ b/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