Baguette/parser
3
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Errors are being reported. Need to catch them all!

Browse Source
This commit is contained in:
Philippe Pittoli 2024-01-18 07:13:40 +01:00
parent 1ef64aafc2
commit e134f55daa
3 changed files with 106 additions and 101 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
src/DomainParser.purs
View File

@ -1,10 +1,10 @@
-- | `DomainParser` is a simple parser for domain names as described in RFC 1035. -- | `DomainParser` is a simple parser for domain names as described in RFC 1035.
module DomainParser where module DomainParser where
import Prelude (bind, not, pure, ($), (&&), (*>), (<<<), (<>), (==), (>)) import Prelude (bind, not, pure, ($), (&&), (*>), (<<<), (<>), (>))
import Control.Lazy (defer) import Control.Lazy (defer)
import Data.Maybe (Maybe(..)) import Data.Maybe (Maybe(..), maybe)
import Data.Either (Either(..)) import Data.Either (Either(..))
import Data.Array as A import Data.Array as A
import Data.String as S import Data.String as S
@ -13,7 +13,8 @@ import Control.Alt ((<|>))
import Control.Plus (empty) import Control.Plus (empty)
import Parser (Parser(..), Position import Parser (Parser(..), Position
, success, fail, failError , success, failError
, current_position
, alphanum, char, letter, many1, parse, string) , alphanum, char, letter, many1, parse, string)
type Size = Int type Size = Int
@ -54,11 +55,8 @@ parse_last_char s p = case last_char s of
Left _ -> false Left _ -> false
_ -> true _ -> true
-- | FIXME: This is flawed. -- | `try` provides a way to accept a faulty parser and
-- | We cannot know if it worked: in case there is a problem with the parser `p`, -- | just rewinds back to previous input state if an error occurs.
-- | the code will "continue to work" but without what's been parsed.
-- | This may sound reasonable but it prevents knowing if a problem actually occured!
-- | We cannot do a `try parser <|> alternative` since it will always work!
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
@ -70,9 +68,7 @@ label :: forall e. Parser e String
label = do label = do
l <- letter l <- letter
s <- try ldh_str s <- try ldh_str
let labelstr = CU.singleton l <> case s of let labelstr = CU.singleton l <> maybe "" (\v -> CU.fromCharArray v) s
Nothing -> ""
Just content -> CU.fromCharArray content
if (S.length labelstr > label_maxsize) if (S.length labelstr > label_maxsize)
then empty then empty
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))
@ -106,9 +102,10 @@ sub_eof = do
sub <- subdomain sub <- subdomain
maybe_final_point <- try $ char '.' maybe_final_point <- try $ char '.'
_ <- eof -- In case there is still some input, it fails. _ <- eof -- In case there is still some input, it fails.
pos <- current_position
let parsed_domain = did_we_parsed_the_final_point maybe_final_point sub let parsed_domain = did_we_parsed_the_final_point maybe_final_point sub
if S.length parsed_domain > max_domain_length if S.length parsed_domain > max_domain_length
then empty -- TODO: error management. then Parser \_ -> failError pos (Just <<< DomainTooLarge $ S.length parsed_domain)
else pure parsed_domain else pure parsed_domain
where where
did_we_parsed_the_final_point Nothing sub = sub did_we_parsed_the_final_point Nothing sub = sub

180
src/Main.purs
View File

