More consistent function naming.

master
Philippe Pittoli 2024-01-19 02:27:11 +01:00
parent 4d88340381
commit d4aa63730e
4 changed files with 47 additions and 43 deletions

View File

@ -6,5 +6,5 @@ build:
run: run:
spago run spago run
test: t:
spago test spago test

View File

@ -3,5 +3,5 @@ module GenericParser
, module GenericParser.DomainParser , module GenericParser.DomainParser
) where ) where
import GenericParser.Parser (Position, PositionString, Input, Error, Value, Result, Parser(..), parse, current_position, failError, fail, success, item, sat, digit, lower, upper, letter, alphanum, char, string, ident, nat, int, space, token, identifier, natural, integer, symbol, many1) import GenericParser.Parser (Position, PositionString, Input, Error, Value, Result, Parser(..), parse, current_position, failureError, failure, success, item, sat, digit, lower, upper, letter, alphanum, char, string, ident, nat, int, space, token, identifier, natural, integer, symbol, many1)
import GenericParser.DomainParser (Size, DomainError(..), let_dig, let_dig_hyp, ldh_str, label_maxsize, max_domain_length, last_char, parse_last_char, tryMaybe, try, label, subdomain, eof, sub_eof, domain) import GenericParser.DomainParser (Size, DomainError(..), let_dig, let_dig_hyp, ldh_str, max_label_length, max_domain_length, tryMaybe, try, label, subdomain, eof, sub_eof, domain)

View File

