├── .github ├── dependabot.yml └── workflows │ └── ci.yaml ├── .gitignore ├── CHANGELOG.md ├── Control ├── Applicative │ ├── Combinators.hs │ ├── Combinators │ │ └── NonEmpty.hs │ └── Permutations.hs └── Monad │ ├── Combinators.hs │ ├── Combinators │ ├── Expr.hs │ └── NonEmpty.hs │ └── Permutations.hs ├── LICENSE.md ├── README.md ├── cabal.project ├── parser-combinators-tests ├── LICENSE.md ├── README.md ├── Spec.hs ├── parser-combinators-tests.cabal └── tests │ ├── Control │ ├── Applicative │ │ ├── CombinatorsSpec.hs │ │ └── PermutationsSpec.hs │ └── Monad │ │ ├── Combinators │ │ └── ExprSpec.hs │ │ ├── CombinatorsSpec.hs │ │ └── PermutationsSpec.hs │ └── Spec.hs └── parser-combinators.cabal /.github/dependabot.yml: -------------------------------------------------------------------------------- 1 | version: 2 2 | updates: 3 | - package-ecosystem: "github-actions" 4 | directory: "/" 5 | schedule: 6 | interval: "weekly" 7 | -------------------------------------------------------------------------------- /.github/workflows/ci.yaml: -------------------------------------------------------------------------------- 1 | name: CI 2 | on: 3 | push: 4 | branches: 5 | - master 6 | pull_request: 7 | types: 8 | - opened 9 | - synchronize 10 | jobs: 11 | ormolu: 12 | runs-on: ubuntu-latest 13 | steps: 14 | - uses: actions/checkout@v4 15 | - uses: haskell-actions/run-ormolu@v15 16 | build: 17 | runs-on: ubuntu-latest 18 | needs: ormolu 19 | strategy: 20 | matrix: 21 | cabal: ["3.12"] 22 | ghc: ["9.8.4", "9.10.1", "9.12.1"] 23 | steps: 24 | - uses: actions/checkout@v4 25 | - uses: haskell-actions/setup@v2 26 | id: setup-haskell-cabal 27 | with: 28 | ghc-version: ${{ matrix.ghc }} 29 | cabal-version: ${{ matrix.cabal }} 30 | - run: cabal update 31 | - run: cabal freeze 32 | - uses: actions/cache@v4.0.0 33 | with: 34 | path: | 35 | ${{ steps.setup-haskell-cabal.outputs.cabal-store }} 36 | dist-newstyle 37 | key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }} 38 | restore-keys: | 39 | ${{ runner.os }}-${{ matrix.ghc }}- 40 | - run: cabal format 41 | - run: pushd parser-combinators-tests && cabal format && popd 42 | - run: git diff --exit-code --color=always 43 | - run: cabal build all 44 | - run: cabal test all 45 | - run: cabal haddock parser-combinators 46 | - run: cabal sdist 47 | - run: pushd parser-combinators-tests && cabal sdist && popd 48 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *# 2 | *.aux 3 | *.chi 4 | *.chs.h 5 | *.dyn_hi 6 | *.dyn_o 7 | *.eventlog 8 | *.hi 9 | *.hp 10 | *.o 11 | *.prof 12 | *~ 13 | .HTF/ 14 | .cabal-sandbox/ 15 | .ghc.environment.* 16 | .hpc 17 | .hsenv 18 | .stack-work/ 19 | .virtualenv 20 | TAGS 21 | benchmarks.tix 22 | cabal-dev 23 | cabal.config 24 | cabal.project.local 25 | cabal.sandbox.config 26 | dist-*/ 27 | dist/ 28 | hie.yaml 29 | stack.yaml 30 | stack.yaml.lock 31 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | ## Parser combinators 1.3.0 2 | 3 | * Changed the `Control.Applicative.Permutations` module to only require 4 | `Applicative` and not `Monad`. This module is the least restrictive and works 5 | with parsers which are not `Monad`s. 6 | 7 | * Added the `Control.Monad.Permutations` module. This module may be 8 | substantially more efficient for some parsers which are `Monad`s. 9 | 10 | * Corrected how permutation parsers intercalate effects and components; parsing 11 | an effect requires that a component immediately follows or else a parse error 12 | will result. 13 | 14 | ## Parser combinators 1.2.1 15 | 16 | * The tests in `parser-combinators-tests` now work with Megaparsec 8. 17 | 18 | * Dropped support for GHC 8.2. 19 | 20 | ## Parser combinators 1.2.0 21 | 22 | * Added `manyTill_` and `someTill_` combinators which work like the older 23 | `manyTill` and `someTill` except they also return the result of the `end` 24 | parser. 25 | 26 | * Dropped support for GHC 8.0. 27 | 28 | ## Parser combinators 1.1.0 29 | 30 | * Added support for ternary operators; see `TernR` in 31 | `Control.Monad.Combinators.Expr`. 32 | 33 | ## Parser combinators 1.0.3 34 | 35 | * Dropped support for GHC 7.10. 36 | 37 | * Added a test suite as a separate package called 38 | `parser-combinators-tests`. 39 | 40 | ## Parser combinators 1.0.2 41 | 42 | * Defined `liftA2` for `Permutation` manually. The new definition should be 43 | more efficient. 44 | 45 | * Made inner `Maybe` field in `Permutation` strict. 46 | 47 | ## Parser combinators 1.0.1 48 | 49 | * Cosmetic changes in the source code. 50 | 51 | ## Parser combinators 1.0.0 52 | 53 | * Added the `Control.Monad.Combinators.Expr` module. 54 | 55 | * Dropped the compatibility operators `(<$$>)`, `(<$?>)`, `(<||>)`, and 56 | `(<|?>)` from `Control.Applicative.Permutations`. 57 | 58 | * Dropped support for GHCs older than 7.10. 59 | 60 | ## Parser combinators 0.4.0 61 | 62 | * Improved the documentation. 63 | 64 | * Re-exported `Control.Applicative.empty` from 65 | `Control.Applicative.Combinators`. 66 | 67 | * Added the `Control.Monad.Combinators` and 68 | `Control.Monad.Combinators.NonEmpty` modules which contain more efficient 69 | versions of the combinators from `Control.Applicative.Combinators` and 70 | `Control.Applicative.Combinators.NonEmpty` respectively. 71 | 72 | ## Parser combinators 0.3.0 73 | 74 | * Added the `skipCount` combinator. 75 | 76 | * Improved algorithmic efficiency of the `count'` combinator. 77 | 78 | ## Parser combinators 0.2.1 79 | 80 | * Removed the byte order marking at the beginning of the 81 | `Control.Applicative.Permutations` module. 82 | 83 | ## Parser combinators 0.2.0 84 | 85 | * Added `Control.Applicative.Combinators.NonEmpty` module that exports 86 | non-empty list versions of combinators that cannot return empty lists. 87 | 88 | * Added `Control.Applicative.Permutations` module that provides generalized 89 | permutation parser combinators. 90 | 91 | ## Parser combinators 0.1.0 92 | 93 | * Initial release. 94 | -------------------------------------------------------------------------------- /Control/Applicative/Combinators.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE TupleSections #-} 3 | 4 | -- | 5 | -- Module : Control.Applicative.Combinators 6 | -- Copyright : © 2017–present Mark Karpov 7 | -- License : BSD 3 clause 8 | -- 9 | -- Maintainer : Mark Karpov 10 | -- Stability : experimental 11 | -- Portability : portable 12 | -- 13 | -- The module provides parser combinators defined for instances of 14 | -- 'Applicative' and 'Alternative'. It also re-exports functions that are 15 | -- commonly used in parsing from "Control.Applicative" with additional 16 | -- parsing-related comments added. 17 | -- 18 | -- Due to the nature of the 'Applicative' and 'Alternative' abstractions, 19 | -- they are prone to memory leaks and not as efficient as their monadic 20 | -- counterparts. Although all the combinators we provide in this module are 21 | -- perfectly expressible in terms of 'Applicative' and 'Alternative', please 22 | -- prefer "Control.Monad.Combinators" instead when possible. 23 | -- 24 | -- If you wish that the combinators that cannot return empty lists return 25 | -- values of the 'Data.List.NonEmpty.NonEmpty' data type, use the 26 | -- "Control.Applicative.Combinators.NonEmpty" module. 27 | -- 28 | -- === A note on backtracking 29 | -- 30 | -- Certain parsing libraries, such as Megaparsec, do not backtrack every 31 | -- branch of parsing automatically for the sake of performance and better 32 | -- error messages. They typically backtrack only “atomic” parsers, e.g. 33 | -- those that match a token or several tokens in a row. To backtrack an 34 | -- arbitrary complex parser\/branch, a special combinator should be used, 35 | -- typically called @try@. Combinators in this module are defined in terms 36 | -- 'Applicative' and 'Alternative' operations. Being quite abstract, they 37 | -- cannot know anything about inner workings of any concrete parsing 38 | -- library, and so they cannot use @try@. 39 | -- 40 | -- The essential feature of the 'Alternative' type class is the @('<|>')@ 41 | -- operator that allows to express choice. In libraries that do not 42 | -- backtrack everything automatically, the choice operator and everything 43 | -- that is build on top of it require the parser on the left hand side to 44 | -- backtrack in order for the alternative branch of parsing to be tried. 45 | -- Thus it is the responsibility of the programmer to wrap more complex, 46 | -- composite parsers in @try@ to achieve correct behavior. 47 | module Control.Applicative.Combinators 48 | ( -- * Re-exports from "Control.Applicative" 49 | (<|>), 50 | -- $assocbo 51 | many, 52 | -- $many 53 | some, 54 | -- $some 55 | optional, 56 | -- $optional 57 | empty, 58 | -- $empty 59 | 60 | -- * Original combinators 61 | between, 62 | choice, 63 | count, 64 | count', 65 | eitherP, 66 | endBy, 67 | endBy1, 68 | manyTill, 69 | manyTill_, 70 | someTill, 71 | someTill_, 72 | option, 73 | sepBy, 74 | sepBy1, 75 | sepEndBy, 76 | sepEndBy1, 77 | skipMany, 78 | skipSome, 79 | skipCount, 80 | skipManyTill, 81 | skipSomeTill, 82 | ) 83 | where 84 | 85 | import Control.Applicative 86 | import Control.Monad (replicateM, replicateM_) 87 | 88 | ---------------------------------------------------------------------------- 89 | -- Re-exports from "Control.Applicative" 90 | 91 | -- $assocbo 92 | -- 93 | -- This combinator implements choice. The parser @p '<|>' q@ first applies 94 | -- @p@. If it succeeds, the value of @p@ is returned. If @p@ fails, parser 95 | -- @q@ is tried. 96 | 97 | -- $many 98 | -- 99 | -- @'many' p@ applies the parser @p@ /zero/ or more times and returns a list 100 | -- of the values returned by @p@. 101 | -- 102 | -- > identifier = (:) <$> letter <*> many (alphaNumChar <|> char '_') 103 | 104 | -- $some 105 | -- 106 | -- @'some' p@ applies the parser @p@ /one/ or more times and returns a list 107 | -- of the values returned by @p@. 108 | -- 109 | -- > word = some letter 110 | 111 | -- $optional 112 | -- 113 | -- @'optional' p@ tries to apply the parser @p@. It will parse @p@ or 114 | -- 'Nothing'. It only fails if @p@ fails after consuming input. On success 115 | -- result of @p@ is returned inside of 'Just', on failure 'Nothing' is 116 | -- returned. 117 | -- 118 | -- See also: 'option'. 119 | 120 | -- $empty 121 | -- 122 | -- This parser fails unconditionally without providing any information about 123 | -- the cause of the failure. 124 | -- 125 | -- @since 0.4.0 126 | 127 | ---------------------------------------------------------------------------- 128 | -- Original combinators 129 | 130 | -- | @'between' open close p@ parses @open@, followed by @p@ and @close@. 131 | -- Returns the value returned by @p@. 132 | -- 133 | -- > braces = between (symbol "{") (symbol "}") 134 | between :: (Applicative m) => m open -> m close -> m a -> m a 135 | between open close p = open *> p <* close 136 | {-# INLINE between #-} 137 | 138 | -- | @'choice' ps@ tries to apply the parsers in the list @ps@ in order, 139 | -- until one of them succeeds. Returns the value of the succeeding parser. 140 | -- 141 | -- > choice = asum 142 | choice :: (Foldable f, Alternative m) => f (m a) -> m a 143 | choice = asum 144 | {-# INLINE choice #-} 145 | 146 | -- | @'count' n p@ parses @n@ occurrences of @p@. If @n@ is smaller or equal 147 | -- to zero, the parser equals to @'pure' []@. Returns a list of @n@ parsed 148 | -- values. 149 | -- 150 | -- > count = replicateM 151 | -- 152 | -- See also: 'skipCount', 'count''. 153 | count :: (Applicative m) => Int -> m a -> m [a] 154 | count = replicateM 155 | {-# INLINE count #-} 156 | 157 | -- | @'count'' m n p@ parses from @m@ to @n@ occurrences of @p@. If @n@ is 158 | -- not positive or @m > n@, the parser equals to @'pure' []@. Returns a list 159 | -- of parsed values. 160 | -- 161 | -- Please note that @m@ /may/ be negative, in this case effect is the same 162 | -- as if it were equal to zero. 163 | -- 164 | -- See also: 'skipCount', 'count'. 165 | count' :: (Alternative m) => Int -> Int -> m a -> m [a] 166 | count' m' n' p = go m' n' 167 | where 168 | go !m !n 169 | | n <= 0 || m > n = pure [] 170 | | m > 0 = liftA2 (:) p (go (m - 1) (n - 1)) 171 | | otherwise = liftA2 (:) p (go 0 (n - 1)) <|> pure [] 172 | {-# INLINE count' #-} 173 | 174 | -- | Combine two alternatives. 175 | -- 176 | -- > eitherP a b = (Left <$> a) <|> (Right <$> b) 177 | eitherP :: (Alternative m) => m a -> m b -> m (Either a b) 178 | eitherP a b = (Left <$> a) <|> (Right <$> b) 179 | {-# INLINE eitherP #-} 180 | 181 | -- | @'endBy' p sep@ parses /zero/ or more occurrences of @p@, separated and 182 | -- ended by @sep@. Returns a list of values returned by @p@. 183 | -- 184 | -- > cStatements = cStatement `endBy` semicolon 185 | endBy :: (Alternative m) => m a -> m sep -> m [a] 186 | endBy p sep = many (p <* sep) 187 | {-# INLINE endBy #-} 188 | 189 | -- | @'endBy1' p sep@ parses /one/ or more occurrences of @p@, separated and 190 | -- ended by @sep@. Returns a list of values returned by @p@. 191 | endBy1 :: (Alternative m) => m a -> m sep -> m [a] 192 | endBy1 p sep = some (p <* sep) 193 | {-# INLINE endBy1 #-} 194 | 195 | -- | @'manyTill' p end@ applies parser @p@ /zero/ or more times until parser 196 | -- @end@ succeeds. Returns the list of values returned by @p@. @end@ result 197 | -- is consumed and lost. Use 'manyTill_' if you wish to keep it. 198 | -- 199 | -- See also: 'skipMany', 'skipManyTill'. 200 | manyTill :: (Alternative m) => m a -> m end -> m [a] 201 | manyTill p end = go 202 | where 203 | go = ([] <$ end) <|> liftA2 (:) p go 204 | {-# INLINE manyTill #-} 205 | 206 | -- | @'manyTill_' p end@ applies parser @p@ /zero/ or more times until 207 | -- parser @end@ succeeds. Returns the list of values returned by @p@ and the 208 | -- @end@ result. Use 'manyTill' if you have no need in the result of the 209 | -- @end@. 210 | -- 211 | -- See also: 'skipMany', 'skipManyTill'. 212 | -- 213 | -- @since 1.2.0 214 | manyTill_ :: (Alternative m) => m a -> m end -> m ([a], end) 215 | manyTill_ p end = go 216 | where 217 | go = (([],) <$> end) <|> liftA2 (\x (xs, y) -> (x : xs, y)) p go 218 | {-# INLINE manyTill_ #-} 219 | 220 | -- | @'someTill' p end@ works similarly to @'manyTill' p end@, but @p@ 221 | -- should succeed at least once. @end@ result is consumed and lost. Use 222 | -- 'someTill_' if you wish to keep it. 223 | -- 224 | -- > someTill p end = liftA2 (:) p (manyTill p end) 225 | -- 226 | -- See also: 'skipSome', 'skipSomeTill'. 227 | someTill :: (Alternative m) => m a -> m end -> m [a] 228 | someTill p end = liftA2 (:) p (manyTill p end) 229 | {-# INLINE someTill #-} 230 | 231 | -- | @'someTill_' p end@ works similarly to @'manyTill_' p end@, but @p@ 232 | -- should succeed at least once. Use 'someTill' if you have no need in the 233 | -- result of the @end@. 234 | -- 235 | -- See also: 'skipSome', 'skipSomeTill'. 236 | -- 237 | -- @since 1.2.0 238 | someTill_ :: (Alternative m) => m a -> m end -> m ([a], end) 239 | someTill_ p end = 240 | liftA2 (\x (xs, y) -> (x : xs, y)) p (manyTill_ p end) 241 | {-# INLINE someTill_ #-} 242 | 243 | -- | @'option' x p@ tries to apply the parser @p@. If @p@ fails without 244 | -- consuming input, it returns the value @x@, otherwise the value returned 245 | -- by @p@. 246 | -- 247 | -- > option x p = p <|> pure x 248 | -- 249 | -- See also: 'optional'. 250 | option :: (Alternative m) => a -> m a -> m a 251 | option x p = p <|> pure x 252 | {-# INLINE option #-} 253 | 254 | -- | @'sepBy' p sep@ parses /zero/ or more occurrences of @p@, separated by 255 | -- @sep@. Returns a list of values returned by @p@. 256 | -- 257 | -- > commaSep p = p `sepBy` comma 258 | sepBy :: (Alternative m) => m a -> m sep -> m [a] 259 | sepBy p sep = sepBy1 p sep <|> pure [] 260 | {-# INLINE sepBy #-} 261 | 262 | -- | @'sepBy1' p sep@ parses /one/ or more occurrences of @p@, separated by 263 | -- @sep@. Returns a list of values returned by @p@. 264 | sepBy1 :: (Alternative m) => m a -> m sep -> m [a] 265 | sepBy1 p sep = liftA2 (:) p (many (sep *> p)) 266 | {-# INLINE sepBy1 #-} 267 | 268 | -- | @'sepEndBy' p sep@ parses /zero/ or more occurrences of @p@, separated 269 | -- and optionally ended by @sep@. Returns a list of values returned by @p@. 270 | sepEndBy :: (Alternative m) => m a -> m sep -> m [a] 271 | sepEndBy p sep = sepEndBy1 p sep <|> pure [] 272 | {-# INLINE sepEndBy #-} 273 | 274 | -- | @'sepEndBy1' p sep@ parses /one/ or more occurrences of @p@, separated 275 | -- and optionally ended by @sep@. Returns a list of values returned by @p@. 276 | sepEndBy1 :: (Alternative m) => m a -> m sep -> m [a] 277 | sepEndBy1 p sep = liftA2 (:) p ((sep *> sepEndBy p sep) <|> pure []) 278 | {-# INLINEABLE sepEndBy1 #-} 279 | 280 | -- | @'skipMany' p@ applies the parser @p@ /zero/ or more times, skipping 281 | -- its result. 282 | -- 283 | -- See also: 'manyTill', 'skipManyTill'. 284 | skipMany :: (Alternative m) => m a -> m () 285 | skipMany p = go 286 | where 287 | go = (p *> go) <|> pure () 288 | {-# INLINE skipMany #-} 289 | 290 | -- | @'skipSome' p@ applies the parser @p@ /one/ or more times, skipping its 291 | -- result. 292 | -- 293 | -- See also: 'someTill', 'skipSomeTill'. 294 | skipSome :: (Alternative m) => m a -> m () 295 | skipSome p = p *> skipMany p 296 | {-# INLINE skipSome #-} 297 | 298 | -- | @'skipCount' n p@ parses @n@ occurrences of @p@, skipping its result. 299 | -- If @n@ is not positive, the parser equals to @'pure' ()@. 300 | -- 301 | -- > skipCount = replicateM_ 302 | -- 303 | -- See also: 'count', 'count''. 304 | -- 305 | -- @since 0.3.0 306 | skipCount :: (Applicative m) => Int -> m a -> m () 307 | skipCount = replicateM_ 308 | {-# INLINE skipCount #-} 309 | 310 | -- | @'skipManyTill' p end@ applies the parser @p@ /zero/ or more times 311 | -- skipping results until parser @end@ succeeds. Result parsed by @end@ is 312 | -- then returned. 313 | -- 314 | -- See also: 'manyTill', 'skipMany'. 315 | skipManyTill :: (Alternative m) => m a -> m end -> m end 316 | skipManyTill p end = go 317 | where 318 | go = end <|> (p *> go) 319 | {-# INLINE skipManyTill #-} 320 | 321 | -- | @'skipSomeTill' p end@ applies the parser @p@ /one/ or more times 322 | -- skipping results until parser @end@ succeeds. Result parsed by @end@ is 323 | -- then returned. 324 | -- 325 | -- See also: 'someTill', 'skipSome'. 326 | skipSomeTill :: (Alternative m) => m a -> m end -> m end 327 | skipSomeTill p end = p *> skipManyTill p end 328 | {-# INLINE skipSomeTill #-} 329 | -------------------------------------------------------------------------------- /Control/Applicative/Combinators/NonEmpty.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Control.Applicative.Combinators 3 | -- Copyright : © 2017–present Mark Karpov 4 | -- License : BSD 3 clause 5 | -- 6 | -- Maintainer : Mark Karpov 7 | -- Stability : experimental 8 | -- Portability : portable 9 | -- 10 | -- The module provides 'NonEmpty' list variants of some of the functions 11 | -- from "Control.Applicative.Combinators". 12 | -- 13 | -- @since 0.2.0 14 | module Control.Applicative.Combinators.NonEmpty 15 | ( some, 16 | endBy1, 17 | someTill, 18 | sepBy1, 19 | sepEndBy1, 20 | ) 21 | where 22 | 23 | import Control.Applicative hiding (some) 24 | import qualified Control.Applicative.Combinators as C 25 | import Data.List.NonEmpty (NonEmpty (..)) 26 | import qualified Data.List.NonEmpty as NE 27 | 28 | -- | @'some' p@ applies the parser @p@ /one/ or more times and returns a 29 | -- list of the values returned by @p@. 30 | -- 31 | -- > word = some letter 32 | some :: (Alternative m) => m a -> m (NonEmpty a) 33 | some p = NE.fromList <$> C.some p 34 | {-# INLINE some #-} 35 | 36 | -- | @'endBy1' p sep@ parses /one/ or more occurrences of @p@, separated and 37 | -- ended by @sep@. Returns a non-empty list of values returned by @p@. 38 | endBy1 :: (Alternative m) => m a -> m sep -> m (NonEmpty a) 39 | endBy1 p sep = NE.fromList <$> C.endBy1 p sep 40 | {-# INLINE endBy1 #-} 41 | 42 | -- | @'someTill' p end@ works similarly to @'C.manyTill' p end@, but @p@ 43 | -- should succeed at least once. 44 | -- 45 | -- See also: 'C.skipSome', 'C.skipSomeTill'. 46 | someTill :: (Alternative m) => m a -> m end -> m (NonEmpty a) 47 | someTill p end = NE.fromList <$> C.someTill p end 48 | {-# INLINE someTill #-} 49 | 50 | -- | @'sepBy1' p sep@ parses /one/ or more occurrences of @p@, separated by 51 | -- @sep@. Returns a non-empty list of values returned by @p@. 52 | sepBy1 :: (Alternative m) => m a -> m sep -> m (NonEmpty a) 53 | sepBy1 p sep = NE.fromList <$> C.sepBy1 p sep 54 | {-# INLINE sepBy1 #-} 55 | 56 | -- | @'sepEndBy1' p sep@ parses /one/ or more occurrences of @p@, separated 57 | -- and optionally ended by @sep@. Returns a non-empty list of values returned by 58 | -- @p@. 59 | sepEndBy1 :: (Alternative m) => m a -> m sep -> m (NonEmpty a) 60 | sepEndBy1 p sep = NE.fromList <$> C.sepEndBy1 p sep 61 | {-# INLINE sepEndBy1 #-} 62 | -------------------------------------------------------------------------------- /Control/Applicative/Permutations.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification #-} 2 | 3 | -- | 4 | -- Module : Control.Applicative.Permutations 5 | -- Copyright : © 2017–present Alex Washburn 6 | -- License : BSD 3 clause 7 | -- 8 | -- Maintainer : Mark Karpov 9 | -- Stability : experimental 10 | -- Portability : portable 11 | -- 12 | -- This module is a generalization of the package @parsec-permutation@ 13 | -- authored by Samuel Hoffstaetter: 14 | -- 15 | -- https://hackage.haskell.org/package/parsec-permutation 16 | -- 17 | -- This module also takes inspiration from the algorithm is described in: 18 | -- /Parsing Permutation Phrases/, by Arthur Baars, Andres Löh and Doaitse 19 | -- Swierstra. Published as a functional pearl at the Haskell Workshop 2001: 20 | -- 21 | -- https://www.cs.ox.ac.uk/jeremy.gibbons/wg21/meeting56/loeh-paper.pdf 22 | -- 23 | -- From these two works we derive a flexible and general method for parsing 24 | -- permutations over an 'Applicative' structure. Quite useful in conjunction 25 | -- with \"Free\" constructions of 'Applicative's, 'Monad's, etc. 26 | -- 27 | -- Other permutation parsing libraries tend towards using special \"almost 28 | -- applicative\" combinators for construction which denies the library user 29 | -- the ability to lift and unlift permutation parsing into any 'Applicative' 30 | -- computational context. We redefine these combinators as convenience 31 | -- operators here alongside the equivalent 'Applicative' instance. 32 | -- 33 | -- For example, suppose we want to parse a permutation of: an optional 34 | -- string of @a@'s, the character @b@ and an optional @c@. Using a standard 35 | -- parsing library combinator @char@ (e.g. 'Text.ParserCombinators.ReadP.ReadP') 36 | -- this can be described using the 'Applicative' instance by: 37 | -- 38 | -- > test = runPermutation $ 39 | -- > (,,) <$> toPermutationWithDefault "" (some (char 'a')) 40 | -- > <*> toPermutation (char 'b') 41 | -- > <*> toPermutationWithDefault '_' (char 'c') 42 | -- 43 | -- @since 0.2.0 44 | module Control.Applicative.Permutations 45 | ( -- ** Permutation type 46 | Permutation, 47 | 48 | -- ** Permutation evaluators 49 | runPermutation, 50 | intercalateEffect, 51 | 52 | -- ** Permutation constructors 53 | toPermutation, 54 | toPermutationWithDefault, 55 | ) 56 | where 57 | 58 | import Control.Applicative 59 | import Data.Function ((&)) 60 | 61 | -- | An 'Applicative' wrapper-type for constructing permutation parsers. 62 | data Permutation m a = P !(Maybe a) [Branch m a] 63 | 64 | data Branch m a = forall z. Branch (Permutation m (z -> a)) (m z) 65 | 66 | instance (Functor m) => Functor (Permutation m) where 67 | fmap f (P v bs) = P (f <$> v) (fmap f <$> bs) 68 | 69 | instance (Functor p) => Functor (Branch p) where 70 | fmap f (Branch perm p) = Branch (fmap (f .) perm) p 71 | 72 | instance (Functor m) => Applicative (Permutation m) where 73 | pure value = P (Just value) empty 74 | lhs@(P f v) <*> rhs@(P g w) = P (f <*> g) $ (ins2 <$> v) <> (ins1 <$> w) 75 | where 76 | ins1 (Branch perm p) = Branch ((.) <$> lhs <*> perm) p 77 | ins2 (Branch perm p) = Branch (flip <$> perm <*> rhs) p 78 | liftA2 f lhs@(P x v) rhs@(P y w) = P (liftA2 f x y) $ (ins2 <$> v) <> (ins1 <$> w) 79 | where 80 | ins1 (Branch perm p) = Branch (liftA2 ((.) . f) lhs perm) p 81 | ins2 (Branch perm p) = Branch (liftA2 (\b g z -> f (g z) b) rhs perm) p 82 | 83 | -- | \"Unlifts\" a permutation parser into a parser to be evaluated. 84 | runPermutation :: 85 | (Alternative m) => 86 | -- | Permutation specification 87 | Permutation m a -> 88 | -- | Resulting base monad capable of handling the permutation 89 | m a 90 | runPermutation = foldAlt f 91 | where 92 | -- INCORRECT = runPerms t <*> p 93 | f (Branch t p) = (&) <$> p <*> runPermutation t 94 | 95 | -- | \"Unlifts\" a permutation parser into a parser to be evaluated with an 96 | -- intercalated effect. Useful for separators between permutation elements. 97 | -- 98 | -- For example, suppose that similar to above we want to parse a permutation 99 | -- of: an optional string of @a@'s, the character @b@ and an optional @c@. 100 | -- /However/, we also want each element of the permutation to be separated 101 | -- by a colon. Using a standard parsing library combinator @char@, this can 102 | -- be described using the 'Applicative' instance by: 103 | -- 104 | -- > test = intercalateEffect (char ':') $ 105 | -- > (,,) <$> toPermutationWithDefault "" (some (char 'a')) 106 | -- > <*> toPermutation (char 'b') 107 | -- > <*> toPermutationWithDefault '_' (char 'c') 108 | -- 109 | -- This will accept strings such as: \"a:b:c\", \"b:c:a\", \"b:aa\", \"b\", 110 | -- etc. 111 | -- 112 | -- Note that the effect is intercalated /between/ permutation components and 113 | -- that: 114 | -- 115 | -- * There is never an effect parsed preceeding the first component of 116 | -- the permutation. 117 | -- * There is never an effect parsed following the last component of the 118 | -- permutation. 119 | -- * No effects are intercalated between missing components with a 120 | -- default value. 121 | -- * If an effect is encountered after a component, another component must 122 | -- immediately follow the effect. 123 | intercalateEffect :: 124 | (Alternative m) => 125 | -- | Effect to be intercalated between permutation components 126 | m b -> 127 | -- | Permutation specification 128 | Permutation m a -> 129 | -- | Resulting base applicative capable of handling the permutation 130 | m a 131 | intercalateEffect effect = foldAlt (runBranchEff effect) 132 | where 133 | runPermEff :: (Alternative m) => m b -> Permutation m a -> m a 134 | runPermEff eff (P v bs) = 135 | eff *> foldr ((<|>) . runBranchEff eff) empty bs <|> maybe empty pure v 136 | 137 | runBranchEff :: (Alternative m) => m b -> Branch m a -> m a 138 | runBranchEff eff (Branch t p) = (&) <$> p <*> runPermEff eff t 139 | 140 | -- | \"Lifts\" a parser to a permutation parser. 141 | toPermutation :: 142 | (Alternative m) => 143 | -- | Permutation component 144 | m a -> 145 | Permutation m a 146 | toPermutation = P Nothing . pure . branch 147 | 148 | -- | \"Lifts\" a parser with a default value to a permutation parser. 149 | -- 150 | -- If no permutation containing the supplied parser can be parsed from the input, 151 | -- then the supplied default value is returned in lieu of a parse result. 152 | toPermutationWithDefault :: 153 | (Alternative m) => 154 | -- | Default Value 155 | a -> 156 | -- | Permutation component 157 | m a -> 158 | Permutation m a 159 | toPermutationWithDefault v = P (Just v) . pure . branch 160 | 161 | branch :: (Functor m) => m a -> Branch m a 162 | branch = Branch $ pure id 163 | 164 | foldAlt :: (Alternative m) => (Branch m a -> m a) -> Permutation m a -> m a 165 | foldAlt f (P v bs) = foldr ((<|>) . f) (maybe empty pure v) bs 166 | -------------------------------------------------------------------------------- /Control/Monad/Combinators.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | 3 | -- | 4 | -- Module : Control.Monad.Combinators 5 | -- Copyright : © 2017–present Mark Karpov 6 | -- License : BSD 3 clause 7 | -- 8 | -- Maintainer : Mark Karpov 9 | -- Stability : experimental 10 | -- Portability : portable 11 | -- 12 | -- The module provides more efficient versions of the combinators from 13 | -- "Control.Applicative.Combinators" defined in terms of 'Monad' and 14 | -- 'MonadPlus' instead of 'Control.Applicative.Applicative' and 15 | -- 'Control.Applicative.Alternative'. When there is no difference in 16 | -- performance we just re-export the combinators from 17 | -- "Control.Applicative.Combinators". 18 | -- 19 | -- @since 0.4.0 20 | module Control.Monad.Combinators 21 | ( -- * Re-exports from "Control.Applicative" 22 | (C.<|>), 23 | -- $assocbo 24 | C.optional, 25 | -- $optional 26 | C.empty, 27 | -- $empty 28 | 29 | -- * Original combinators 30 | C.between, 31 | C.choice, 32 | count, 33 | count', 34 | C.eitherP, 35 | endBy, 36 | endBy1, 37 | many, 38 | manyTill, 39 | manyTill_, 40 | some, 41 | someTill, 42 | someTill_, 43 | C.option, 44 | sepBy, 45 | sepBy1, 46 | sepEndBy, 47 | sepEndBy1, 48 | skipMany, 49 | skipSome, 50 | skipCount, 51 | skipManyTill, 52 | skipSomeTill, 53 | ) 54 | where 55 | 56 | import qualified Control.Applicative.Combinators as C 57 | import Control.Monad 58 | 59 | ---------------------------------------------------------------------------- 60 | -- Re-exports from "Control.Applicative" 61 | 62 | -- $assocbo 63 | -- 64 | -- This combinator implements choice. The parser @p 'C.<|>' q@ first applies 65 | -- @p@. If it succeeds, the value of @p@ is returned. If @p@ fails, parser 66 | -- @q@ is tried. 67 | 68 | -- $optional 69 | -- 70 | -- @'C.optional' p@ tries to apply the parser @p@. It will parse @p@ or 71 | -- 'Nothing'. It only fails if @p@ fails after consuming input. On success 72 | -- result of @p@ is returned inside of 'Just', on failure 'Nothing' is 73 | -- returned. 74 | -- 75 | -- See also: 'C.option'. 76 | 77 | -- $empty 78 | -- 79 | -- This parser fails unconditionally without providing any information about 80 | -- the cause of the failure. 81 | 82 | ---------------------------------------------------------------------------- 83 | -- Original combinators 84 | 85 | -- | @'count' n p@ parses @n@ occurrences of @p@. If @n@ is smaller or equal 86 | -- to zero, the parser equals to @'return' []@. Returns a list of @n@ 87 | -- values. 88 | -- 89 | -- See also: 'skipCount', 'count''. 90 | count :: (Monad m) => Int -> m a -> m [a] 91 | count n' p = go id n' 92 | where 93 | go f !n = 94 | if n <= 0 95 | then return (f []) 96 | else do 97 | x <- p 98 | go (f . (x :)) (n - 1) 99 | {-# INLINE count #-} 100 | 101 | -- | @'count'' m n p@ parses from @m@ to @n@ occurrences of @p@. If @n@ is 102 | -- not positive or @m > n@, the parser equals to @'return' []@. Returns a 103 | -- list of parsed values. 104 | -- 105 | -- Please note that @m@ /may/ be negative, in this case effect is the same 106 | -- as if it were equal to zero. 107 | -- 108 | -- See also: 'skipCount', 'count'. 109 | count' :: (MonadPlus m) => Int -> Int -> m a -> m [a] 110 | count' m' n' p = 111 | if n' > 0 && n' >= m' 112 | then gom id m' 113 | else return [] 114 | where 115 | gom f !m = 116 | if m > 0 117 | then do 118 | x <- p 119 | gom (f . (x :)) (m - 1) 120 | else god f (if m' <= 0 then n' else n' - m') 121 | god f !d = 122 | if d > 0 123 | then do 124 | r <- C.optional p 125 | case r of 126 | Nothing -> return (f []) 127 | Just x -> god (f . (x :)) (d - 1) 128 | else return (f []) 129 | {-# INLINE count' #-} 130 | 131 | -- | @'endBy' p sep@ parses /zero/ or more occurrences of @p@, separated and 132 | -- ended by @sep@. Returns a list of values returned by @p@. 133 | -- 134 | -- > cStatements = cStatement `endBy` semicolon 135 | endBy :: (MonadPlus m) => m a -> m sep -> m [a] 136 | endBy p sep = many (p >>= \x -> x <$ sep) 137 | {-# INLINE endBy #-} 138 | 139 | -- | @'endBy1' p sep@ parses /one/ or more occurrences of @p@, separated and 140 | -- ended by @sep@. Returns a list of values returned by @p@. 141 | endBy1 :: (MonadPlus m) => m a -> m sep -> m [a] 142 | endBy1 p sep = some (p >>= \x -> x <$ sep) 143 | {-# INLINE endBy1 #-} 144 | 145 | -- | @'many' p@ applies the parser @p@ /zero/ or more times and returns a 146 | -- list of the values returned by @p@. 147 | -- 148 | -- > identifier = (:) <$> letter <*> many (alphaNumChar <|> char '_') 149 | many :: (MonadPlus m) => m a -> m [a] 150 | many p = go id 151 | where 152 | go f = do 153 | r <- C.optional p 154 | case r of 155 | Nothing -> return (f []) 156 | Just x -> go (f . (x :)) 157 | {-# INLINE many #-} 158 | 159 | -- | @'manyTill' p end@ applies parser @p@ /zero/ or more times until parser 160 | -- @end@ succeeds. Returns the list of values returned by @p@. __Note__ that 161 | -- @end@ result is consumed and lost. Use 'manyTill_' if you wish to keep 162 | -- it. 163 | -- 164 | -- See also: 'skipMany', 'skipManyTill'. 165 | manyTill :: (MonadPlus m) => m a -> m end -> m [a] 166 | manyTill p end = fst <$> manyTill_ p end 167 | {-# INLINE manyTill #-} 168 | 169 | -- | @'manyTill_' p end@ applies parser @p@ /zero/ or more times until 170 | -- parser @end@ succeeds. Returns the list of values returned by @p@ and the 171 | -- @end@ result. Use 'manyTill' if you have no need in the result of the 172 | -- @end@. 173 | -- 174 | -- See also: 'skipMany', 'skipManyTill'. 175 | -- 176 | -- @since 1.2.0 177 | manyTill_ :: (MonadPlus m) => m a -> m end -> m ([a], end) 178 | manyTill_ p end = go id 179 | where 180 | go f = do 181 | done <- C.optional end 182 | case done of 183 | Just done' -> return (f [], done') 184 | Nothing -> do 185 | x <- p 186 | go (f . (x :)) 187 | {-# INLINE manyTill_ #-} 188 | 189 | -- | @'some' p@ applies the parser @p@ /one/ or more times and returns a 190 | -- list of the values returned by @p@. 191 | -- 192 | -- > word = some letter 193 | some :: (MonadPlus m) => m a -> m [a] 194 | some p = liftM2 (:) p (many p) 195 | {-# INLINE some #-} 196 | 197 | -- | @'someTill' p end@ works similarly to @'manyTill' p end@, but @p@ 198 | -- should succeed at least once. __Note__ that @end@ result is consumed and 199 | -- lost. Use 'someTill_' if you wish to keep it. 200 | -- 201 | -- > someTill p end = liftM2 (:) p (manyTill p end) 202 | -- 203 | -- See also: 'skipSome', 'skipSomeTill'. 204 | someTill :: (MonadPlus m) => m a -> m end -> m [a] 205 | someTill p end = liftM2 (:) p (manyTill p end) 206 | {-# INLINE someTill #-} 207 | 208 | -- | @'someTill_' p end@ works similarly to @'manyTill_' p end@, but @p@ 209 | -- should succeed at least once. Use 'someTill' if you have no need in the 210 | -- result of the @end@. 211 | -- 212 | -- See also: 'skipSome', 'skipSomeTill'. 213 | -- 214 | -- @since 1.2.0 215 | someTill_ :: (MonadPlus m) => m a -> m end -> m ([a], end) 216 | someTill_ p end = liftM2 (\x (xs, y) -> (x : xs, y)) p (manyTill_ p end) 217 | {-# INLINE someTill_ #-} 218 | 219 | -- | @'sepBy' p sep@ parses /zero/ or more occurrences of @p@, separated by 220 | -- @sep@. Returns a list of values returned by @p@. 221 | -- 222 | -- > commaSep p = p `sepBy` comma 223 | sepBy :: (MonadPlus m) => m a -> m sep -> m [a] 224 | sepBy p sep = do 225 | r <- C.optional p 226 | case r of 227 | Nothing -> return [] 228 | Just x -> (x :) <$> many (sep >> p) 229 | {-# INLINE sepBy #-} 230 | 231 | -- | @'sepBy1' p sep@ parses /one/ or more occurrences of @p@, separated by 232 | -- @sep@. Returns a list of values returned by @p@. 233 | sepBy1 :: (MonadPlus m) => m a -> m sep -> m [a] 234 | sepBy1 p sep = do 235 | x <- p 236 | (x :) <$> many (sep >> p) 237 | {-# INLINE sepBy1 #-} 238 | 239 | -- | @'sepEndBy' p sep@ parses /zero/ or more occurrences of @p@, separated 240 | -- and optionally ended by @sep@. Returns a list of values returned by @p@. 241 | sepEndBy :: (MonadPlus m) => m a -> m sep -> m [a] 242 | sepEndBy p sep = go id 243 | where 244 | go f = do 245 | r <- C.optional p 246 | case r of 247 | Nothing -> return (f []) 248 | Just x -> do 249 | more <- C.option False (True <$ sep) 250 | if more 251 | then go (f . (x :)) 252 | else return (f [x]) 253 | {-# INLINE sepEndBy #-} 254 | 255 | -- | @'sepEndBy1' p sep@ parses /one/ or more occurrences of @p@, separated 256 | -- and optionally ended by @sep@. Returns a list of values returned by @p@. 257 | sepEndBy1 :: (MonadPlus m) => m a -> m sep -> m [a] 258 | sepEndBy1 p sep = do 259 | x <- p 260 | more <- C.option False (True <$ sep) 261 | if more 262 | then (x :) <$> sepEndBy p sep 263 | else return [x] 264 | {-# INLINE sepEndBy1 #-} 265 | 266 | -- | @'skipMany' p@ applies the parser @p@ /zero/ or more times, skipping 267 | -- its result. 268 | -- 269 | -- See also: 'manyTill', 'skipManyTill'. 270 | skipMany :: (MonadPlus m) => m a -> m () 271 | skipMany p = go 272 | where 273 | go = do 274 | more <- C.option False (True <$ p) 275 | when more go 276 | {-# INLINE skipMany #-} 277 | 278 | -- | @'skipSome' p@ applies the parser @p@ /one/ or more times, skipping its 279 | -- result. 280 | -- 281 | -- See also: 'someTill', 'skipSomeTill'. 282 | skipSome :: (MonadPlus m) => m a -> m () 283 | skipSome p = p >> skipMany p 284 | {-# INLINE skipSome #-} 285 | 286 | -- | @'skipCount' n p@ parses @n@ occurrences of @p@, skipping its result. 287 | -- If @n@ is smaller or equal to zero, the parser equals to @'return' ()@. 288 | -- 289 | -- See also: 'count', 'count''. 290 | skipCount :: (Monad m) => Int -> m a -> m () 291 | skipCount n' p = go n' 292 | where 293 | go !n = 294 | unless (n <= 0) $ 295 | p >> go (n - 1) 296 | {-# INLINE skipCount #-} 297 | 298 | -- | @'skipManyTill' p end@ applies the parser @p@ /zero/ or more times 299 | -- skipping results until parser @end@ succeeds. Result parsed by @end@ is 300 | -- then returned. 301 | -- 302 | -- See also: 'manyTill', 'skipMany'. 303 | skipManyTill :: (MonadPlus m) => m a -> m end -> m end 304 | skipManyTill p end = go 305 | where 306 | go = do 307 | r <- C.optional end 308 | case r of 309 | Nothing -> p >> go 310 | Just x -> return x 311 | {-# INLINE skipManyTill #-} 312 | 313 | -- | @'skipSomeTill' p end@ applies the parser @p@ /one/ or more times 314 | -- skipping results until parser @end@ succeeds. Result parsed by @end@ is 315 | -- then returned. 316 | -- 317 | -- See also: 'someTill', 'skipSome'. 318 | skipSomeTill :: (MonadPlus m) => m a -> m end -> m end 319 | skipSomeTill p end = p >> skipManyTill p end 320 | {-# INLINE skipSomeTill #-} 321 | -------------------------------------------------------------------------------- /Control/Monad/Combinators/Expr.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Control.Monad.Combinators.Expr 3 | -- Copyright : © 2017–present Mark Karpov 4 | -- License : BSD 3 clause 5 | -- 6 | -- Maintainer : Mark Karpov 7 | -- Stability : experimental 8 | -- Portability : non-portable 9 | -- 10 | -- A helper module to parse expressions. It can build a parser given a table 11 | -- of operators. 12 | -- 13 | -- @since 1.0.0 14 | module Control.Monad.Combinators.Expr 15 | ( Operator (..), 16 | makeExprParser, 17 | ) 18 | where 19 | 20 | import Control.Monad 21 | import Control.Monad.Combinators 22 | 23 | -- | This data type specifies operators that work on values of type @a@. An 24 | -- operator is either binary infix or unary prefix or postfix. A binary 25 | -- operator has also an associated associativity. 26 | data Operator m a 27 | = -- | Non-associative infix 28 | InfixN (m (a -> a -> a)) 29 | | -- | Left-associative infix 30 | InfixL (m (a -> a -> a)) 31 | | -- | Right-associative infix 32 | InfixR (m (a -> a -> a)) 33 | | -- | Prefix 34 | Prefix (m (a -> a)) 35 | | -- | Postfix 36 | Postfix (m (a -> a)) 37 | | -- | Right-associative ternary. Right-associative means that 38 | -- @a ? b : d ? e : f@ parsed as 39 | -- @a ? b : (d ? e : f)@ and not as @(a ? b : d) ? e : f@. 40 | -- 41 | -- The outer monadic action parses the first separator (e.g. @?@) and 42 | -- returns an action (of type @m (a -> a -> a -> a)@) that parses the 43 | -- second separator (e.g. @:@). 44 | -- 45 | -- Example usage: 46 | -- 47 | -- >>> TernR ((If <$ char ':') <$ char '?') 48 | TernR (m (m (a -> a -> a -> a))) 49 | 50 | -- | @'makeExprParser' term table@ builds an expression parser for terms 51 | -- @term@ with operators from @table@, taking the associativity and 52 | -- precedence specified in the @table@ into account. 53 | -- 54 | -- @table@ is a list of @[Operator m a]@ lists. The list is ordered in 55 | -- descending precedence. All operators in one list have the same precedence 56 | -- (but may have different associativity). 57 | -- 58 | -- Prefix and postfix operators of the same precedence associate to the left 59 | -- (i.e. if @++@ is postfix increment, than @-2++@ equals @-1@, not @-3@). 60 | -- 61 | -- Unary operators of the same precedence can only occur once (i.e. @--2@ is 62 | -- not allowed if @-@ is prefix negate). If you need to parse several prefix 63 | -- or postfix operators in a row, (like C pointers—@**i@) you can use this 64 | -- approach: 65 | -- 66 | -- > manyUnaryOp = foldr1 (.) <$> some singleUnaryOp 67 | -- 68 | -- This is not done by default because in some cases allowing repeating 69 | -- prefix or postfix operators is not desirable. 70 | -- 71 | -- If you want to have an operator that is a prefix of another operator in 72 | -- the table, use the following (or similar) wrapper (Megaparsec example): 73 | -- 74 | -- > op n = (lexeme . try) (string n <* notFollowedBy punctuationChar) 75 | -- 76 | -- 'makeExprParser' takes care of all the complexity involved in building an 77 | -- expression parser. Here is an example of an expression parser that 78 | -- handles prefix signs, postfix increment and basic arithmetic: 79 | -- 80 | -- > expr = makeExprParser term table "expression" 81 | -- > 82 | -- > term = parens expr <|> integer "term" 83 | -- > 84 | -- > table = [ [ prefix "-" negate 85 | -- > , prefix "+" id ] 86 | -- > , [ postfix "++" (+1) ] 87 | -- > , [ binary "*" (*) 88 | -- > , binary "/" div ] 89 | -- > , [ binary "+" (+) 90 | -- > , binary "-" (-) ] ] 91 | -- > 92 | -- > binary name f = InfixL (f <$ symbol name) 93 | -- > prefix name f = Prefix (f <$ symbol name) 94 | -- > postfix name f = Postfix (f <$ symbol name) 95 | makeExprParser :: 96 | (MonadPlus m) => 97 | -- | Term parser 98 | m a -> 99 | -- | Operator table, see 'Operator' 100 | [[Operator m a]] -> 101 | -- | Resulting expression parser 102 | m a 103 | makeExprParser = foldl addPrecLevel 104 | {-# INLINEABLE makeExprParser #-} 105 | 106 | -- | @addPrecLevel p ops@ adds the ability to parse operators in table @ops@ 107 | -- to parser @p@. 108 | addPrecLevel :: (MonadPlus m) => m a -> [Operator m a] -> m a 109 | addPrecLevel term ops = 110 | term' >>= \x -> choice [ras' x, las' x, nas' x, tern' x, return x] 111 | where 112 | (ras, las, nas, prefix, postfix, tern) = foldr splitOp ([], [], [], [], [], []) ops 113 | term' = pTerm (choice prefix) term (choice postfix) 114 | ras' = pInfixR (choice ras) term' 115 | las' = pInfixL (choice las) term' 116 | nas' = pInfixN (choice nas) term' 117 | tern' = pTernR (choice tern) term' 118 | {-# INLINEABLE addPrecLevel #-} 119 | 120 | -- | @pTerm prefix term postfix@ parses a @term@ surrounded by optional 121 | -- prefix and postfix unary operators. Parsers @prefix@ and @postfix@ are 122 | -- allowed to fail, in this case 'id' is used. 123 | pTerm :: (MonadPlus m) => m (a -> a) -> m a -> m (a -> a) -> m a 124 | pTerm prefix term postfix = do 125 | pre <- option id prefix 126 | x <- term 127 | post <- option id postfix 128 | return . post . pre $ x 129 | {-# INLINE pTerm #-} 130 | 131 | -- | @pInfixN op p x@ parses non-associative infix operator @op@, then term 132 | -- with parser @p@, then returns result of the operator application on @x@ 133 | -- and the term. 134 | pInfixN :: (MonadPlus m) => m (a -> a -> a) -> m a -> a -> m a 135 | pInfixN op p x = do 136 | f <- op 137 | y <- p 138 | return $ f x y 139 | {-# INLINE pInfixN #-} 140 | 141 | -- | @pInfixL op p x@ parses left-associative infix operator @op@, then term 142 | -- with parser @p@, then returns result of the operator application on @x@ 143 | -- and the term. 144 | pInfixL :: (MonadPlus m) => m (a -> a -> a) -> m a -> a -> m a 145 | pInfixL op p x = do 146 | f <- op 147 | y <- p 148 | let r = f x y 149 | pInfixL op p r <|> return r 150 | {-# INLINE pInfixL #-} 151 | 152 | -- | @pInfixR op p x@ parses right-associative infix operator @op@, then 153 | -- term with parser @p@, then returns result of the operator application on 154 | -- @x@ and the term. 155 | pInfixR :: (MonadPlus m) => m (a -> a -> a) -> m a -> a -> m a 156 | pInfixR op p x = do 157 | f <- op 158 | y <- p >>= \r -> pInfixR op p r <|> return r 159 | return $ f x y 160 | {-# INLINE pInfixR #-} 161 | 162 | -- | Parse the first separator of a ternary operator 163 | pTernR :: (MonadPlus m) => m (m (a -> a -> a -> a)) -> m a -> a -> m a 164 | pTernR sep1 p x = do 165 | sep2 <- sep1 166 | y <- p >>= \r -> pTernR sep1 p r `mplus` return r 167 | f <- sep2 168 | z <- p >>= \r -> pTernR sep1 p r `mplus` return r 169 | return $ f x y z 170 | {-# INLINE pTernR #-} 171 | 172 | type Batch m a = 173 | ( [m (a -> a -> a)], 174 | [m (a -> a -> a)], 175 | [m (a -> a -> a)], 176 | [m (a -> a)], 177 | [m (a -> a)], 178 | [m (m (a -> a -> a -> a))] 179 | ) 180 | 181 | -- | A helper to separate various operators (binary, unary, and according to 182 | -- associativity) and return them in a tuple. 183 | splitOp :: Operator m a -> Batch m a -> Batch m a 184 | splitOp (InfixR op) (r, l, n, pre, post, tern) = (op : r, l, n, pre, post, tern) 185 | splitOp (InfixL op) (r, l, n, pre, post, tern) = (r, op : l, n, pre, post, tern) 186 | splitOp (InfixN op) (r, l, n, pre, post, tern) = (r, l, op : n, pre, post, tern) 187 | splitOp (Prefix op) (r, l, n, pre, post, tern) = (r, l, n, op : pre, post, tern) 188 | splitOp (Postfix op) (r, l, n, pre, post, tern) = (r, l, n, pre, op : post, tern) 189 | splitOp (TernR op) (r, l, n, pre, post, tern) = (r, l, n, pre, post, op : tern) 190 | -------------------------------------------------------------------------------- /Control/Monad/Combinators/NonEmpty.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Control.Monad.Combinators.NonEmpty 3 | -- Copyright : © 2017–present Mark Karpov 4 | -- License : BSD 3 clause 5 | -- 6 | -- Maintainer : Mark Karpov 7 | -- Stability : experimental 8 | -- Portability : portable 9 | -- 10 | -- The module provides 'NonEmpty' list variants of some of the functions 11 | -- from "Control.Monad.Combinators". 12 | -- 13 | -- @since 0.4.0 14 | module Control.Monad.Combinators.NonEmpty 15 | ( some, 16 | endBy1, 17 | someTill, 18 | sepBy1, 19 | sepEndBy1, 20 | ) 21 | where 22 | 23 | import Control.Monad 24 | import qualified Control.Monad.Combinators as C 25 | import Data.List.NonEmpty (NonEmpty (..)) 26 | import qualified Data.List.NonEmpty as NE 27 | 28 | -- | @'some' p@ applies the parser @p@ /one/ or more times and returns a 29 | -- list of the values returned by @p@. 30 | -- 31 | -- > word = some letter 32 | some :: (MonadPlus m) => m a -> m (NonEmpty a) 33 | some p = NE.fromList <$> C.some p 34 | {-# INLINE some #-} 35 | 36 | -- | @'endBy1' p sep@ parses /one/ or more occurrences of @p@, separated and 37 | -- ended by @sep@. Returns a non-empty list of values returned by @p@. 38 | endBy1 :: (MonadPlus m) => m a -> m sep -> m (NonEmpty a) 39 | endBy1 p sep = NE.fromList <$> C.endBy1 p sep 40 | {-# INLINE endBy1 #-} 41 | 42 | -- | @'someTill' p end@ works similarly to @'C.manyTill' p end@, but @p@ 43 | -- should succeed at least once. 44 | -- 45 | -- See also: 'C.skipSome', 'C.skipSomeTill'. 46 | someTill :: (MonadPlus m) => m a -> m end -> m (NonEmpty a) 47 | someTill p end = NE.fromList <$> C.someTill p end 48 | {-# INLINE someTill #-} 49 | 50 | -- | @'sepBy1' p sep@ parses /one/ or more occurrences of @p@, separated by 51 | -- @sep@. Returns a non-empty list of values returned by @p@. 52 | sepBy1 :: (MonadPlus m) => m a -> m sep -> m (NonEmpty a) 53 | sepBy1 p sep = NE.fromList <$> C.sepBy1 p sep 54 | {-# INLINE sepBy1 #-} 55 | 56 | -- | @'sepEndBy1' p sep@ parses /one/ or more occurrences of @p@, separated 57 | -- and optionally ended by @sep@. Returns a non-empty list of values returned by 58 | -- @p@. 59 | sepEndBy1 :: (MonadPlus m) => m a -> m sep -> m (NonEmpty a) 60 | sepEndBy1 p sep = NE.fromList <$> C.sepEndBy1 p sep 61 | {-# INLINE sepEndBy1 #-} 62 | -------------------------------------------------------------------------------- /Control/Monad/Permutations.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Control.Monad.Permutations 3 | -- Copyright : © 2017–present Alex Washburn 4 | -- License : BSD 3 clause 5 | -- 6 | -- Maintainer : Mark Karpov 7 | -- Stability : experimental 8 | -- Portability : portable 9 | -- 10 | -- This module specialized the interface to 'Monad' for potential efficiency 11 | -- considerations, depending on the monad the permutations are run over. 12 | -- 13 | -- For a more general interface requiring only 'Applicative', and for more 14 | -- complete documentation, see the 'Control.Applicative.Permutations' module. 15 | -- 16 | -- @since 1.3.0 17 | module Control.Monad.Permutations 18 | ( -- ** Permutation type 19 | Permutation, 20 | 21 | -- ** Permutation evaluators 22 | runPermutation, 23 | intercalateEffect, 24 | 25 | -- ** Permutation constructors 26 | toPermutation, 27 | toPermutationWithDefault, 28 | ) 29 | where 30 | 31 | import Control.Applicative 32 | 33 | -- | An 'Applicative' wrapper-type for constructing permutation parsers. 34 | data Permutation m a = P !(Maybe a) (m (Permutation m a)) 35 | 36 | instance (Functor m) => Functor (Permutation m) where 37 | fmap f (P v p) = P (f <$> v) (fmap f <$> p) 38 | 39 | instance (Alternative m) => Applicative (Permutation m) where 40 | pure value = P (Just value) empty 41 | lhs@(P f v) <*> rhs@(P g w) = P (f <*> g) (lhsAlt <|> rhsAlt) 42 | where 43 | lhsAlt = (<*> rhs) <$> v 44 | rhsAlt = (lhs <*>) <$> w 45 | liftA2 f lhs@(P x v) rhs@(P y w) = P (liftA2 f x y) (lhsAlt <|> rhsAlt) 46 | where 47 | lhsAlt = (\p -> liftA2 f p rhs) <$> v 48 | rhsAlt = liftA2 f lhs <$> w 49 | 50 | -- | \"Unlifts\" a permutation parser into a parser to be evaluated. 51 | runPermutation :: 52 | ( Alternative m, 53 | Monad m 54 | ) => 55 | -- | Permutation specification 56 | Permutation m a -> 57 | -- | Resulting base monad capable of handling the permutation 58 | m a 59 | runPermutation (P value parser) = optional parser >>= f 60 | where 61 | f Nothing = maybe empty pure value 62 | f (Just p) = runPermutation p 63 | 64 | -- | \"Unlifts\" a permutation parser into a parser to be evaluated with an 65 | -- intercalated effect. Useful for separators between permutation elements. 66 | intercalateEffect :: 67 | ( Alternative m, 68 | Monad m 69 | ) => 70 | -- | Effect to be intercalated between permutation components 71 | m b -> 72 | -- | Permutation specification 73 | Permutation m a -> 74 | -- | Resulting base monad capable of handling the permutation 75 | m a 76 | intercalateEffect = run noEffect 77 | where 78 | noEffect = pure () 79 | run :: (Alternative m, Monad m) => m c -> m b -> Permutation m a -> m a 80 | run headSep tailSep (P value parser) = optional (headSep *> parser) >>= f 81 | where 82 | f Nothing = maybe empty pure value 83 | f (Just p) = run tailSep tailSep p 84 | 85 | -- | \"Lifts\" a parser to a permutation parser. 86 | toPermutation :: 87 | (Alternative m) => 88 | -- | Permutation component 89 | m a -> 90 | Permutation m a 91 | toPermutation p = P Nothing $ pure <$> p 92 | 93 | -- | \"Lifts\" a parser with a default value to a permutation parser. 94 | -- 95 | -- If no permutation containing the supplied parser can be parsed from the input, 96 | -- then the supplied default value is returned in lieu of a parse result. 97 | toPermutationWithDefault :: 98 | (Alternative m) => 99 | -- | Default Value 100 | a -> 101 | -- | Permutation component 102 | m a -> 103 | Permutation m a 104 | toPermutationWithDefault v p = P (Just v) $ pure <$> p 105 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | Copyright © 2017–present Mark Karpov 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright notice, 9 | this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above copyright 12 | notice, this list of conditions and the following disclaimer in the 13 | documentation and/or other materials provided with the distribution. 14 | 15 | * Neither the name Mark Karpov nor the names of contributors may be used to 16 | endorse or promote products derived from this software without specific 17 | prior written permission. 18 | 19 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY EXPRESS 20 | OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES 21 | OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN 22 | NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, 23 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 24 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, 25 | OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 26 | LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, 28 | EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Parser combinators 2 | 3 | [![License BSD3](https://img.shields.io/badge/license-BSD3-brightgreen.svg)](http://opensource.org/licenses/BSD-3-Clause) 4 | [![Hackage](https://img.shields.io/hackage/v/parser-combinators.svg?style=flat)](https://hackage.haskell.org/package/parser-combinators) 5 | [![Stackage Nightly](http://stackage.org/package/parser-combinators/badge/nightly)](http://stackage.org/nightly/package/parser-combinators) 6 | [![Stackage LTS](http://stackage.org/package/parser-combinators/badge/lts)](http://stackage.org/lts/package/parser-combinators) 7 | [![CI](https://github.com/mrkkrp/parser-combinators/actions/workflows/ci.yaml/badge.svg)](https://github.com/mrkkrp/parser-combinators/actions/workflows/ci.yaml) 8 | 9 | The package provides common parser combinators defined in terms of 10 | `Applicative` and `Alternative` without any dependencies but `base`. There 11 | are also more efficient versions of the combinators defined in terms of 12 | `Monad` and `MonadPlus`. 13 | 14 | ## Contribution 15 | 16 | Issues, bugs, and questions may be reported in [the GitHub issue tracker for 17 | this project](https://github.com/mrkkrp/parser-combinators/issues). 18 | 19 | Pull requests are also welcome. 20 | 21 | ## License 22 | 23 | Copyright © 2017–present Mark Karpov 24 | 25 | Distributed under BSD 3 clause license. 26 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . parser-combinators-tests 2 | tests: True 3 | benchmarks: True 4 | constraints: parser-combinators +dev, parser-combinators-tests +dev 5 | -------------------------------------------------------------------------------- /parser-combinators-tests/LICENSE.md: -------------------------------------------------------------------------------- 1 | Copyright © 2017–2019 Mark Karpov 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright notice, 9 | this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above copyright 12 | notice, this list of conditions and the following disclaimer in the 13 | documentation and/or other materials provided with the distribution. 14 | 15 | * Neither the name Mark Karpov nor the names of contributors may be used to 16 | endorse or promote products derived from this software without specific 17 | prior written permission. 18 | 19 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY EXPRESS 20 | OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES 21 | OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN 22 | NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, 23 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 24 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, 25 | OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 26 | LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27 | NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, 28 | EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | -------------------------------------------------------------------------------- /parser-combinators-tests/README.md: -------------------------------------------------------------------------------- 1 | # Parser combinators tests 2 | 3 | A test suite for the `parser-combinators` package as a separate package. 4 | This allows us to avoid a circular dependency with `megaparsec` (which 5 | depends on `parser-combinators`). 6 | 7 | ## License 8 | 9 | Copyright © 2017–present Mark Karpov 10 | 11 | Distributed under BSD 3 clause license. 12 | -------------------------------------------------------------------------------- /parser-combinators-tests/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /parser-combinators-tests/parser-combinators-tests.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | name: parser-combinators-tests 3 | version: 1.3.0 4 | license: BSD-3-Clause 5 | license-file: LICENSE.md 6 | maintainer: Mark Karpov 7 | author: Mark Karpov 8 | tested-with: ghc ==9.6.3 ghc ==9.8.2 ghc ==9.10.1 9 | homepage: https://github.com/mrkkrp/parser-combinators 10 | bug-reports: https://github.com/mrkkrp/parser-combinators/issues 11 | synopsis: Test suite of parser-combinators 12 | description: Test suite of parser-combinators. 13 | category: Parsing 14 | build-type: Simple 15 | extra-doc-files: README.md 16 | 17 | source-repository head 18 | type: git 19 | location: https://github.com/mrkkrp/parser-combinators.git 20 | 21 | flag dev 22 | description: Turn on development settings. 23 | default: False 24 | manual: True 25 | 26 | test-suite test-suite 27 | type: exitcode-stdio-1.0 28 | main-is: Spec.hs 29 | build-tools: hspec-discover >=2 && <3 30 | hs-source-dirs: tests 31 | other-modules: 32 | Control.Applicative.CombinatorsSpec 33 | Control.Applicative.PermutationsSpec 34 | Control.Monad.Combinators.ExprSpec 35 | Control.Monad.CombinatorsSpec 36 | Control.Monad.PermutationsSpec 37 | 38 | default-language: Haskell2010 39 | build-depends: 40 | QuickCheck >=2.7 && <2.16, 41 | base >=4.15 && <5, 42 | hspec >=2.0 && <3, 43 | hspec-megaparsec >=2 && <3, 44 | megaparsec >=8 && <10, 45 | megaparsec-tests >=8 && <10, 46 | parser-combinators ==1.3.0 47 | 48 | if flag(dev) 49 | ghc-options: 50 | -Wall -Werror -Wredundant-constraints -Wpartial-fields 51 | -Wunused-packages 52 | 53 | else 54 | ghc-options: -O2 -Wall 55 | 56 | if impl(ghc >=9.8) 57 | ghc-options: -Wno-x-partial 58 | -------------------------------------------------------------------------------- /parser-combinators-tests/tests/Control/Applicative/CombinatorsSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiWayIf #-} 2 | 3 | module Control.Applicative.CombinatorsSpec (spec) where 4 | 5 | import Control.Applicative.Combinators 6 | import Data.Char (isDigit, isLetter) 7 | import Data.List (intersperse) 8 | import Data.Maybe (fromJust, fromMaybe, isNothing, maybeToList) 9 | import Test.Hspec 10 | import Test.Hspec.Megaparsec 11 | import Test.Hspec.Megaparsec.AdHoc 12 | import Test.QuickCheck 13 | import Text.Megaparsec.Char 14 | 15 | spec :: Spec 16 | spec = do 17 | describe "between" $ 18 | it "works" . property $ \pre c n' post -> do 19 | let p = between (string pre) (string post) (many (char c)) 20 | n = getNonNegative n' 21 | b = length (takeWhile (== c) post) 22 | z = replicate n c 23 | s = pre ++ z ++ post 24 | if b > 0 25 | then 26 | prs_ p s 27 | `shouldFailWith` err 28 | (length pre + n + b) 29 | ( etoks post 30 | <> etok c 31 | <> if length post == b 32 | then ueof 33 | else utoks (drop b post) 34 | ) 35 | else prs_ p s `shouldParse` z 36 | 37 | describe "choice" $ 38 | it "works" . property $ \cs' s' -> do 39 | let cs = getNonEmpty cs' 40 | p = choice (char <$> cs) 41 | s = [s'] 42 | if s' `elem` cs 43 | then prs_ p s `shouldParse` s' 44 | else prs_ p s `shouldFailWith` err 0 (utok s' <> mconcat (etok <$> cs)) 45 | 46 | describe "count" $ do 47 | it "works" . property $ \n x' -> do 48 | let x = getNonNegative x' 49 | p = count n (char 'x') 50 | p' = count' n n (char 'x') 51 | s = replicate x 'x' 52 | prs_ p s `shouldBe` prs_ p' s 53 | rightOrder (count 3 letterChar) "abc" "abc" 54 | 55 | describe "count'" $ do 56 | it "works" . property $ \m n x' -> do 57 | let x = getNonNegative x' 58 | p = count' m n (char 'x') 59 | s = replicate x 'x' 60 | if 61 | | n <= 0 || m > n -> 62 | if x == 0 63 | then prs_ p s `shouldParse` "" 64 | else prs_ p s `shouldFailWith` err 0 (utok 'x' <> eeof) 65 | | m <= x && x <= n -> 66 | prs_ p s `shouldParse` s 67 | | x < m -> 68 | prs_ p s `shouldFailWith` err x (ueof <> etok 'x') 69 | | otherwise -> 70 | prs_ p s `shouldFailWith` err n (utok 'x' <> eeof) 71 | rightOrder (count' 1 3 letterChar) "abc" "abc" 72 | 73 | describe "eitherP" $ 74 | it "works" . property $ \ch -> do 75 | let p = eitherP letterChar digitChar 76 | s = pure ch 77 | if 78 | | isLetter ch -> prs_ p s `shouldParse` Left ch 79 | | isDigit ch -> prs_ p s `shouldParse` Right ch 80 | | otherwise -> 81 | prs_ p s 82 | `shouldFailWith` err 0 (utok ch <> elabel "letter" <> elabel "digit") 83 | 84 | describe "endBy" $ do 85 | it "works" . property $ \n' c -> do 86 | let n = getNonNegative n' 87 | p = endBy (char 'a') (char '-') 88 | s = intersperse '-' (replicate n 'a') ++ [c] 89 | if 90 | | c == 'a' && n == 0 -> 91 | prs_ p s `shouldFailWith` err 1 (ueof <> etok '-') 92 | | c == 'a' -> 93 | prs_ p s `shouldFailWith` err (g n) (utok 'a' <> etok '-') 94 | | c == '-' && n == 0 -> 95 | prs_ p s `shouldFailWith` err 0 (utok '-' <> etok 'a' <> eeof) 96 | | c /= '-' -> 97 | prs_ p s 98 | `shouldFailWith` err 99 | (g n) 100 | ( utok c 101 | <> (if n > 0 then etok '-' else eeof) 102 | <> (if n == 0 then etok 'a' else mempty) 103 | ) 104 | | otherwise -> prs_ p s `shouldParse` replicate n 'a' 105 | rightOrder (endBy letterChar (char ',')) "a,b,c," "abc" 106 | 107 | describe "endBy1" $ do 108 | it "works" . property $ \n' c -> do 109 | let n = getNonNegative n' 110 | p = endBy1 (char 'a') (char '-') 111 | s = intersperse '-' (replicate n 'a') ++ [c] 112 | if 113 | | c == 'a' && n == 0 -> 114 | prs_ p s `shouldFailWith` err 1 (ueof <> etok '-') 115 | | c == 'a' -> 116 | prs_ p s `shouldFailWith` err (g n) (utok 'a' <> etok '-') 117 | | c == '-' && n == 0 -> 118 | prs_ p s `shouldFailWith` err 0 (utok '-' <> etok 'a') 119 | | c /= '-' -> 120 | prs_ p s 121 | `shouldFailWith` err 122 | (g n) 123 | ( utok c 124 | <> (if n > 0 then etok '-' else mempty) 125 | <> (if n == 0 then etok 'a' else mempty) 126 | ) 127 | | otherwise -> prs_ p s `shouldParse` replicate n 'a' 128 | rightOrder (endBy1 letterChar (char ',')) "a,b,c," "abc" 129 | 130 | describe "manyTill" $ do 131 | it "works" . property $ \(NonNegative a) (NonNegative b) (NonNegative c) -> do 132 | let p = (,) <$> manyTill letterChar (char 'c') <*> many letterChar 133 | s = abcRow a b c 134 | if c == 0 135 | then 136 | prs_ p s 137 | `shouldFailWith` err 138 | (a + b) 139 | (ueof <> etok 'c' <> elabel "letter") 140 | else 141 | let (pre, post) = break (== 'c') s 142 | in prs_ p s `shouldParse` (pre, drop 1 post) 143 | rightOrder (manyTill letterChar (char 'd')) "abcd" "abc" 144 | 145 | describe "manyTill_" $ do 146 | it "works" . property $ \(NonNegative a) (NonNegative b) (NonNegative c) -> do 147 | let p = (,) <$> manyTill_ letterChar (char 'c') <*> many letterChar 148 | s = abcRow a b c 149 | if c == 0 150 | then 151 | prs_ p s 152 | `shouldFailWith` err 153 | (a + b) 154 | (ueof <> etok 'c' <> elabel "letter") 155 | else 156 | let (pre, post) = break (== 'c') s 157 | in prs_ p s `shouldParse` ((pre, 'c'), drop 1 post) 158 | rightOrder (fst <$> manyTill_ letterChar (char 'd')) "abcd" "abc" 159 | 160 | describe "someTill" $ do 161 | it "works" . property $ \(NonNegative a) (NonNegative b) (NonNegative c) -> do 162 | let p = (,) <$> someTill letterChar (char 'c') <*> many letterChar 163 | s = abcRow a b c 164 | if 165 | | null s -> 166 | prs_ p s `shouldFailWith` err 0 (ueof <> elabel "letter") 167 | | c == 0 -> 168 | prs_ p s 169 | `shouldFailWith` err 170 | (a + b) 171 | (ueof <> etok 'c' <> elabel "letter") 172 | | s == "c" -> 173 | prs_ p s `shouldFailWith` err 1 (ueof <> etok 'c' <> elabel "letter") 174 | | head s == 'c' -> 175 | prs_ p s `shouldParse` ("c", drop 2 s) 176 | | otherwise -> 177 | let (pre, post) = break (== 'c') s 178 | in prs_ p s `shouldParse` (pre, drop 1 post) 179 | rightOrder (someTill letterChar (char 'd')) "abcd" "abc" 180 | 181 | describe "someTill_" $ do 182 | it "works" . property $ \(NonNegative a) (NonNegative b) (NonNegative c) -> do 183 | let p = (,) <$> someTill_ letterChar (char 'c') <*> many letterChar 184 | s = abcRow a b c 185 | if 186 | | null s -> 187 | prs_ p s `shouldFailWith` err 0 (ueof <> elabel "letter") 188 | | c == 0 -> 189 | prs_ p s 190 | `shouldFailWith` err 191 | (a + b) 192 | (ueof <> etok 'c' <> elabel "letter") 193 | | s == "c" -> 194 | prs_ p s `shouldFailWith` err 1 (ueof <> etok 'c' <> elabel "letter") 195 | | head s == 'c' -> 196 | prs_ p s `shouldParse` (("c", 'c'), drop 2 s) 197 | | otherwise -> 198 | let (pre, post) = break (== 'c') s 199 | in prs_ p s `shouldParse` ((pre, 'c'), drop 1 post) 200 | rightOrder (fst <$> someTill_ letterChar (char 'd')) "abcd" "abc" 201 | 202 | describe "option" $ 203 | it "works" . property $ \d a s -> do 204 | let p = option d (string a) 205 | p' = fromMaybe d <$> optional (string a) 206 | prs_ p s `shouldBe` prs_ p' s 207 | 208 | describe "sepBy" $ do 209 | it "works" . property $ \n' c' -> do 210 | let n = getNonNegative n' 211 | c = fromJust c' 212 | p = sepBy (char 'a') (char '-') 213 | s = intersperse '-' (replicate n 'a') ++ maybeToList c' 214 | if 215 | | isNothing c' -> 216 | prs_ p s `shouldParse` replicate n 'a' 217 | | c == 'a' && n == 0 -> 218 | prs_ p s `shouldParse` "a" 219 | | n == 0 -> 220 | prs_ p s `shouldFailWith` err 0 (utok c <> etok 'a' <> eeof) 221 | | c == '-' -> 222 | prs_ p s `shouldFailWith` err (length s) (ueof <> etok 'a') 223 | | otherwise -> 224 | prs_ p s `shouldFailWith` err (g n) (utok c <> etok '-' <> eeof) 225 | rightOrder (sepBy letterChar (char ',')) "a,b,c" "abc" 226 | 227 | describe "sepBy1" $ do 228 | it "works" . property $ \n' c' -> do 229 | let n = getNonNegative n' 230 | c = fromJust c' 231 | p = sepBy1 (char 'a') (char '-') 232 | s = intersperse '-' (replicate n 'a') ++ maybeToList c' 233 | if 234 | | isNothing c' && n >= 1 -> 235 | prs_ p s `shouldParse` replicate n 'a' 236 | | isNothing c' -> 237 | prs_ p s `shouldFailWith` err 0 (ueof <> etok 'a') 238 | | c == 'a' && n == 0 -> 239 | prs_ p s `shouldParse` "a" 240 | | n == 0 -> 241 | prs_ p s `shouldFailWith` err 0 (utok c <> etok 'a') 242 | | c == '-' -> 243 | prs_ p s `shouldFailWith` err (length s) (ueof <> etok 'a') 244 | | otherwise -> 245 | prs_ p s `shouldFailWith` err (g n) (utok c <> etok '-' <> eeof) 246 | rightOrder (sepBy1 letterChar (char ',')) "a,b,c" "abc" 247 | 248 | describe "sepEndBy" $ do 249 | it "works" . property $ \n' c' -> do 250 | let n = getNonNegative n' 251 | c = fromJust c' 252 | p = sepEndBy (char 'a') (char '-') 253 | a = replicate n 'a' 254 | s = intersperse '-' (replicate n 'a') ++ maybeToList c' 255 | if 256 | | isNothing c' -> 257 | prs_ p s `shouldParse` a 258 | | c == 'a' && n == 0 -> 259 | prs_ p s `shouldParse` "a" 260 | | n == 0 -> 261 | prs_ p s `shouldFailWith` err 0 (utok c <> etok 'a' <> eeof) 262 | | c == '-' -> 263 | prs_ p s `shouldParse` a 264 | | otherwise -> 265 | prs_ p s `shouldFailWith` err (g n) (utok c <> etok '-' <> eeof) 266 | rightOrder (sepEndBy letterChar (char ',')) "a,b,c," "abc" 267 | 268 | describe "sepEndBy1" $ do 269 | it "works" . property $ \n' c' -> do 270 | let n = getNonNegative n' 271 | c = fromJust c' 272 | p = sepEndBy1 (char 'a') (char '-') 273 | a = replicate n 'a' 274 | s = intersperse '-' (replicate n 'a') ++ maybeToList c' 275 | if 276 | | isNothing c' && n >= 1 -> 277 | prs_ p s `shouldParse` a 278 | | isNothing c' -> 279 | prs_ p s `shouldFailWith` err 0 (ueof <> etok 'a') 280 | | c == 'a' && n == 0 -> 281 | prs_ p s `shouldParse` "a" 282 | | n == 0 -> 283 | prs_ p s `shouldFailWith` err 0 (utok c <> etok 'a') 284 | | c == '-' -> 285 | prs_ p s `shouldParse` a 286 | | otherwise -> 287 | prs_ p s `shouldFailWith` err (g n) (utok c <> etok '-' <> eeof) 288 | rightOrder (sepEndBy1 letterChar (char ',')) "a,b,c," "abc" 289 | 290 | describe "skipMany" $ 291 | it "works" . property $ \c n' a -> do 292 | let p = skipMany (char c) *> string a 293 | n = getNonNegative n' 294 | p' = many (char c) >> string a 295 | s = replicate n c ++ a 296 | prs_ p s `shouldBe` prs_ p' s 297 | 298 | describe "skipSome" $ 299 | it "works" . property $ \c n' a -> do 300 | let p = skipSome (char c) *> string a 301 | n = getNonNegative n' 302 | p' = some (char c) >> string a 303 | s = replicate n c ++ a 304 | prs_ p s `shouldBe` prs_ p' s 305 | 306 | describe "skipCount" $ 307 | it "works" . property $ \c n' a -> do 308 | let p = skipCount n (char c) *> string a 309 | n = getNonNegative n' 310 | p' = count n (char c) *> string a 311 | s = replicate n c ++ a 312 | prs_ p s `shouldBe` prs_ p' s 313 | 314 | describe "skipManyTill" $ 315 | it "works" . property $ \c n' a -> 316 | c /= a ==> do 317 | let p = skipManyTill (char c) (char a) 318 | n = getNonNegative n' 319 | s = replicate n c ++ [a] 320 | prs_ p s `shouldParse` a 321 | 322 | describe "skipSomeTill" $ 323 | it "works" . property $ \c n' a -> 324 | c /= a ==> do 325 | let p = skipSomeTill (char c) (char a) 326 | n = getNonNegative n' 327 | s = replicate n c ++ [a] 328 | if n == 0 329 | then prs_ p s `shouldFailWith` err 0 (utok a <> etok c) 330 | else prs_ p s `shouldParse` a 331 | 332 | ---------------------------------------------------------------------------- 333 | -- Helpers 334 | 335 | g :: Int -> Int 336 | g x = x + if x > 0 then x - 1 else 0 337 | -------------------------------------------------------------------------------- /parser-combinators-tests/tests/Control/Applicative/PermutationsSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | 3 | module Control.Applicative.PermutationsSpec (spec) where 4 | 5 | import Control.Applicative.Permutations 6 | import Control.Monad 7 | import Data.List 8 | import Data.Void 9 | import Test.Hspec 10 | import Test.Hspec.Megaparsec 11 | import Test.Hspec.Megaparsec.AdHoc 12 | import Test.QuickCheck 13 | import Text.Megaparsec 14 | import Text.Megaparsec.Char 15 | 16 | spec :: Spec 17 | spec = do 18 | describe "runPermutation & Permutation" $ do 19 | describe "Functor instance" $ do 20 | it "obeys identity law" $ 21 | property $ \n -> 22 | prsp (fmap id (pure (n :: Int))) "" 23 | === prsp (id (pure n)) "" 24 | it "obeys composition law" $ 25 | property $ \n m t -> 26 | let f = (+ m) 27 | g = (* t) 28 | in prs (fmap (f . g) (pure (n :: Int))) "" 29 | === prs ((fmap f . fmap g) (pure n)) "" 30 | describe "Applicative instance" $ do 31 | it "obeys identity law" $ 32 | property $ \n -> 33 | prsp (pure id <*> pure (n :: Int)) "" 34 | === prsp (pure n) "" 35 | it "obeys composition law" $ 36 | property $ \n m t -> 37 | let u = pure (+ m) 38 | v = pure (* t) 39 | w = pure (n :: Int) 40 | in prsp (pure (.) <*> u <*> v <*> w) "" 41 | === prsp (u <*> (v <*> w)) "" 42 | it "obeys homomorphism law" $ 43 | property $ \x m -> 44 | let f = (+ m) 45 | in prsp (pure f <*> pure (x :: Int)) "" 46 | === prsp (pure (f x)) "" 47 | it "obeys interchange law" $ 48 | property $ \n y -> 49 | let u = pure (+ n) 50 | in prsp (u <*> pure (y :: Int)) "" 51 | === prsp (pure ($ y) <*> u) "" 52 | describe "toPermutation" $ 53 | it "works" $ 54 | property $ \xs s' -> forAll (shuffle xs) $ \ys -> do 55 | let s = ys ++ s' 56 | p = foldr f (pure []) xs 57 | f x p' = (:) <$> toPermutation (char x) <*> p' 58 | prsp p s `shouldParse` xs 59 | prsp' p s `succeedsLeaving` s' 60 | describe "intercalateEffect" $ 61 | it "works" $ 62 | property $ \e xs s' -> 63 | let preconditions f = 64 | foldr1 65 | (.||.) 66 | [ -- Zero permutation targets will cause problems 67 | property $ null xs, 68 | -- If the effect is the prefix of the suffix, it will fail 69 | not (null s') .&&. e == head s', 70 | f 71 | ] 72 | in preconditions $ 73 | forAll (intersperse e <$> shuffle xs) $ \ys -> do 74 | let s = ys ++ s' 75 | p = intercalateEffect (char e) $ foldr f (pure []) xs 76 | f x p' = (:) <$> toPermutation (char x) <*> p' 77 | prs p s `shouldParse` xs 78 | prs' p s `succeedsLeaving` s' 79 | describe "toPermutationWithDefault" $ do 80 | let testCases = 81 | [ ("abc", "abc", ""), 82 | ("acb", "abc", ""), 83 | ("bac", "abc", ""), 84 | ("bca", "abc", ""), 85 | ("cab", "abc", ""), 86 | ("cba", "abc", ""), 87 | ("aab", "ayz", "ab"), 88 | ("aba", "abz", "a"), 89 | ("baa", "abz", "a"), 90 | ("bba", "xbz", "ba"), 91 | ("bab", "abz", "b"), 92 | ("abb", "abz", "b"), 93 | ("cca", "xyc", "ca"), 94 | ("cac", "ayc", "c"), 95 | ("acc", "ayc", "c"), 96 | ("aaa", "ayz", "aa"), 97 | ("bbb", "xbz", "bb"), 98 | ("ccc", "xyc", "cc"), 99 | ("q", "xyz", "q"), 100 | ("", "xyz", "") 101 | ] 102 | forM_ testCases $ \(i, o, r) -> 103 | it ("parses \"" ++ i ++ "\" as \"" ++ o ++ "\" leaving \"" ++ r ++ "\"") $ do 104 | prsp testPermParser i `shouldParse` o 105 | prsp' testPermParser i `succeedsLeaving` r 106 | describe "intercalateEffect (with default)" $ do 107 | let p = intercalateEffect (char ',') testPermParser 108 | testCases = 109 | [ ("a,b,c", "abc", ""), 110 | ("a,c,b", "abc", ""), 111 | ("b,a,c", "abc", ""), 112 | ("b,c,a", "abc", ""), 113 | ("c,a,b", "abc", ""), 114 | ("c,b,a", "abc", ""), 115 | ("aab", "ayz", "ab"), 116 | ("a,ba", "abz", "a"), 117 | ("b,aa", "abz", "a"), 118 | ("bba", "xbz", "ba"), 119 | ("b,ab", "abz", "b"), 120 | ("a,bb", "abz", "b"), 121 | ("cca", "xyc", "ca"), 122 | ("c,ac", "ayc", "c"), 123 | ("a,cc", "ayc", "c"), 124 | ("aaa", "ayz", "aa"), 125 | ("bbb", "xbz", "bb"), 126 | ("ccc", "xyc", "cc"), 127 | ("!", "xyz", "!"), 128 | (",", "xyz", ","), 129 | ("", "xyz", "") 130 | ] 131 | forM_ testCases $ \(i, o, r) -> 132 | it ("parses \"" ++ i ++ "\" as \"" ++ o ++ "\" leaving \"" ++ r ++ "\"") $ do 133 | prs p i `shouldParse` o 134 | prs' p i `succeedsLeaving` r 135 | 136 | prsp :: 137 | Permutation Parser a -> 138 | String -> 139 | Either (ParseErrorBundle String Void) a 140 | prsp p = prs (runPermutation p) 141 | 142 | prsp' :: 143 | Permutation Parser a -> 144 | String -> 145 | (State String Void, Either (ParseErrorBundle String Void) a) 146 | prsp' p = prs' (runPermutation p) 147 | 148 | testPermParser :: Permutation Parser String 149 | testPermParser = 150 | f 151 | <$> toPermutationWithDefault 'x' (char 'a') 152 | <*> toPermutationWithDefault 'y' (char 'b') 153 | <*> toPermutationWithDefault 'z' (char 'c') 154 | where 155 | f a b c = [a, b, c] 156 | -------------------------------------------------------------------------------- /parser-combinators-tests/tests/Control/Monad/Combinators/ExprSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | 4 | module Control.Monad.Combinators.ExprSpec (spec) where 5 | 6 | import Control.Monad 7 | import Control.Monad.Combinators.Expr 8 | import Test.Hspec 9 | import Test.Hspec.Megaparsec 10 | import Test.Hspec.Megaparsec.AdHoc 11 | import Test.QuickCheck 12 | import Text.Megaparsec 13 | import Text.Megaparsec.Char 14 | 15 | spec :: Spec 16 | spec = 17 | describe "makeExprParser" $ do 18 | context "when given valid rendered AST" $ 19 | it "can parse it back" $ 20 | property $ \node -> do 21 | let s = showNode node 22 | prs expr s `shouldParse` node 23 | prs' expr s `succeedsLeaving` "" 24 | context "when stream in empty" $ 25 | it "signals correct parse error" $ 26 | prs (expr <* eof) "" 27 | `shouldFailWith` err 28 | 0 29 | (ueof <> etok '-' <> elabel "term") 30 | context "when term is missing" $ 31 | it "signals correct parse error" $ do 32 | let p = expr <* eof 33 | prs p "-" `shouldFailWith` err 1 (ueof <> elabel "term") 34 | prs p "(" `shouldFailWith` err 1 (ueof <> etok '-' <> elabel "term") 35 | prs p "*" `shouldFailWith` err 0 (utok '*' <> etok '-' <> elabel "term") 36 | context "operator is missing" $ 37 | it "signals correct parse error" $ 38 | property $ \a b -> do 39 | let p = expr <* eof 40 | a' = inParens a 41 | n = length a' + 1 42 | s = a' ++ " " ++ inParens b 43 | c = s !! n 44 | if c == '-' 45 | then prs p s `shouldParse` Sub a b 46 | else 47 | prs p s 48 | `shouldFailWith` err 49 | n 50 | ( mconcat 51 | [ utok c, 52 | eeof, 53 | etok '!', 54 | etok '%', 55 | etok '*', 56 | etok '+', 57 | etok '-', 58 | etok '/', 59 | etok '?', 60 | etok '^' 61 | ] 62 | ) 63 | 64 | data Node 65 | = -- | literal value 66 | Val Integer 67 | | -- | negation (prefix unary) 68 | Neg Node 69 | | -- | factorial (postfix unary) 70 | Fac Node 71 | | -- | modulo 72 | Mod Node Node 73 | | -- | summation (addition) 74 | Sum Node Node 75 | | -- | subtraction 76 | Sub Node Node 77 | | -- | product 78 | Pro Node Node 79 | | -- | division 80 | Div Node Node 81 | | -- | exponentiation 82 | Exp Node Node 83 | | -- | ternary conditional operator 84 | If Node Node Node 85 | deriving (Eq, Show) 86 | 87 | instance Enum Node where 88 | fromEnum (Val _) = 0 89 | fromEnum (Neg _) = 0 90 | fromEnum (Fac _) = 0 91 | fromEnum (Mod _ _) = 0 92 | fromEnum (Exp _ _) = 1 93 | fromEnum (Pro _ _) = 2 94 | fromEnum (Div _ _) = 2 95 | fromEnum (Sum _ _) = 3 96 | fromEnum (Sub _ _) = 3 97 | fromEnum (If _ _ _) = 4 98 | toEnum _ = error "Oops!" 99 | 100 | instance Ord Node where 101 | x `compare` y = fromEnum x `compare` fromEnum y 102 | 103 | showNode :: Node -> String 104 | showNode (Val x) = show x 105 | showNode n@(Neg x) = "-" ++ showGT n x 106 | showNode n@(Fac x) = showGT n x ++ "!" 107 | showNode n@(Mod x y) = showGE n x ++ " % " ++ showGE n y 108 | showNode n@(Sum x y) = showGT n x ++ " + " ++ showGE n y 109 | showNode n@(Sub x y) = showGT n x ++ " - " ++ showGE n y 110 | showNode n@(Pro x y) = showGT n x ++ " * " ++ showGE n y 111 | showNode n@(Div x y) = showGT n x ++ " / " ++ showGE n y 112 | showNode n@(Exp x y) = showGE n x ++ " ^ " ++ showGT n y 113 | showNode n@(If c x y) = showGE n c ++ " ? " ++ showGT n x ++ " : " ++ showGT n y 114 | 115 | showGT :: Node -> Node -> String 116 | showGT parent node = (if node > parent then showCmp else showNode) node 117 | 118 | showGE :: Node -> Node -> String 119 | showGE parent node = (if node >= parent then showCmp else showNode) node 120 | 121 | showCmp :: Node -> String 122 | showCmp node = (if fromEnum node == 0 then showNode else inParens) node 123 | 124 | inParens :: Node -> String 125 | inParens x = "(" ++ showNode x ++ ")" 126 | 127 | instance Arbitrary Node where 128 | arbitrary = sized arbitraryN0 129 | 130 | arbitraryN0 :: Int -> Gen Node 131 | arbitraryN0 n = 132 | frequency 133 | [ (1, Mod <$> leaf <*> leaf), 134 | (9, arbitraryN1 n) 135 | ] 136 | where 137 | leaf = arbitraryN1 (n `div` 2) 138 | 139 | arbitraryN1 :: Int -> Gen Node 140 | arbitraryN1 n = 141 | frequency 142 | [ (1, Neg <$> arbitraryN2 n), 143 | (1, Fac <$> arbitraryN2 n), 144 | (7, arbitraryN2 n) 145 | ] 146 | 147 | arbitraryN2 :: Int -> Gen Node 148 | arbitraryN2 0 = Val . getNonNegative <$> arbitrary 149 | arbitraryN2 n = 150 | (join . elements) 151 | [ pure Sum, 152 | pure Sub, 153 | pure Pro, 154 | pure Div, 155 | pure Exp, 156 | If <$> leaf 157 | ] 158 | <*> leaf 159 | <*> leaf 160 | where 161 | leaf = arbitraryN0 (n `div` 2) 162 | 163 | lexeme :: Parser a -> Parser a 164 | lexeme p = p <* hidden space 165 | 166 | symbol :: String -> Parser String 167 | symbol = lexeme . string 168 | 169 | parens :: Parser a -> Parser a 170 | parens = between (symbol "(") (symbol ")") 171 | 172 | integer :: Parser Integer 173 | integer = lexeme (read <$> some digitChar "integer") 174 | 175 | -- Here we use a table of operators that makes use of all features of 176 | -- 'makeExprParser'. Then we generate abstract syntax tree (AST) of complex 177 | -- but valid expressions and render them to get their textual 178 | -- representation. 179 | 180 | expr :: Parser Node 181 | expr = makeExprParser term table 182 | 183 | term :: Parser Node 184 | term = parens expr <|> (Val <$> integer) "term" 185 | 186 | table :: [[Operator Parser Node]] 187 | table = 188 | [ [ Prefix (Neg <$ symbol "-"), 189 | Postfix (Fac <$ symbol "!"), 190 | InfixN (Mod <$ symbol "%") 191 | ], 192 | [InfixR (Exp <$ symbol "^")], 193 | [ InfixL (Pro <$ symbol "*"), 194 | InfixL (Div <$ symbol "/") 195 | ], 196 | [ InfixL (Sum <$ symbol "+"), 197 | InfixL (Sub <$ symbol "-") 198 | ], 199 | [TernR ((If <$ symbol ":") <$ symbol "?")] 200 | ] 201 | -------------------------------------------------------------------------------- /parser-combinators-tests/tests/Control/Monad/CombinatorsSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiWayIf #-} 2 | 3 | module Control.Monad.CombinatorsSpec (spec) where 4 | 5 | import Control.Monad.Combinators 6 | import Data.List (intersperse) 7 | import Data.Maybe (fromJust, isNothing, maybeToList) 8 | import Test.Hspec 9 | import Test.Hspec.Megaparsec 10 | import Test.Hspec.Megaparsec.AdHoc 11 | import Test.QuickCheck 12 | import Text.Megaparsec.Char 13 | 14 | spec :: Spec 15 | spec = do 16 | describe "count" $ do 17 | it "works" . property $ \n x' -> do 18 | let x = getNonNegative x' 19 | p = count n (char 'x') 20 | p' = count' n n (char 'x') 21 | s = replicate x 'x' 22 | prs_ p s `shouldBe` prs_ p' s 23 | rightOrder (count 3 letterChar) "abc" "abc" 24 | 25 | describe "count'" $ do 26 | it "works" . property $ \m n x' -> do 27 | let x = getNonNegative x' 28 | p = count' m n (char 'x') 29 | s = replicate x 'x' 30 | if 31 | | n <= 0 || m > n -> 32 | if x == 0 33 | then prs_ p s `shouldParse` "" 34 | else prs_ p s `shouldFailWith` err 0 (utok 'x' <> eeof) 35 | | m <= x && x <= n -> 36 | prs_ p s `shouldParse` s 37 | | x < m -> 38 | prs_ p s `shouldFailWith` err x (ueof <> etok 'x') 39 | | otherwise -> 40 | prs_ p s `shouldFailWith` err n (utok 'x' <> eeof) 41 | rightOrder (count' 1 3 letterChar) "abc" "abc" 42 | 43 | describe "endBy" $ do 44 | it "works" . property $ \n' c -> do 45 | let n = getNonNegative n' 46 | p = endBy (char 'a') (char '-') 47 | s = intersperse '-' (replicate n 'a') ++ [c] 48 | if 49 | | c == 'a' && n == 0 -> 50 | prs_ p s `shouldFailWith` err 1 (ueof <> etok '-') 51 | | c == 'a' -> 52 | prs_ p s `shouldFailWith` err (g n) (utok 'a' <> etok '-') 53 | | c == '-' && n == 0 -> 54 | prs_ p s `shouldFailWith` err 0 (utok '-' <> etok 'a' <> eeof) 55 | | c /= '-' -> 56 | prs_ p s 57 | `shouldFailWith` err 58 | (g n) 59 | ( utok c 60 | <> (if n > 0 then etok '-' else eeof) 61 | <> (if n == 0 then etok 'a' else mempty) 62 | ) 63 | | otherwise -> prs_ p s `shouldParse` replicate n 'a' 64 | rightOrder (endBy letterChar (char ',')) "a,b,c," "abc" 65 | 66 | describe "endBy1" $ do 67 | it "works" . property $ \n' c -> do 68 | let n = getNonNegative n' 69 | p = endBy1 (char 'a') (char '-') 70 | s = intersperse '-' (replicate n 'a') ++ [c] 71 | if 72 | | c == 'a' && n == 0 -> 73 | prs_ p s `shouldFailWith` err (1 :: Int) (ueof <> etok '-') 74 | | c == 'a' -> 75 | prs_ p s `shouldFailWith` err (g n) (utok 'a' <> etok '-') 76 | | c == '-' && n == 0 -> 77 | prs_ p s `shouldFailWith` err 0 (utok '-' <> etok 'a') 78 | | c /= '-' -> 79 | prs_ p s 80 | `shouldFailWith` err 81 | (g n) 82 | ( utok c 83 | <> (if n > 0 then etok '-' else mempty) 84 | <> (if n == 0 then etok 'a' else mempty) 85 | ) 86 | | otherwise -> prs_ p s `shouldParse` replicate n 'a' 87 | rightOrder (endBy1 letterChar (char ',')) "a,b,c," "abc" 88 | 89 | describe "manyTill" $ do 90 | it "works" . property $ \(NonNegative a) (NonNegative b) (NonNegative c) -> do 91 | let p = (,) <$> manyTill letterChar (char 'c') <*> many letterChar 92 | s = abcRow a b c 93 | if c == 0 94 | then 95 | prs_ p s 96 | `shouldFailWith` err 97 | (a + b) 98 | (ueof <> etok 'c' <> elabel "letter") 99 | else 100 | let (pre, post) = break (== 'c') s 101 | in prs_ p s `shouldParse` (pre, drop 1 post) 102 | rightOrder (manyTill letterChar (char 'd')) "abcd" "abc" 103 | 104 | describe "manyTill_" $ do 105 | it "works" . property $ \(NonNegative a) (NonNegative b) (NonNegative c) -> do 106 | let p = (,) <$> manyTill_ letterChar (char 'c') <*> many letterChar 107 | s = abcRow a b c 108 | if c == 0 109 | then 110 | prs_ p s 111 | `shouldFailWith` err 112 | (a + b) 113 | (ueof <> etok 'c' <> elabel "letter") 114 | else 115 | let (pre, post) = break (== 'c') s 116 | in prs_ p s `shouldParse` ((pre, 'c'), drop 1 post) 117 | rightOrder (fmap fst . manyTill_ letterChar $ char 'd') "abcd" "abc" 118 | 119 | describe "someTill" $ do 120 | it "works" . property $ \(NonNegative a) (NonNegative b) (NonNegative c) -> do 121 | let p = (,) <$> someTill letterChar (char 'c') <*> many letterChar 122 | s = abcRow a b c 123 | if 124 | | null s -> 125 | prs_ p s `shouldFailWith` err 0 (ueof <> elabel "letter") 126 | | c == 0 -> 127 | prs_ p s 128 | `shouldFailWith` err 129 | (a + b) 130 | (ueof <> etok 'c' <> elabel "letter") 131 | | s == "c" -> 132 | prs_ p s `shouldFailWith` err 1 (ueof <> etok 'c' <> elabel "letter") 133 | | head s == 'c' -> 134 | prs_ p s `shouldParse` ("c", drop 2 s) 135 | | otherwise -> 136 | let (pre, post) = break (== 'c') s 137 | in prs_ p s `shouldParse` (pre, drop 1 post) 138 | rightOrder (someTill letterChar (char 'd')) "abcd" "abc" 139 | 140 | describe "someTill_" $ do 141 | it "works" . property $ \(NonNegative a) (NonNegative b) (NonNegative c) -> do 142 | let p = (,) <$> someTill_ letterChar (char 'c') <*> many letterChar 143 | s = abcRow a b c 144 | if 145 | | null s -> 146 | prs_ p s `shouldFailWith` err 0 (ueof <> elabel "letter") 147 | | c == 0 -> 148 | prs_ p s 149 | `shouldFailWith` err 150 | (a + b) 151 | (ueof <> etok 'c' <> elabel "letter") 152 | | s == "c" -> 153 | prs_ p s `shouldFailWith` err 1 (ueof <> etok 'c' <> elabel "letter") 154 | | head s == 'c' -> 155 | prs_ p s `shouldParse` (("c", 'c'), drop 2 s) 156 | | otherwise -> 157 | let (pre, post) = break (== 'c') s 158 | in prs_ p s `shouldParse` ((pre, 'c'), drop 1 post) 159 | rightOrder (fmap fst . someTill_ letterChar $ char 'd') "abcd" "abc" 160 | 161 | describe "sepBy" $ do 162 | it "works" . property $ \n' c' -> do 163 | let n = getNonNegative n' 164 | c = fromJust c' 165 | p = sepBy (char 'a') (char '-') 166 | s = intersperse '-' (replicate n 'a') ++ maybeToList c' 167 | if 168 | | isNothing c' -> 169 | prs_ p s `shouldParse` replicate n 'a' 170 | | c == 'a' && n == 0 -> 171 | prs_ p s `shouldParse` "a" 172 | | n == 0 -> 173 | prs_ p s `shouldFailWith` err 0 (utok c <> etok 'a' <> eeof) 174 | | c == '-' -> 175 | prs_ p s `shouldFailWith` err (length s) (ueof <> etok 'a') 176 | | otherwise -> 177 | prs_ p s `shouldFailWith` err (g n) (utok c <> etok '-' <> eeof) 178 | rightOrder (sepBy letterChar (char ',')) "a,b,c" "abc" 179 | 180 | describe "sepBy1" $ do 181 | it "works" . property $ \n' c' -> do 182 | let n = getNonNegative n' 183 | c = fromJust c' 184 | p = sepBy1 (char 'a') (char '-') 185 | s = intersperse '-' (replicate n 'a') ++ maybeToList c' 186 | if 187 | | isNothing c' && n >= 1 -> 188 | prs_ p s `shouldParse` replicate n 'a' 189 | | isNothing c' -> 190 | prs_ p s `shouldFailWith` err 0 (ueof <> etok 'a') 191 | | c == 'a' && n == 0 -> 192 | prs_ p s `shouldParse` "a" 193 | | n == 0 -> 194 | prs_ p s `shouldFailWith` err 0 (utok c <> etok 'a') 195 | | c == '-' -> 196 | prs_ p s `shouldFailWith` err (length s) (ueof <> etok 'a') 197 | | otherwise -> 198 | prs_ p s `shouldFailWith` err (g n) (utok c <> etok '-' <> eeof) 199 | rightOrder (sepBy1 letterChar (char ',')) "a,b,c" "abc" 200 | 201 | describe "sepEndBy" $ do 202 | it "works" . property $ \n' c' -> do 203 | let n = getNonNegative n' 204 | c = fromJust c' 205 | p = sepEndBy (char 'a') (char '-') 206 | a = replicate n 'a' 207 | s = intersperse '-' (replicate n 'a') ++ maybeToList c' 208 | if 209 | | isNothing c' -> 210 | prs_ p s `shouldParse` a 211 | | c == 'a' && n == 0 -> 212 | prs_ p s `shouldParse` "a" 213 | | n == 0 -> 214 | prs_ p s `shouldFailWith` err 0 (utok c <> etok 'a' <> eeof) 215 | | c == '-' -> 216 | prs_ p s `shouldParse` a 217 | | otherwise -> 218 | prs_ p s `shouldFailWith` err (g n) (utok c <> etok '-' <> eeof) 219 | rightOrder (sepEndBy letterChar (char ',')) "a,b,c," "abc" 220 | 221 | describe "sepEndBy1" $ do 222 | it "works" . property $ \n' c' -> do 223 | let n = getNonNegative n' 224 | c = fromJust c' 225 | p = sepEndBy1 (char 'a') (char '-') 226 | a = replicate n 'a' 227 | s = intersperse '-' (replicate n 'a') ++ maybeToList c' 228 | if 229 | | isNothing c' && n >= 1 -> 230 | prs_ p s `shouldParse` a 231 | | isNothing c' -> 232 | prs_ p s `shouldFailWith` err 0 (ueof <> etok 'a') 233 | | c == 'a' && n == 0 -> 234 | prs_ p s `shouldParse` "a" 235 | | n == 0 -> 236 | prs_ p s `shouldFailWith` err 0 (utok c <> etok 'a') 237 | | c == '-' -> 238 | prs_ p s `shouldParse` a 239 | | otherwise -> 240 | prs_ p s `shouldFailWith` err (g n) (utok c <> etok '-' <> eeof) 241 | rightOrder (sepEndBy1 letterChar (char ',')) "a,b,c," "abc" 242 | 243 | describe "skipMany" $ 244 | it "works" . property $ \c n' a -> do 245 | let p = skipMany (char c) *> string a 246 | n = getNonNegative n' 247 | p' = many (char c) >> string a 248 | s = replicate n c ++ a 249 | prs_ p s `shouldBe` prs_ p' s 250 | 251 | describe "skipSome" $ 252 | it "works" . property $ \c n' a -> do 253 | let p = skipSome (char c) *> string a 254 | n = getNonNegative n' 255 | p' = some (char c) >> string a 256 | s = replicate n c ++ a 257 | prs_ p s `shouldBe` prs_ p' s 258 | 259 | describe "skipCount" $ 260 | it "works" . property $ \c n' a -> do 261 | let p = skipCount n (char c) *> string a 262 | n = getNonNegative n' 263 | p' = count n (char c) *> string a 264 | s = replicate n c ++ a 265 | prs_ p s `shouldBe` prs_ p' s 266 | 267 | describe "skipManyTill" $ 268 | it "works" . property $ \c n' a -> 269 | c /= a ==> do 270 | let p = skipManyTill (char c) (char a) 271 | n = getNonNegative n' 272 | s = replicate n c ++ [a] 273 | prs_ p s `shouldParse` a 274 | 275 | describe "skipSomeTill" $ 276 | it "works" . property $ \c n' a -> 277 | c /= a ==> do 278 | let p = skipSomeTill (char c) (char a) 279 | n = getNonNegative n' 280 | s = replicate n c ++ [a] 281 | if n == 0 282 | then prs_ p s `shouldFailWith` err 0 (utok a <> etok c) 283 | else prs_ p s `shouldParse` a 284 | 285 | ---------------------------------------------------------------------------- 286 | -- Helpers 287 | 288 | g :: Int -> Int 289 | g x = x + if x > 0 then x - 1 else 0 290 | -------------------------------------------------------------------------------- /parser-combinators-tests/tests/Control/Monad/PermutationsSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | 3 | module Control.Monad.PermutationsSpec (spec) where 4 | 5 | import Control.Monad 6 | import Control.Monad.Permutations 7 | import Data.List 8 | import Data.Void 9 | import Test.Hspec 10 | import Test.Hspec.Megaparsec 11 | import Test.Hspec.Megaparsec.AdHoc 12 | import Test.QuickCheck 13 | import Text.Megaparsec 14 | import Text.Megaparsec.Char 15 | 16 | spec :: Spec 17 | spec = do 18 | describe "runPermutation & Permutation" $ do 19 | describe "Functor instance" $ do 20 | it "obeys identity law" $ 21 | property $ \n -> 22 | prsp (fmap id (pure (n :: Int))) "" 23 | === prsp (id (pure n)) "" 24 | it "obeys composition law" $ 25 | property $ \n m t -> 26 | let f = (+ m) 27 | g = (* t) 28 | in prs (fmap (f . g) (pure (n :: Int))) "" 29 | === prs ((fmap f . fmap g) (pure n)) "" 30 | describe "Applicative instance" $ do 31 | it "obeys identity law" $ 32 | property $ \n -> 33 | prsp (pure id <*> pure (n :: Int)) "" 34 | === prsp (pure n) "" 35 | it "obeys composition law" $ 36 | property $ \n m t -> 37 | let u = pure (+ m) 38 | v = pure (* t) 39 | w = pure (n :: Int) 40 | in prsp (pure (.) <*> u <*> v <*> w) "" 41 | === prsp (u <*> (v <*> w)) "" 42 | it "obeys homomorphism law" $ 43 | property $ \x m -> 44 | let f = (+ m) 45 | in prsp (pure f <*> pure (x :: Int)) "" 46 | === prsp (pure (f x)) "" 47 | it "obeys interchange law" $ 48 | property $ \n y -> 49 | let u = pure (+ n) 50 | in prsp (u <*> pure (y :: Int)) "" 51 | === prsp (pure ($ y) <*> u) "" 52 | describe "toPermutation" $ 53 | it "works" $ 54 | property $ \xs s' -> forAll (shuffle xs) $ \ys -> do 55 | let s = ys ++ s' 56 | p = foldr f (pure []) xs 57 | f x p' = (:) <$> toPermutation (char x) <*> p' 58 | prsp p s `shouldParse` xs 59 | prsp' p s `succeedsLeaving` s' 60 | describe "intercalateEffect" $ 61 | it "works" $ 62 | property $ \e xs s' -> 63 | let preconditions f = 64 | foldr1 65 | (.||.) 66 | [ -- Zero permutation targets will cause problems 67 | property $ null xs, 68 | -- If the effect is the prefix of the suffix, it will fail 69 | not (null s') .&&. e == head s', 70 | f 71 | ] 72 | in preconditions $ 73 | forAll (intersperse e <$> shuffle xs) $ \ys -> do 74 | let s = ys ++ s' 75 | p = intercalateEffect (char e) $ foldr f (pure []) xs 76 | f x p' = (:) <$> toPermutation (char x) <*> p' 77 | prs p s `shouldParse` xs 78 | prs' p s `succeedsLeaving` s' 79 | describe "toPermutationWithDefault" $ do 80 | let testCases = 81 | [ ("abc", "abc", ""), 82 | ("acb", "abc", ""), 83 | ("bac", "abc", ""), 84 | ("bca", "abc", ""), 85 | ("cab", "abc", ""), 86 | ("cba", "abc", ""), 87 | ("aab", "ayz", "ab"), 88 | ("aba", "abz", "a"), 89 | ("baa", "abz", "a"), 90 | ("bba", "xbz", "ba"), 91 | ("bab", "abz", "b"), 92 | ("abb", "abz", "b"), 93 | ("cca", "xyc", "ca"), 94 | ("cac", "ayc", "c"), 95 | ("acc", "ayc", "c"), 96 | ("aaa", "ayz", "aa"), 97 | ("bbb", "xbz", "bb"), 98 | ("ccc", "xyc", "cc"), 99 | ("q", "xyz", "q"), 100 | ("", "xyz", "") 101 | ] 102 | forM_ testCases $ \(i, o, r) -> 103 | it ("parses \"" ++ i ++ "\" as \"" ++ o ++ "\" leaving \"" ++ r ++ "\"") $ do 104 | prsp testPermParser i `shouldParse` o 105 | prsp' testPermParser i `succeedsLeaving` r 106 | describe "intercalateEffect (with default)" $ do 107 | let p = intercalateEffect (char ',') testPermParser 108 | testCases = 109 | [ ("a,b,c", "abc", ""), 110 | ("a,c,b", "abc", ""), 111 | ("b,a,c", "abc", ""), 112 | ("b,c,a", "abc", ""), 113 | ("c,a,b", "abc", ""), 114 | ("c,b,a", "abc", ""), 115 | ("aab", "ayz", "ab"), 116 | ("a,ba", "abz", "a"), 117 | ("b,aa", "abz", "a"), 118 | ("bba", "xbz", "ba"), 119 | ("b,ab", "abz", "b"), 120 | ("a,bb", "abz", "b"), 121 | ("cca", "xyc", "ca"), 122 | ("c,ac", "ayc", "c"), 123 | ("a,cc", "ayc", "c"), 124 | ("aaa", "ayz", "aa"), 125 | ("bbb", "xbz", "bb"), 126 | ("ccc", "xyc", "cc"), 127 | ("!", "xyz", "!"), 128 | (",", "xyz", ","), 129 | ("", "xyz", "") 130 | ] 131 | forM_ testCases $ \(i, o, r) -> 132 | it ("parses \"" ++ i ++ "\" as \"" ++ o ++ "\" leaving \"" ++ r ++ "\"") $ do 133 | prs p i `shouldParse` o 134 | prs' p i `succeedsLeaving` r 135 | 136 | prsp :: 137 | Permutation Parser a -> 138 | String -> 139 | Either (ParseErrorBundle String Void) a 140 | prsp p = prs (runPermutation p) 141 | 142 | prsp' :: 143 | Permutation Parser a -> 144 | String -> 145 | (State String Void, Either (ParseErrorBundle String Void) a) 146 | prsp' p = prs' (runPermutation p) 147 | 148 | testPermParser :: Permutation Parser String 149 | testPermParser = 150 | f 151 | <$> toPermutationWithDefault 'x' (char 'a') 152 | <*> toPermutationWithDefault 'y' (char 'b') 153 | <*> toPermutationWithDefault 'z' (char 'c') 154 | where 155 | f a b c = [a, b, c] 156 | -------------------------------------------------------------------------------- /parser-combinators-tests/tests/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /parser-combinators.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | name: parser-combinators 3 | version: 1.3.0 4 | license: BSD-3-Clause 5 | license-file: LICENSE.md 6 | maintainer: Mark Karpov 7 | author: 8 | Mark Karpov 9 | Alex Washburn 10 | 11 | tested-with: ghc ==9.8.4 ghc ==9.10.1 ghc ==9.12.1 12 | homepage: https://github.com/mrkkrp/parser-combinators 13 | bug-reports: https://github.com/mrkkrp/parser-combinators/issues 14 | synopsis: 15 | Lightweight package providing commonly useful parser combinators 16 | 17 | description: 18 | Lightweight package providing commonly useful parser combinators. 19 | 20 | category: Parsing 21 | build-type: Simple 22 | extra-doc-files: 23 | CHANGELOG.md 24 | README.md 25 | 26 | source-repository head 27 | type: git 28 | location: https://github.com/mrkkrp/parser-combinators.git 29 | 30 | flag dev 31 | description: Turn on development settings. 32 | default: False 33 | manual: True 34 | 35 | library 36 | exposed-modules: 37 | Control.Applicative.Combinators 38 | Control.Applicative.Combinators.NonEmpty 39 | Control.Applicative.Permutations 40 | Control.Monad.Combinators 41 | Control.Monad.Combinators.Expr 42 | Control.Monad.Combinators.NonEmpty 43 | Control.Monad.Permutations 44 | 45 | default-language: Haskell2010 46 | build-depends: base >=4.15 && <5 47 | 48 | if flag(dev) 49 | ghc-options: 50 | -Wall -Werror -Wredundant-constraints -Wpartial-fields 51 | -Wunused-packages 52 | 53 | else 54 | ghc-options: -O2 -Wall 55 | --------------------------------------------------------------------------------