@ -1,7 +1,7 @@
module Main where module Main where
import Parser (Parser(..)) import Parser (Parser(..))
import DomainParser (domain, label, ldh_str, sub_eof, subdomain) import DomainParser (domain, label, ldh_str, sub_eof, subdomain, DomainError(..))
import Prelude (Unit, discard, show, ($), (<>)) import Prelude (Unit, discard, show, ($), (<>))
@ -9,7 +9,7 @@ import Effect (Effect)
import Effect.Console (log) import Effect.Console (log)
import Data.Either (Either(..)) import Data.Either (Either(..))
--import Data.Maybe (Maybe(..)) import Data.Maybe (Maybe(..))
--import Data.Tuple (Tuple(..)) --import Data.Tuple (Tuple(..))
import Data.String.CodeUnits (fromCharArray) import Data.String.CodeUnits (fromCharArray)
@ -39,112 +39,120 @@ import Data.String.CodeUnits (fromCharArray)
-- let toprint = if b then "FOUND IT" else "not found" -- let toprint = if b then "FOUND IT" else "not found"
-- log $ toprint <> ", rest: " <> str -- log $ toprint <> ", rest: " <> str
logtest :: forall e v. String -> Parser e v -> String -> (v -> String) -> Effect Unit logtest :: forall e v. String -> Parser e v -> String -> (v -> String) -> (e -> String) -> Effect Unit
logtest fname (Parser p) str r = do logtest fname (Parser p) str r e = do
log $ "(" <> fname <> ") parsing '" <> str <> "': " log $ "(" <> fname <> ") parsing '" <> str <> "': "
<> case p { string: str, position: 0 } of <> case p { string: str, position: 0 } of
Left { position, error: _ } -> "failed at position " <> show position Left { position, error } -> "failed at position " <> show position <> case error of
Nothing -> " -> no error reported"
Just err -> " -> error: " <> e err
Right { suffix, result } -> show (r result) <> " '" <> suffix.string <> "'" Right { suffix, result } -> show (r result) <> " '" <> suffix.string <> "'"
id :: forall a. a -> a id :: forall a. a -> a
id a = a id a = a
showerror :: DomainError -> String
showerror (SubdomainTooLarge position size) = "SubdomainTooLarge (position: " <> show position <> ", size: " <> show size <> ")"
showerror (DomainTooLarge size) = "DomainTooLarge (size: " <> show size <> ")"
showerror (InvalidCharacter position) = "InvalidCharacter (position: " <> show position <> ")"
showerror (EOFExpected) = "EOFExpected"
main :: Effect Unit main :: Effect Unit
main = do main = do
logtest "ldh_str" ldh_str "a12B.fl" fromCharArray logtest "ldh_str" ldh_str "a12B.fl" fromCharArray showerror
logtest "ldh_str" ldh_str "1efg.x1" fromCharArray logtest "ldh_str" ldh_str "1efg.x1" fromCharArray showerror
logtest "ldh_str" ldh_str ".qjzleb" fromCharArray logtest "ldh_str" ldh_str ".qjzleb" fromCharArray showerror
logtest "ldh_str" ldh_str "a-b.b-a" fromCharArray logtest "ldh_str" ldh_str "a-b.b-a" fromCharArray showerror
logtest "ldh_str" ldh_str "" fromCharArray logtest "ldh_str" ldh_str "" fromCharArray showerror
log "" log ""
logtest "label" label "example.org" id logtest "label" label "example.org" id showerror
logtest "label" label "" id logtest "label" label "" id showerror
logtest "label" label "a.x" id logtest "label" label "a.x" id showerror
logtest "label" label "a2.org" id logtest "label" label "a2.org" id showerror
logtest "label" label "a33.org" id logtest "label" label "a33.org" id showerror
logtest "label" label "a444.org" id logtest "label" label "a444.org" id showerror
logtest "label" label "a5555.org" id logtest "label" label "a5555.org" id showerror
logtest "label" label "a66666.org" id logtest "label" label "a66666.org" id showerror
logtest "label" label "a777777.org" id logtest "label" label "a777777.org" id showerror
logtest "label" label "a8888888.org" id logtest "label" label "a8888888.org" id showerror
log "" log ""
logtest "label" label "-" id logtest "label" label "-" id showerror
logtest "label" label "a-" id logtest "label" label "a-" id showerror
log "" log ""
logtest "subdomain" subdomain "example.org" id logtest "subdomain" subdomain "example.org" id showerror
logtest "subdomain" subdomain "" id logtest "subdomain" subdomain "" id showerror
logtest "subdomain" subdomain "a.x" id logtest "subdomain" subdomain "a.x" id showerror
logtest "subdomain" subdomain "a2.org" id logtest "subdomain" subdomain "a2.org" id showerror
logtest "subdomain" subdomain "a33.org" id logtest "subdomain" subdomain "a33.org" id showerror
logtest "subdomain" subdomain "a444.org" id logtest "subdomain" subdomain "a444.org" id showerror
logtest "subdomain" subdomain "a5555.org" id logtest "subdomain" subdomain "a5555.org" id showerror
logtest "subdomain" subdomain "a66666.org" id logtest "subdomain" subdomain "a66666.org" id showerror
logtest "subdomain" subdomain "a777777.org" id logtest "subdomain" subdomain "a777777.org" id showerror
logtest "subdomain" subdomain "a8888888.org" id logtest "subdomain" subdomain "a8888888.org" id showerror
logtest "subdomain" subdomain "xblah.a.x" id logtest "subdomain" subdomain "xblah.a.x" id showerror
logtest "subdomain" subdomain "xblah.a2.org" id logtest "subdomain" subdomain "xblah.a2.org" id showerror
logtest "subdomain" subdomain "xblah.a33.org" id logtest "subdomain" subdomain "xblah.a33.org" id showerror
logtest "subdomain" subdomain "xblah.a444.org" id logtest "subdomain" subdomain "xblah.a444.org" id showerror
logtest "subdomain" subdomain "xblah.a5555.org" id logtest "subdomain" subdomain "xblah.a5555.org" id showerror
logtest "subdomain" subdomain "xblah.a66666.org" id logtest "subdomain" subdomain "xblah.a66666.org" id showerror
logtest "subdomain" subdomain "xblah.a777777.org" id logtest "subdomain" subdomain "xblah.a777777.org" id showerror
logtest "subdomain" subdomain "xblah.a8888888.org" id logtest "subdomain" subdomain "xblah.a8888888.org" id showerror
logtest "subdomain" subdomain "-" id logtest "subdomain" subdomain "-" id showerror
logtest "subdomain" subdomain "a-" id logtest "subdomain" subdomain "a-" id showerror
log "" log ""
logtest "sub_eof" sub_eof " " id logtest "sub_eof" sub_eof " " id showerror
logtest "sub_eof" sub_eof " " id logtest "sub_eof" sub_eof " " id showerror
logtest "sub_eof" sub_eof "example.org" id logtest "sub_eof" sub_eof "example.org" id showerror
logtest "sub_eof" sub_eof "" id logtest "sub_eof" sub_eof "" id showerror
logtest "sub_eof" sub_eof "a.x" id logtest "sub_eof" sub_eof "a.x" id showerror
logtest "sub_eof" sub_eof "a2.org" id logtest "sub_eof" sub_eof "a2.org" id showerror
logtest "sub_eof" sub_eof "a33.org" id logtest "sub_eof" sub_eof "a33.org" id showerror
logtest "sub_eof" sub_eof "a444.org" id logtest "sub_eof" sub_eof "a444.org" id showerror
logtest "sub_eof" sub_eof "a5555.org" id logtest "sub_eof" sub_eof "a5555.org" id showerror
logtest "sub_eof" sub_eof "a66666.org" id logtest "sub_eof" sub_eof "a66666.org" id showerror
logtest "sub_eof" sub_eof "a777777.org" id logtest "sub_eof" sub_eof "a777777.org" id showerror
logtest "sub_eof" sub_eof "a8888888.org" id logtest "sub_eof" sub_eof "a8888888.org" id showerror
logtest "sub_eof" sub_eof "xblah.a.x" id logtest "sub_eof" sub_eof "xblah.a.x" id showerror
logtest "sub_eof" sub_eof "xblah.a2.org" id logtest "sub_eof" sub_eof "xblah.a2.org" id showerror
logtest "sub_eof" sub_eof "xblah.a33.org" id logtest "sub_eof" sub_eof "xblah.a33.org" id showerror
logtest "sub_eof" sub_eof "xblah.a444.org" id logtest "sub_eof" sub_eof "xblah.a444.org" id showerror
logtest "sub_eof" sub_eof "xblah.a5555.org" id logtest "sub_eof" sub_eof "xblah.a5555.org" id showerror
logtest "sub_eof" sub_eof "xblah.a66666.org" id logtest "sub_eof" sub_eof "xblah.a66666.org" id showerror
logtest "sub_eof" sub_eof "xblah.a777777.org" id logtest "sub_eof" sub_eof "xblah.a777777.org" id showerror
logtest "sub_eof" sub_eof "xblah.a8888888.org" id logtest "sub_eof" sub_eof "xblah.a8888888.org" id showerror
logtest "sub_eof" sub_eof "-" id logtest "sub_eof" sub_eof "-" id showerror
logtest "sub_eof" sub_eof "a-" id logtest "sub_eof" sub_eof "a-" id showerror
log "" log ""
logtest "domain" domain " " id logtest "domain" domain " " id showerror
logtest "domain" domain " " id logtest "domain" domain " " id showerror
logtest "domain" domain "example.org" id logtest "domain" domain "example.org" id showerror
logtest "domain" domain "" id logtest "domain" domain "" id showerror
logtest "domain" domain "a.x" id logtest "domain" domain "a.x" id showerror
logtest "domain" domain "a2.org" id logtest "domain" domain "a2.org" id showerror
logtest "domain" domain "a33.org" id logtest "domain" domain "a33.org" id showerror
logtest "domain" domain "a444.org" id logtest "domain" domain "a444.org" id showerror
logtest "domain" domain "a5555.org" id logtest "domain" domain "a5555.org" id showerror
logtest "domain" domain "a66666.org" id logtest "domain" domain "a66666.org" id showerror
logtest "domain" domain "a777777.org" id logtest "domain" domain "a777777.org" id showerror
logtest "domain" domain "a8888888.org" id logtest "domain" domain "a8888888.org" id showerror
logtest "domain" domain "xblah.a.x" id logtest "domain" domain "xblah.a.x" id showerror
logtest "domain" domain "xblah.a2.org" id logtest "domain" domain "xblah.a2.org" id showerror
logtest "domain" domain "xblah.a33.org" id logtest "domain" domain "xblah.a33.org" id showerror
logtest "domain" domain "xblah.a444.org" id logtest "domain" domain "xblah.a444.org" id showerror
logtest "domain" domain "xblah.a5555.org" id logtest "domain" domain "xblah.a5555.org" id showerror
logtest "domain" domain "xblah.a66666.org" id logtest "domain" domain "xblah.a66666.org" id showerror
logtest "domain" domain "xblah.a777777.org" id logtest "domain" domain "xblah.a777777.org" id showerror
logtest "domain" domain "xblah.a8888888.org" id logtest "domain" domain "xblah.a8888888.org" id showerror
logtest "domain" domain "-" id logtest "domain" domain "-" id showerror
logtest "domain" domain "a-" id logtest "domain" domain "a-" id showerror
-- log $ "parsing the first 'f' in 'fiction' (sat): " <> case parse (sat (\x -> x == 'f')) "fiction" of -- log $ "parsing the first 'f' in 'fiction' (sat): " <> case parse (sat (\x -> x == 'f')) "fiction" of
-- Just (Tuple x y) -> show x <> " " <> show y -- Just (Tuple x y) -> show x <> " " <> show y