@ -3,17 +3,16 @@ module GenericParser.DomainParser where
import Prelude (bind, not, pure, ($), (&&), (*>), (<<<), (<>), (>), (-)) import Prelude (bind, not, pure, ($), (&&), (*>), (<<<), (<>), (>), (-))
import Control.Alt ((<|>))
import Control.Lazy (defer) import Control.Lazy (defer)
import Data.Maybe (Maybe(..), maybe)
import Data.Either (Either(..))
import Data.Array as A import Data.Array as A
import Data.Either (Either(..))
import Data.Maybe (Maybe(..), maybe)
import Data.String as S import Data.String as S
import Data.String.CodeUnits as CU import Data.String.CodeUnits as CU
import Control.Alt ((<|>))
-- import Control.Plus (empty)
import GenericParser.Parser (Parser(..) import GenericParser.Parser (Parser(..)
, success, failError , success, failureError
, current_position , current_position
, alphanum, char, letter, many1, parse, string) , alphanum, char, letter, many1, parse, string)
@ -37,41 +36,35 @@ let_dig_hyp = let_dig <|> char '-'
ldh_str :: forall e. Parser e (Array Char) ldh_str :: forall e. Parser e (Array Char)
ldh_str = many1 let_dig_hyp ldh_str = many1 let_dig_hyp
-- TODO: 63 -- | WARNING: Verify the actual maximum length for a label.
label_maxsize :: Int -- | Current maximum accepted length for a label is 63.
label_maxsize = 7 max_label_length :: Int
max_label_length = 63
-- TODO: 255? -- | WARNING: Verify the actual maximum length for a domain.
-- | Current maximum accepted length for a domain is 255.
max_domain_length :: Int max_domain_length :: Int
max_domain_length = 15 max_domain_length = 255
last_char :: String -> Maybe Char
last_char = A.last <<< CU.toCharArray
parse_last_char :: forall e. String -> Parser e Char -> Boolean
parse_last_char s p = case last_char s of
Nothing -> false
Just c -> case parse p { string: CU.singleton c, position: 0 } of
Left _ -> false
_ -> true
-- | `tryMaybe` provides a way to accept a faulty parser and -- | `tryMaybe` provides a way to accept a faulty parser and
-- | just rewinds back to previous input state if an error occurs. -- | just rewinds back to previous input state if an error occurs.
tryMaybe :: forall e a. Parser e a -> Parser e (Maybe a) tryMaybe :: forall e a. Parser e a -> Parser e (Maybe a)
tryMaybe p = Parser p' tryMaybe p = Parser p'
where p' input = case parse p input of where p' input = case parse p input of
Left _ -> Right { suffix: input, result: Nothing } Left _ -> success input Nothing
Right { suffix, result } -> Right { suffix, result: Just result } Right { suffix, result } -> success suffix (Just result)
-- | `try` provides a way to accept a faulty parser and -- | `try` provides a way to accept a faulty parser and
-- | just rewinds back to previous input state if a non-specific error occurs. -- | just rewinds back to previous input state if a non-specific error occurs.
-- | The difference with `tryMaybe` is that `try` will forward the error if it is
-- | a specific one, meanning that `error` isn't `Nothing`.
try :: forall e a. Parser e a -> Parser e (Maybe a) try :: forall e a. Parser e a -> Parser e (Maybe a)
try p = Parser p' try p = Parser p'
where p' input = case parse p input of where p' input = case parse p input of
Right { suffix, result } -> success suffix (Just result)
Left { position, error } -> case error of Left { position, error } -> case error of
Nothing -> Right { suffix: input, result: Nothing } Nothing -> success input Nothing
_ -> Left { position, error } _ -> failureError position error
Right { suffix, result } -> Right { suffix, result: Just result }
-- | From RFC 1035: <label> ::= <letter> [ [ <ldh-str> ] <let-dig> ] -- | From RFC 1035: <label> ::= <letter> [ [ <ldh-str> ] <let-dig> ]
label :: Parser DomainError String label :: Parser DomainError String
@ -79,16 +72,28 @@ label = do
pos <- current_position pos <- current_position
maybel <- tryMaybe letter maybel <- tryMaybe letter
case maybel of case maybel of
Nothing -> Parser \_ -> failError pos (Just InvalidCharacter) Nothing -> Parser \_ -> failureError pos (Just InvalidCharacter)
Just l -> do Just l -> do
s <- tryMaybe ldh_str s <- tryMaybe ldh_str
lastpos <- current_position lastpos <- current_position
let labelstr = CU.singleton l <> maybe "" CU.fromCharArray s let labelstr = CU.singleton l <> maybe "" CU.fromCharArray s
if (S.length labelstr > label_maxsize) if (S.length labelstr > max_label_length)
then Parser \_ -> failError pos (Just <<< SubdomainTooLarge $ S.length labelstr) then Parser \_ -> failureError pos (Just <<< SubdomainTooLarge $ S.length labelstr)
else if (S.length labelstr > 1 && not (parse_last_char labelstr let_dig)) else if (S.length labelstr > 1 && not (parse_last_char labelstr let_dig))
then Parser \_ -> failError (lastpos - 1) (Just InvalidCharacter) then Parser \_ -> failureError (lastpos - 1) (Just InvalidCharacter)
else pure labelstr else pure labelstr
where
-- Get the last character of a String.
last_char :: String -> Maybe Char
last_char = A.last <<< CU.toCharArray
-- Parse the last character of a String.
parse_last_char :: forall e. String -> Parser e Char -> Boolean
parse_last_char s p = case last_char s of
Nothing -> false
Just c -> case parse p { string: CU.singleton c, position: 0 } of
Left _ -> false
_ -> true
-- | From RFC 1035: <subdomain> ::= <label> | <subdomain> "." <label> -- | From RFC 1035: <subdomain> ::= <label> | <subdomain> "." <label>
subdomain :: Parser DomainError String subdomain :: Parser DomainError String
@ -108,7 +113,7 @@ subdomain = do
eof :: Parser DomainError String eof :: Parser DomainError String
eof = Parser \input -> case S.length input.string of eof = Parser \input -> case S.length input.string of
0 -> success input "" 0 -> success input ""
_ -> failError input.position (Just EOFExpected) _ -> failureError input.position (Just EOFExpected)
-- | Test for the domain to be a list of subdomains then an end-of-file. -- | Test for the domain to be a list of subdomains then an end-of-file.
-- | Said otherwise, the input must only contain a domain (with or without a final dot '.'). -- | Said otherwise, the input must only contain a domain (with or without a final dot '.').
@ -120,7 +125,7 @@ sub_eof = do
pos <- current_position pos <- current_position
let parsed_domain = did_we_parse_the_final_point maybe_final_point sub let parsed_domain = did_we_parse_the_final_point maybe_final_point sub
if S.length parsed_domain > max_domain_length if S.length parsed_domain > max_domain_length
then Parser \_ -> failError pos (Just <<< DomainTooLarge $ S.length parsed_domain) then Parser \_ -> failureError pos (Just <<< DomainTooLarge $ S.length parsed_domain)
else pure parsed_domain else pure parsed_domain
where where
did_we_parse_the_final_point Nothing sub = sub did_we_parse_the_final_point Nothing sub = sub

