hydrogen-parsing 0.10 → 0.11
raw patch · 2 files changed
+107/−94 lines, 2 filesdep ~hydrogen-preludePVP ok
version bump matches the API change (PVP)
Dependency ranges changed: hydrogen-prelude
API changes (from Hackage documentation)
- Hydrogen.Parsing: type SomethingBad = (SourcePos, [String])
+ Hydrogen.Parsing: type SomethingBad = [(SourcePos, String)]
Files
- hydrogen-parsing.cabal +36/−35
- src/Hydrogen/Parsing.hs +71/−59
hydrogen-parsing.cabal view
@@ -1,39 +1,40 @@-name: hydrogen-parsing-version: 0.10-homepage: https://scravy.de/hydrogen-parsing/-synopsis: Hydrogen Parsing Utilities-license: MIT-license-file: LICENSE-extra-source-files: CHANGELOG.md, README.md-author: Julian Fleischer-maintainer: julian@scravy.de-category: Language-build-type: Simple-cabal-version: >=1.14+name: hydrogen-parsing+version: 0.11+homepage: https://scravy.de/hydrogen-parsing/+synopsis: Hydrogen Parsing Utilities+license: MIT+license-file: LICENSE+extra-source-files: CHANGELOG.md, README.md+author: Julian Fleischer+maintainer: julian@scravy.de+category: Language+build-type: Simple+cabal-version: >=1.14 source-repository head- type: git- location: https://github.com/scravy/hydrogen-parsing+ type: git+ location: https://github.com/scravy/hydrogen-parsing library- exposed-modules: Hydrogen.Parsing- , Hydrogen.Parsing.Char- build-depends: base ==4.7.*- , containers ==0.5.*- , hydrogen-prelude ==0.10- , parsec ==3.1.*- hs-source-dirs: src- ghc-options: -Wall- default-language: Haskell2010- default-extensions: CPP- , DeriveDataTypeable- , DeriveGeneric- , EmptyCase- , FlexibleContexts- , GADTs- , LambdaCase- , MultiWayIf- , NoImplicitPrelude- , RecordWildCards- , ScopedTypeVariables- , StandaloneDeriving+ exposed-modules: Hydrogen.Parsing+ , Hydrogen.Parsing.Char+ build-depends: base ==4.7.*+ , containers ==0.5.*+ , hydrogen-prelude ==0.11+ , parsec ==3.1.*+ hs-source-dirs: src+ ghc-options: -Wall+ default-language: Haskell2010+ default-extensions: CPP+ , DeriveDataTypeable+ , DeriveGeneric+ , EmptyCase+ , FlexibleContexts+ , GADTs+ , LambdaCase+ , MultiWayIf+ , NoImplicitPrelude+ , RecordWildCards+ , ScopedTypeVariables+ , StandaloneDeriving+ , TupleSections
src/Hydrogen/Parsing.hs view
@@ -37,33 +37,65 @@ import Text.Parsec.Prim --- | Infix to postfix notation (an implementation of the Shunting-Yard-Algorithm)-sya :: (Ord p, Eq o)- => (a -> Maybe o) -- ^ Determine operator- -> (o -> Bool) -- ^ Is left precedence?- -> (o -> p) -- ^ Precedence of given operator- -> [a] -- ^ The input stream (infix notation)- -> [a] -- ^ The output stream (postfix notation)-sya mkOp isL p = sy []+type SomethingBad = [(SourcePos, String)]+type Parser source result = source -> Either SomethingBad result+type Tokens t = [(SourcePos, t)]+++instance Serialize SourcePos where++ put pos = do+ let line = sourceLine pos+ col = sourceColumn pos+ name = sourceName pos+ putWord32be (fromIntegral line)+ putWord32be (fromIntegral col)+ put name++ get = do+ line <- fromIntegral <$> getWord32be+ col <- fromIntegral <$> getWord32be+ name <- get+ return (newPos name line col)+++mkError :: ParseError -> Either SomethingBad b+mkError e = Left $ map ((errorPos e,) . messageToString) (errorMessages e) where- sy (t : ts) (x : xs)- | isOp x && isOp t && cmp t x = t : sy ts (x : xs)+ messageToString = \case+ SysUnExpect msg -> "Unexpected " ++ msg+ UnExpect msg -> "Unexpected " ++ msg+ Expect msg -> "Expected " ++ msg+ Message msg -> msg - sy ts (x : xs)- | isOp x = sy (x : ts) xs- | otherwise = x : sy ts xs - sy ts [] = ts+runTokenParser :: (Stream a Identity t) => ParsecT a () Identity b -> Parser a b+runTokenParser p = either mkError Right . runIdentity . runParserT p () "" - isOp = isJust . mkOp - cmp o1 o2 = isL o1' && p o1' == p o2' || p o1' > p o2'- where- Just o1' = mkOp o1- Just o2' = mkOp o2+sourceToken :: (Show t, Stream (Tokens t) m (SourcePos, t))+ => (t -> Maybe a)+ -> ParsecT [(SourcePos, t)] u m a+sourceToken f = tokenPrim (show . snd) nextPos (f . snd)+ where+ nextPos p _ = \case+ ((p', _) : _) -> p'+ _ -> p +manyBetween :: (Monad m, Stream s m t)+ => ParsecT s u m open -> ParsecT s u m close -> ParsecT s u m p -> ParsecT s u m [p]+manyBetween o c p = o *> manyTill p c ++(>+>) :: Parser a b -> Parser b c -> Parser a c+p1 >+> p2 = join <$> fmap p2 <$> p1+++(<+<) :: Parser b c -> Parser a b -> Parser a c+(<+<) = flip (>+>)++ tryRead :: (Monad m) => ReadS a -> String -> m a tryRead p s = case p s of [(val, "")] -> return val@@ -182,49 +214,29 @@ _ -> Nothing -instance Serialize SourcePos where-- put pos = do- let line = sourceLine pos- col = sourceColumn pos- name = sourceName pos- putWord32be (fromIntegral line)- putWord32be (fromIntegral col)- put name-- get = do- line <- fromIntegral <$> getWord32be- col <- fromIntegral <$> getWord32be- name <- get- return (newPos name line col)--type SomethingBad = (SourcePos, [String])-type Parser source result = source -> Either SomethingBad result-type Tokens t = [(SourcePos, t)]--mkError :: ParseError -> Either SomethingBad b-mkError e = Left (errorPos e, map messageString (errorMessages e))--runTokenParser :: (Stream a Identity t) => ParsecT a () Identity b -> Parser a b-runTokenParser p = either mkError Right . runIdentity . runParserT p () ""--sourceToken :: (Show t, Stream (Tokens t) m (SourcePos, t))- => (t -> Maybe a)- -> ParsecT [(SourcePos, t)] u m a-sourceToken f = tokenPrim (show . snd) nextPos (f . snd)+-- | Infix to postfix notation (an implementation of the Shunting-Yard-Algorithm)+sya :: (Ord p, Eq o)+ => (a -> Maybe o) -- ^ Determine operator+ -> (o -> Bool) -- ^ Is left precedence?+ -> (o -> p) -- ^ Precedence of given operator+ -> [a] -- ^ The input stream (infix notation)+ -> [a] -- ^ The output stream (postfix notation)+sya mkOp isL p = sy [] where- nextPos p _ = \case- ((p', _) : _) -> p'- _ -> p+ sy (t : ts) (x : xs)+ | isOp x && isOp t && cmp t x = t : sy ts (x : xs) -manyBetween :: (Monad m, Stream s m t)- => ParsecT s u m open -> ParsecT s u m close -> ParsecT s u m p -> ParsecT s u m [p]-manyBetween o c p = o *> manyTill p c+ sy ts (x : xs)+ | isOp x = sy (x : ts) xs+ | otherwise = x : sy ts xs -(>+>) :: Parser a b -> Parser b c -> Parser a c-p1 >+> p2 = join <$> fmap p2 <$> p1+ sy ts [] = ts -(<+<) :: Parser b c -> Parser a b -> Parser a c-(<+<) = flip (>+>)+ isOp = isJust . mkOp++ cmp o1 o2 = isL o1' && p o1' == p o2' || p o1' > p o2'+ where+ Just o1' = mkOp o1+ Just o2' = mkOp o2