6
src/Parser.purs
View File

@ -11,7 +11,6 @@ import Data.Int as Int
import Data.Either (Either(..)) import Data.Either (Either(..))
import Data.Maybe (Maybe(..)) import Data.Maybe (Maybe(..))
import Data.String.CodeUnits (toCharArray, fromCharArray) import Data.String.CodeUnits (toCharArray, fromCharArray)
-- import Data.Tuple (Tuple(..))
import BaseFunctions (concat, isAlpha, isAlphaNum, isDigit, isLower, isSpace, isUpper) import BaseFunctions (concat, isAlpha, isAlphaNum, isDigit, isLower, isSpace, isUpper)
@ -28,9 +27,11 @@ newtype Parser e v = Parser (Input -> Result e v)
parse :: forall e v. Parser e v -> (Input -> Result e v) parse :: forall e v. Parser e v -> (Input -> Result e v)
parse (Parser p) = p parse (Parser p) = p
current_position :: forall e. Parser e Position
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.
-- TODO: stop the parsing when an error is provided.
failError :: forall e v. Position -> Maybe e -> Result e v failError :: forall e v. Position -> Maybe e -> Result e v
failError position error = Left { position, error } failError position error = Left { position, error }
@ -39,7 +40,6 @@ failError position error = Left { position, error }
-- | 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.
-- TODO: stop the parsing when an error is provided.
fail :: forall e v. Position -> Result e v fail :: forall e v. Position -> Result e v
fail position = failError position Nothing fail position = failError position Nothing