View File

@ -5,10 +5,9 @@ import Control.Alt (class Alt, (<|>))
import Control.Alternative (class Alternative) import Control.Alternative (class Alternative)
import Control.Lazy (class Lazy) import Control.Lazy (class Lazy)
import Control.Plus (class Plus, empty) import Control.Plus (class Plus, empty)
import Data.Array as A import Data.Array as A
import Data.Int as Int
import Data.Either (Either(..)) import Data.Either (Either(..))
import Data.Int as Int
import Data.Maybe (Maybe(..)) import Data.Maybe (Maybe(..))
import Data.String.CodeUnits (toCharArray, fromCharArray) import Data.String.CodeUnits (toCharArray, fromCharArray)
@ -32,16 +31,16 @@ current_position = Parser \input -> success input input.position
-- | Fail with a specified error. -- | Fail with a specified error.
-- | When a parsing has a specified error, no alternative will be tried and the error is reported. -- | When a parsing has a specified error, no alternative will be tried and the error is reported.
failError :: forall e v. Position -> Maybe e -> Result e v failureError :: forall e v. Position -> Maybe e -> Result e v
failError position error = Left { position, error } failureError position error = Left { position, error }
-- | Fail without a specified error. -- | Fail without a specified error.
-- | This is used in generic parsers not attached to a specified context, -- | This is used in generic parsers not attached to a specified context,
-- | such as `digit` or `letter`. -- | such as `digit` or `letter`.
-- | Also, this can be used to express a possibly expected invalid parsing that should not -- | Also, this can be used to express a possibly expected invalid parsing that should not
-- | halt the parsing, but rather let an alternative path to be tried. -- | halt the parsing, but rather let an alternative path to be tried.
fail :: forall e v. Position -> Result e v failure :: forall e v. Position -> Result e v
fail position = failError position Nothing failure position = failureError position Nothing
-- | `success` constructs a result value for a successful parsing. -- | `success` constructs a result value for a successful parsing.
-- | It requires the input (a string with its current position) and the result. -- | It requires the input (a string with its current position) and the result.
@ -53,7 +52,7 @@ item :: forall e. Parser e Char
item = Parser p item = Parser p
where where
p input = case A.uncons (toCharArray input.string) of p input = case A.uncons (toCharArray input.string) of
Nothing -> fail input.position Nothing -> failure input.position
Just { head: x, tail: xs } -> success { string: (fromCharArray xs), position: input.position+1 } x Just { head: x, tail: xs } -> success { string: (fromCharArray xs), position: input.position+1 } x
instance functorParser :: Functor (Parser e) where instance functorParser :: Functor (Parser e) where
@ -87,12 +86,12 @@ instance altParser :: Alt (Parser e) where
p stream = case p1 stream of p stream = case p1 stream of
Left { position, error } -> case error of Left { position, error } -> case error of
Nothing -> p2 stream Nothing -> p2 stream
_ -> failError position error _ -> failureError position error
Right right -> Right right Right right -> Right right
instance plusParser :: Plus (Parser e) where instance plusParser :: Plus (Parser e) where
empty :: forall v. Parser e v empty :: forall v. Parser e v
empty = Parser \input -> fail input.position empty = Parser \input -> failure input.position
instance alternativeParser :: Alternative (Parser e) instance alternativeParser :: Alternative (Parser e)