diff --git a/changelog.txt b/changelog.txt --- a/changelog.txt +++ b/changelog.txt @@ -24,3 +24,14 @@ + generalised `within` + different whitespace and comment handling in predefined lexer + predefined lexer handles (nested) comment-blocks + +0.4.0.2 -> 0.4.0.3 + M added hex, octal and binary representation to integer literals + + added float literals + + exporting `preferably` and `reluctantly` + M renamed `rassoc` to shortest_match + M renamed `lassoc` to longest_match + - removed `assoc` + + version of `chooses` that is left-biased (w.r.t. alternatives) + + generalised arguments of longest_match and shortest_match to IsAltExpr + + exporting `optionalWithDef` diff --git a/gll.cabal b/gll.cabal --- a/gll.cabal +++ b/gll.cabal @@ -3,7 +3,7 @@ -- The name of the package. name: gll -version: 0.4.0.2 +version: 0.4.0.3 synopsis: GLL parser with simple combinator interface license: BSD3 license-file: LICENSE diff --git a/src/GLL/Combinators/Interface.hs b/src/GLL/Combinators/Interface.hs --- a/src/GLL/Combinators/Interface.hs +++ b/src/GLL/Combinators/Interface.hs @@ -182,7 +182,7 @@ -- * Elementary parsers term_parser, satisfy, -- ** Elementary parsers using the 'Token' datatype - keychar, keyword, int_lit, bool_lit, char_lit, string_lit, alt_id_lit, id_lit, token, + keychar, keyword, int_lit, float_lit, bool_lit, char_lit, string_lit, alt_id_lit, id_lit, token, -- ** Elementary character-level parsers char, -- * Elementary combinators @@ -193,7 +193,7 @@ -- *** Semantic actions (<$$>), -- *** Nonterminal introduction - (<:=>),(<::=>),chooses, + (<:=>),(<::=>),chooses,chooses_prec, -- * Types -- ** Grammar (combinator expression) types BNF, SymbExpr, AltExpr, AltExprs, @@ -223,11 +223,12 @@ -- *** Ignoring semantic results (<$$), (**>), (<**), -- *** EBNF patterns - optional, multiple, multiple1, multipleSepBy, multipleSepBy1, + optional, preferably, reluctantly, optionalWithDef, + multiple, multiple1, multipleSepBy, multipleSepBy1, multipleSepBy2, within, parens, braces, brackets, angles, -- *** Disambiguation (<:=), (<::=),(<<<**>), (<**>>>), (<<**>), (<<<**), (**>>>), (<**>>), - rassoc, lassoc, assoc, + longest_match,shortest_match, many, many1, some, some1, manySepBy, manySepBy1, manySepBy2, someSepBy, someSepBy1,someSepBy2, @@ -348,10 +349,15 @@ (<::=>) :: (Show t, Ord t, HasAlts b) => String -> b t a -> SymbExpr t a x <::=> altPs = mkNtRule True False x altPs --- | Variant of <::=> that can be supplied with a list of alternates -chooses :: (Show t, Ord t) => String -> [AltExpr t a] -> SymbExpr t a -chooses p alts = (<::=>) p (OO alts) +-- | Variant of '<::=>' that can be supplied with a list of alternates +chooses :: (Show t, Ord t, IsAltExpr alt) => String -> [alt t a] -> SymbExpr t a +chooses p alts = (<::=>) p (OO (map toAlt alts)) +-- | Variant of '<::=' that can be supplied with a list of alternates +chooses_prec :: (Show t, Ord t, IsAltExpr alt) => String -> [alt t a] -> SymbExpr t a +chooses_prec p alts = (<::=) p (OO (map toAlt alts)) + + infixl 4 <$$> -- | -- Form an 'AltExpr' by mapping some semantic action overy the result @@ -390,22 +396,17 @@ in OO (l : r) -- | --- Apply this combinator to an alternative to indicate that the alternative --- is for a left-associative operator. Used for top-down disambiguation. -lassoc :: AltExpr t a -> AltExpr t a -lassoc (AltExpr (v1,v2,v3)) = AltExpr (v1,v2,\opts -> v3 (maximumPivot opts)) - --- | --- Apply this combinator to an alternative to indicate that the alternative --- is for a right-associative operator. Used for top-down disambiguation. -rassoc :: AltExpr t a -> AltExpr t a -rassoc (AltExpr (v1,v2,v3)) = AltExpr (v1,v2,\opts -> v3 (minimumPivot opts)) +-- Apply this combinator to an alternative to turn all underlying occurrences +-- of '<**>' (or variants) apply 'longest match'. +longest_match :: (Show t, Ord t, IsAltExpr alt) => alt t a -> AltExpr t a +longest_match isalt = AltExpr (v1,v2,\opts -> v3 (maximumPivot opts)) + where AltExpr (v1,v2,v3) = toAlt isalt --- | --- Apply this combinator to an alternative to indicate that the alternative --- is for an associative operator. Used for top-down disambiguation. -assoc :: AltExpr t a -> AltExpr t a -assoc = lassoc +-- Apply this combinator to an alternative to turn all underlying occurrences +-- of '<**>' (or variants) apply 'shortest match'. +shortest_match :: (Show t, Ord t, IsAltExpr alt) => alt t a -> AltExpr t a +shortest_match isalt = AltExpr (v1,v2,\opts -> v3 (minimumPivot opts)) + where AltExpr (v1,v2,v3) = toAlt isalt -- | Create a symbol-parse for a terminal given: -- @@ -458,6 +459,13 @@ where unwrap (Just (IntLit (Just i))) = i unwrap _ = error "int_lit: downcast, or token without lexeme" +-- | Parse a single floating point literal, using a 'SubsumesToken' type. +-- Returns the lexeme interpreted as a 'Double'. +float_lit :: SubsumesToken t => SymbExpr t Double +float_lit = term_parser (upcast (FloatLit Nothing)) (unwrap . downcast) + where unwrap (Just (FloatLit (Just i))) = i + unwrap _ = error "float_lit: downcast, or token without lexeme" + -- | Parse a single Boolean, using a 'SubsumesToken' type. -- Returns the lexeme interpreter as a Boolean. bool_lit :: SubsumesToken t => SymbExpr t Bool @@ -687,11 +695,31 @@ manySepBy2 p s = mkRule $ (:) <$$> p <** s <**> manySepBy1 p s --- | Make a piece of BNF optional, but proceed if unsuccessful --- (yielding 'Nothing' as a result in that case). +-- | Derive either from the given symbol or the empty string. optional :: (Show t, Ord t, IsSymbExpr s) => s t a -> SymbExpr t (Maybe a) -optional p = let fresh = mkNt p "?" - in fresh <::=> Just <$$> p <||> satisfy Nothing +optional p = fresh + <:=> Just <$$> p + <||> satisfy Nothing + where fresh = mkNt p "?" + +-- | Version of 'optional' that prefers to derive from the given symbol +-- affects only nullable nonterminal symbols +preferably :: (Show t, Ord t, IsSymbExpr s) => s t a -> SymbExpr t (Maybe a) +preferably p = fresh + <:= Just <$$> p + <||> satisfy Nothing + where fresh = mkNt p "?" + +-- | Version of 'optional' that prefers to derive the empty string from +-- the given symbol, effects only nullable nonterminal symbols +reluctantly :: (Show t, Ord t, IsSymbExpr s) => s t a -> SymbExpr t (Maybe a) +reluctantly p = fresh + <:= satisfy Nothing + <||> Just <$$> p + where fresh = mkNt p "?" + +optionalWithDef :: (Show t, Ord t, IsSymbExpr s) => s t a -> a -> SymbExpr t a +optionalWithDef p def = mkNt p "?" <:=> id <$$> p <||> satisfy def -- | Place a piece of BNF /within/ two other BNF fragments, ignoring their semantics. within :: IsSymbExpr s => BNF Token a -> s Token b -> BNF Token c -> BNF Token b diff --git a/src/GLL/Combinators/Lexer.hs b/src/GLL/Combinators/Lexer.hs --- a/src/GLL/Combinators/Lexer.hs +++ b/src/GLL/Combinators/Lexer.hs @@ -1,12 +1,14 @@ module GLL.Combinators.Lexer ( default_lexer, lexer, LexerSettings(..), emptyLanguage, + oneOf, manyOf, someOf, baseToDec, ) where import GLL.Types.Grammar (Token(..), SubsumesToken(..)) import Data.List (isPrefixOf) import Data.Char (isSpace, isDigit, isAlpha, isUpper, isLower) import Text.Regex.Applicative +import Text.Regex.Applicative.Common (signed) -- | Settings for changing the behaviour of the builtin lexer 'lexer'. -- Lexers are built using "Text.Regex.Applicative". @@ -73,30 +75,89 @@ lTokens lexsets = lCharacters <|> lKeywords - <|> charsToInt <$> optional (sym '-') <*> some (psym isDigit) + <|> upcast . IntLit . Just <$> lIntegers + <|> upcast . FloatLit . Just <$> lFloats <|> upcast . IDLit . Just <$> identifiers lexsets <|> upcast . AltIDLit . Just <$> altIdentifiers lexsets <|> upcast . CharLit . Just <$> lCharLit <|> upcast . StringLit . Just <$> lStringLit <|> lMore - where - charsToInt Nothing n = upcast (IntLit (Just (read n))) - charsToInt (Just _) n = upcast (IntLit (Just (-(read n)))) + where lMore = foldr ((<|>) . uncurry lToken) empty (tokens lexsets) lChar c = upcast (Char c) <$ sym c - lCharacters = foldr ((<|>) . lChar) empty (keychars lexsets) + lCharacters = foldr ((<|>) . lChar) empty (keychars lexsets) lKeyword k = upcast (Keyword k) <$ string k lKeywords = foldr ((<|>) . lKeyword) empty (keywords lexsets) - lMore = foldr ((<|>) . uncurry lToken) empty (tokens lexsets) - lToken t re = upcast . Token t . Just <$> re +lToken t re = upcast . Token t . Just <$> re - lStringLit = toString <$ sym '\"' <*> many strChar <* sym '\"' - where strChar = sym '\\' *> sym '\"' - <|> psym ((/=) '\"') - toString inner = read ("\"" ++ inner ++ "\"") +lStringLit = toString <$ sym '\"' <*> many strChar <* sym '\"' + where strChar = sym '\\' *> sym '\"' + <|> psym ((/=) '\"') + toString inner = read ("\"" ++ inner ++ "\"") - lCharLit = id <$ sym '\'' <*> charChar <* sym '\'' - where charChar = sym '\\' *> sym '\'' - <|> psym ((/=) '\'') +lCharLit = id <$ sym '\'' <*> charChar <* sym '\'' + where charChar = sym '\\' *> sym '\'' + <|> psym ((/=) '\'') + +lFloats :: RE Char Double +lFloats = signed ( read <$> ( + mkDP <$> decimal <*> sym '.' <*> decimal <*> optional exponent + <|> mkEP <$> decimal <*> exponent + )) + where mkDP pre _ post mexp = pre ++ "." ++ post ++ maybe "" id mexp + mkEP pre exp = pre ++ exp + + exponent = mk <$> (sym 'e' <|> sym 'E') + <*> optional (sym '+' <|> sym '-') + <*> decimal + where mk pre sign dec = pre : maybe "" (:[]) sign ++ dec + +lIntegers :: RE Char Int +lIntegers = signed ( + (read <$> decimal) + <|> (baseToDec 16 <$ hexPrefix <*> someOf (['0'..'9']++['A'..'F']++['a'..'f'])) + <|> (baseToDec 8 <$ octPrefix <*> someOf ['0'..'7']) + <|> (baseToDec 2 <$ binPrefix <*> someOf ['0','1']) + ) + where hexPrefix = string "0x" <|> string "0X" + octPrefix = string "0o" <|> string "0O" + binPrefix = string "0b" <|> string "0B" + +decimal :: RE Char String +decimal = someOf ['0'..'9'] + +-- | Convert numerical representation in a given base +-- (max base = 16, written as string) +-- into decimal representation (returned as Int) +baseToDec :: Int -> String -> Int +baseToDec base = baseToDec' 0 base . map toInt + where baseToDec' acc base [] = acc + baseToDec' acc base (d:ds) = baseToDec' (acc * base + d) base ds + toInt c | c == 'A' || c == 'a' = 10 + | c == 'B' || c == 'b' = 11 + | c == 'C' || c == 'c' = 12 + | c == 'D' || c == 'd' = 13 + | c == 'E' || c == 'e' = 14 + | c == 'F' || c == 'f' = 15 + | otherwise = read [c] + +oneOf :: Eq t => [t] -> RE t t +oneOf ts = psym (\t -> t `elem` ts) + +manyOf :: Eq t => [t] -> RE t [t] +manyOf ts = many (oneOf ts) + +someOf :: Eq t => [t] -> RE t [t] +someOf ts = some (oneOf ts) + +{- + +manyOf :: Eq t => [t] -> RE t [t] +manyOf ts = empty <|> someOf ts + +someOf :: Eq t => [t] -> RE t [t] +someOf ts = (:) <$> oneOf ts <*> manyOf ts + +-} diff --git a/src/GLL/Types/Grammar.hs b/src/GLL/Types/Grammar.hs --- a/src/GLL/Types/Grammar.hs +++ b/src/GLL/Types/Grammar.hs @@ -52,6 +52,7 @@ | EOS | Epsilon | IntLit (Maybe Int) + | FloatLit (Maybe Double) | BoolLit (Maybe Bool) | StringLit (Maybe String) | CharLit (Maybe Char) @@ -93,23 +94,25 @@ instance SubsumesToken Token where upcast = id - downcast = Just . id + downcast = Just deriving instance Ord Token deriving instance Eq Token instance Show Token where - show (Char c) = "char('" ++ [c] ++ "')" + show (Char c) = "keychar('" ++ [c] ++ "')" show (Keyword s) = "keyword(\"" ++ s ++ "\")" show (EOS) = "" show (Epsilon) = "" show (IntLit (Just i)) = "int(" ++ show i ++ ")" show (IntLit _) = "" + show (FloatLit (Just i)) = "float(" ++ show i ++ ")" + show (FloatLit _) = "" show (BoolLit (Just b)) = "bool(" ++ show b ++ ")" show (BoolLit _) = "" show (StringLit (Just s)) = "string(\"" ++ s ++ "\")" show (StringLit _) = "" - show (CharLit (Just c)) = "char-literal('" ++ [c] ++ "')" + show (CharLit (Just c)) = "char('" ++ [c] ++ "')" show (CharLit Nothing) = "" show (AltIDLit (Just id)) = "altid(\"" ++ id ++ "\")" show (AltIDLit Nothing) = "" @@ -132,6 +135,7 @@ StringLit _ `matches` StringLit _ = True CharLit _ `matches` CharLit _ = True IntLit _ `matches` IntLit _ = True + FloatLit _ `matches` FloatLit _ = True BoolLit _ `matches` BoolLit _ = True AltIDLit _ `matches` AltIDLit _ = True IDLit _ `matches` IDLit _ = True