├── .gitignore ├── .vscode └── settings.json ├── CHANGELOG.md ├── README.md ├── Setup.hs ├── bench ├── Main.hs ├── Parsers.hs └── res │ ├── depth_15.lam │ └── depth_5.lam ├── cabal.project ├── flake.lock ├── flake.nix ├── fourmolu.yaml ├── sage.cabal ├── src ├── Streaming │ ├── Chars.hs │ └── Chars │ │ ├── ByteString │ │ └── Utf8.hs │ │ └── Text.hs └── Text │ ├── Sage.hs │ └── Sage │ └── Indentation.hs └── test ├── Main.hs └── Test ├── Indentation.hs ├── Parser.hs └── Span.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist-newstyle/ 2 | 3 | .envrc 4 | .direnv/ 5 | -------------------------------------------------------------------------------- /.vscode/settings.json: -------------------------------------------------------------------------------- 1 | { 2 | "haskell.formattingProvider": "fourmolu" 3 | } -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for sage 2 | 3 | ## 0.2 4 | 5 | * Use `base >=4.16` (GHC 9.2) 6 | * Use `text >=2.0` 7 | 8 | ## 0.1 9 | 10 | * Initial release 11 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # sage 2 | 3 | Efficient parser combinators for modern Haskell. 4 | 5 | Sage is about 10% faster and twice as memory-efficient as Attoparsec. 6 | 7 | Inspired by Ed Kmett's [parsnip](https://github.com/ekmett/codex/tree/master/parsnip) parser, 8 | which for some reason I thought was called 'parsley'. (I don't care for root vegetable puns) 9 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | 3 | main = defaultMain 4 | -------------------------------------------------------------------------------- /bench/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns 5 | -ddump-simpl 6 | -ddump-to-file 7 | -dsuppress-idinfo 8 | -dsuppress-coercions 9 | -dsuppress-type-applications 10 | -dsuppress-uniques 11 | -dsuppress-module-prefixes #-} 12 | 13 | module Main where 14 | 15 | import Control.Applicative (many, some, (<**>), (<|>)) 16 | import Control.DeepSeq (NFData) 17 | import Criterion.Main 18 | import qualified Data.Attoparsec.Text as Attoparsec 19 | import Data.ByteString (ByteString) 20 | import qualified Data.ByteString as ByteString 21 | import Data.Char (isLower) 22 | import qualified Data.Either as Either 23 | import Data.String (IsString) 24 | import Data.Text (Text) 25 | import qualified Data.Text as Text 26 | import qualified Data.Text.Encoding as Text.Encoding 27 | import qualified Data.Text.IO as Text (readFile) 28 | import GHC.Generics (Generic) 29 | import qualified Options.Applicative as Options 30 | import Parsers (parsersBench) 31 | import Streaming.Chars (Chars) 32 | import Streaming.Chars.ByteString.Utf8 (StreamUtf8 (StreamUtf8)) 33 | import Streaming.Chars.Text (StreamText (StreamText)) 34 | import System.Environment (withArgs) 35 | import qualified System.IO.MMap as Mmap 36 | import Text.Parser.Char (CharParsing, anyChar, char, satisfy, text) 37 | import Text.Parser.Combinators (between, eof, sepBy) 38 | import qualified Text.Sage as Parser 39 | import Weigh 40 | 41 | data Expr = Var Text | Lam Text Expr | App Expr Expr 42 | deriving (Generic, Show) 43 | 44 | instance NFData Expr 45 | 46 | {-# INLINE expr #-} 47 | expr :: (CharParsing m) => m Expr 48 | expr = 49 | lambda 50 | <|> app 51 | where 52 | spaces = (char ' ' *> spaces) <|> pure () 53 | 54 | ident = fmap Text.pack (some $ satisfy isLower) <* spaces 55 | 56 | lambda = 57 | Lam 58 | <$ char '\\' 59 | <* spaces 60 | <*> ident 61 | <* char '-' 62 | <* char '>' 63 | <* spaces 64 | <*> expr 65 | 66 | atom = 67 | Var <$> ident <* spaces 68 | <|> between (char '(' *> spaces) (char ')' <* spaces) expr 69 | 70 | app = foldl App <$> atom <*> many atom 71 | 72 | {-# INLINEABLE parseLambda #-} 73 | parseLambda :: (Chars s) => s -> Either Parser.ParseError Expr 74 | parseLambda = Parser.parse expr 75 | 76 | {-# NOINLINE parseLambdaText #-} 77 | parseLambdaText :: Text -> Either Parser.ParseError Expr 78 | parseLambdaText = Parser.parse expr . StreamText 79 | 80 | {-# NOINLINE parseLambdaBS #-} 81 | parseLambdaBS :: ByteString -> Either Parser.ParseError Expr 82 | parseLambdaBS = Parser.parse expr . StreamUtf8 83 | 84 | {-# NOINLINE parseLambdaAP #-} 85 | parseLambdaAP :: Text -> Either String Expr 86 | parseLambdaAP = Attoparsec.parseOnly expr 87 | 88 | manySymbols :: Text -> Either Parser.ParseError Int 89 | manySymbols = Parser.parse (ps <* eof) . StreamText 90 | where 91 | ps = (+) <$> p <*> (char ' ' *> ps <|> pure 0) 92 | p = 93 | 1 <$ text "hello" 94 | <|> 2 <$ text "goopy" 95 | <|> 3 <$ text "wonder" 96 | <|> 4 <$ text "several" 97 | <|> 5 <$ text "plato" 98 | <|> 6 <$ text "ticklish" 99 | 100 | manyTextsNaive :: Text -> Either Parser.ParseError Int 101 | manyTextsNaive = Parser.parse (ps <* eof) . StreamText 102 | where 103 | t :: (Chars s) => Text -> Parser.Parser s () 104 | t = Text.foldr (\c rest -> char c *> rest) (pure ()) 105 | 106 | ps = (+) <$> p <*> (char ' ' *> ps <|> pure 0) 107 | p = 108 | 1 <$ t "hello" 109 | <|> 2 <$ t "goopy" 110 | <|> 3 <$ t "wonder" 111 | <|> 4 <$ t "several" 112 | <|> 5 <$ t "plato" 113 | <|> 6 <$ t "ticklish" 114 | 115 | manyTexts :: Text -> Either Parser.ParseError Int 116 | manyTexts = Parser.parse (ps <* eof) . StreamText 117 | where 118 | ps = (+) <$> p <*> (char ' ' *> ps <|> pure 0) 119 | p = 120 | 1 <$ Parser.string "hello" 121 | <|> 2 <$ Parser.string "goopy" 122 | <|> 3 <$ Parser.string "wonder" 123 | <|> 4 <$ Parser.string "several" 124 | <|> 5 <$ Parser.string "plato" 125 | <|> 6 <$ Parser.string "ticklish" 126 | 127 | manyTextsAP :: Text -> Attoparsec.Result Int 128 | manyTextsAP = Attoparsec.parse (ps <* Attoparsec.endOfInput) 129 | where 130 | ps = (+) <$> p <*> (Attoparsec.char ' ' *> ps <|> pure 0) 131 | 132 | p = 133 | 1 <$ Attoparsec.string "hello" 134 | <|> 2 <$ Attoparsec.string "goopy" 135 | <|> 3 <$ Attoparsec.string "wonder" 136 | <|> 4 <$ Attoparsec.string "several" 137 | <|> 5 <$ Attoparsec.string "plato" 138 | <|> 6 <$ Attoparsec.string "ticklish" 139 | 140 | commasep :: Text -> Either Parser.ParseError [Char] 141 | commasep = Parser.parse (sepBy (char 'a') (char ',') <* eof) . StreamText 142 | 143 | commasepAP :: Text -> Attoparsec.Result [Char] 144 | commasepAP = Attoparsec.parse (Attoparsec.sepBy (Attoparsec.char 'a') (Attoparsec.char ',') <* Attoparsec.endOfInput) 145 | 146 | lipsum :: (IsString s) => s 147 | lipsum = "Lorem ipsum dolor sit amet, consectetur adipiscing elit. Proin consequat sodales elit eget egestas. Suspendisse eget augue accumsan velit accumsan fringilla. Nam dolor ex, pulvinar id elit quis, eleifend porta quam. Vivamus tristique fringilla enim quis cursus. Sed ex eros, volutpat quis iaculis ut, mollis quis odio. Sed id turpis quis libero varius dictum. Aliquam ut massa non diam aliquam feugiat. Vestibulum condimentum mauris vel orci aliquet iaculis. Maecenas nec est dictum, sodales lorem eu, venenatis elit. Vestibulum eu eros ac ipsum maximus bibendum eu luctus magna. Nulla vitae lorem interdum, efficitur nibh non, auctor diam. In maximus quis arcu dignissim euismod. Sed maximus et augue quis fringilla. Donec sit amet felis nec nisi finibus sagittis eget ac est. Nam at sollicitudin sapien. Cras commodo felis ac sodales eleifend. Integer vitae iaculis risus. Fusce aliquam vel leo et tristique. Sed fringilla, metus non consequat pellentesque, eros ligula vehicula ante, eget volutpat." 148 | 149 | {-# INLINEABLE sageMany #-} 150 | sageMany :: (Chars s) => s -> [Char] 151 | sageMany = Either.fromRight undefined . Parser.parse (many anyChar) 152 | 153 | {-# NOINLINE sageManyText #-} 154 | sageManyText :: Text -> [Char] 155 | sageManyText = sageMany . StreamText 156 | 157 | {-# NOINLINE attoManyText #-} 158 | attoManyText :: Text -> [Char] 159 | attoManyText = Either.fromRight undefined . Attoparsec.parseOnly (many anyChar) 160 | 161 | {-# NOINLINE sageManyBS #-} 162 | sageManyBS :: ByteString -> [Char] 163 | sageManyBS = sageMany . StreamUtf8 164 | 165 | {-# INLINEABLE sageSome #-} 166 | sageSome :: (Chars s) => s -> [Char] 167 | sageSome = Either.fromRight undefined . Parser.parse (some anyChar) 168 | 169 | {-# NOINLINE sageSomeText #-} 170 | sageSomeText :: Text -> [Char] 171 | sageSomeText = sageSome . StreamText 172 | 173 | {-# NOINLINE attoSomeText #-} 174 | attoSomeText :: Text -> [Char] 175 | attoSomeText = Either.fromRight undefined . Attoparsec.parseOnly (some anyChar) 176 | 177 | {-# NOINLINE sageSomeBS #-} 178 | sageSomeBS :: ByteString -> [Char] 179 | sageSomeBS = sageSome . StreamUtf8 180 | 181 | a1000Text :: Text 182 | a1000Text = Text.replicate 1000 "a" 183 | 184 | a1000BS :: ByteString 185 | a1000BS = Text.Encoding.encodeUtf8 a1000Text 186 | 187 | {-# INLINEABLE sageChar #-} 188 | sageChar :: (Chars s) => s -> [Char] 189 | sageChar = Either.fromRight undefined . Parser.parse (many $ char 'a') 190 | 191 | {-# NOINLINE sageCharText #-} 192 | sageCharText :: Text -> [Char] 193 | sageCharText = sageChar . StreamText 194 | 195 | {-# NOINLINE attoCharText #-} 196 | attoCharText :: Text -> [Char] 197 | attoCharText = Either.fromRight undefined . Attoparsec.parseOnly (many $ char 'a') 198 | 199 | {-# NOINLINE sageCharBS #-} 200 | sageCharBS :: ByteString -> [Char] 201 | sageCharBS = sageChar . StreamUtf8 202 | 203 | hello1000Text :: Text 204 | hello1000Text = Text.replicate 1000 "hello" 205 | 206 | hello1000BS :: ByteString 207 | hello1000BS = Text.Encoding.encodeUtf8 hello1000Text 208 | 209 | {-# INLINEABLE sageString #-} 210 | sageString :: (Chars s) => s -> [Text] 211 | sageString = Either.fromRight undefined . Parser.parse (many $ Parser.string "hello") 212 | 213 | {-# NOINLINE sageStringText #-} 214 | sageStringText :: Text -> [Text] 215 | sageStringText = sageString . StreamText 216 | 217 | {-# NOINLINE attoStringText #-} 218 | attoStringText :: Text -> [Text] 219 | attoStringText = Either.fromRight undefined . Attoparsec.parseOnly (many $ Attoparsec.string "hello") 220 | 221 | {-# NOINLINE sageStringBS #-} 222 | sageStringBS :: ByteString -> [Text] 223 | sageStringBS = sageString . StreamUtf8 224 | 225 | data Cli 226 | = Space 227 | | Time [String] 228 | 229 | cliParser :: Options.Parser Cli 230 | cliParser = 231 | Options.hsubparser $ 232 | Options.command "space" (Options.info cliSpaceParser Options.fullDesc) 233 | <> Options.command "time" (Options.info cliTimeParser Options.fullDesc) 234 | where 235 | cliSpaceParser = 236 | pure Space 237 | 238 | cliTimeParser = 239 | Time <$> many (Options.strArgument $ Options.metavar "ARG" <> Options.help "Arguments to pass to Criterion") 240 | 241 | main :: IO () 242 | main = do 243 | cli <- Options.execParser (Options.info (cliParser <**> Options.helper) Options.fullDesc) 244 | case cli of 245 | Space -> do 246 | benchSpace 247 | Time rest -> 248 | benchTime rest 249 | 250 | benchSpace :: IO () 251 | benchSpace = do 252 | file_5 <- Text.readFile "bench/res/depth_5.lam" 253 | file_5BS <- ByteString.readFile "bench/res/depth_5.lam" 254 | file_15 <- Text.readFile "bench/res/depth_15.lam" 255 | file_15BS <- ByteString.readFile "bench/res/depth_15.lam" 256 | mainWith $ do 257 | wgroup "attoparsec" $ do 258 | wgroup "Text" $ do 259 | func' "many" attoManyText lipsum 260 | func' "some" attoSomeText lipsum 261 | func' "char" attoCharText a1000Text 262 | func' "string" attoStringText hello1000Text 263 | wgroup "sage" $ do 264 | wgroup "Text" $ do 265 | func' "many" sageManyText lipsum 266 | func' "some" sageSomeText lipsum 267 | func' "char" sageCharText a1000Text 268 | func' "string" sageStringText hello1000Text 269 | wgroup "UTF-8 ByteString" $ do 270 | func' "many" sageManyBS lipsum 271 | func' "some" sageSomeBS lipsum 272 | func' "char" sageCharBS a1000BS 273 | func' "string" sageStringBS hello1000BS 274 | func "sage x (\\y -> z)" parseLambdaText "x (\\y -> z)" 275 | func "attoparsec x (\\y -> z)" parseLambdaAP "x (\\y -> z)" 276 | func "sage x (\\y -> a b c d e)" parseLambdaText "x (\\y -> a b c d e)" 277 | func "attoparsec x (\\y -> a b c d e)" parseLambdaAP "x (\\y -> a b c d e)" 278 | func "sage x (\\y -> a b c d ~)" parseLambdaText "x (\\y -> a b c d ~)" 279 | func "attoparsec x (\\y -> a b c d ~)" parseLambdaAP "x (\\y -> a b c d ~)" 280 | wgroup "32B file" $ do 281 | wgroup "just parsing" $ do 282 | func' "attoparsec" parseLambdaAP file_5 283 | wgroup "sage" $ do 284 | func' "Text" parseLambdaText file_5 285 | func' "UTF-8 ByteString" parseLambdaBS file_5BS 286 | wgroup "read file and parse" $ do 287 | io "Text" (\path -> parseLambdaText <$> Text.readFile path) "bench/res/depth_5.lam" 288 | io "UTF-8 ByteString" (\path -> parseLambdaBS <$> ByteString.readFile path) "bench/res/depth_5.lam" 289 | io "UTF-8 ByteString mmapped" (\path -> parseLambdaBS <$> Mmap.mmapFileByteString path Nothing) "bench/res/depth_5.lam" 290 | wgroup "10KB file" $ do 291 | wgroup "just parsing" $ do 292 | func' "attoparsec" parseLambdaAP file_15 293 | wgroup "sage" $ do 294 | func' "Text" parseLambdaText file_15 295 | func' "UTF-8 ByteString" parseLambdaBS file_15BS 296 | wgroup "read file and parse" $ do 297 | io "Text" (\path -> parseLambdaText <$> Text.readFile path) "bench/res/depth_15.lam" 298 | io "UTF-8 ByteString" (\path -> parseLambdaBS <$> ByteString.readFile path) "bench/res/depth_15.lam" 299 | io "UTF-8 ByteString mmapped" (\path -> parseLambdaBS <$> Mmap.mmapFileByteString path Nothing) "bench/res/depth_15.lam" 300 | 301 | benchTime :: [String] -> IO () 302 | benchTime args = 303 | withArgs args . defaultMain $ 304 | [ bgroup 305 | "sage" 306 | [ bgroup 307 | "Text" 308 | [ bench "many" $ nf sageManyText lipsum 309 | , bench "some" $ nf sageSomeText lipsum 310 | , bench "char" $ nf sageCharText a1000Text 311 | , bench "string" $ nf sageStringText hello1000Text 312 | ] 313 | , bgroup 314 | "UTF-8 ByteString" 315 | [ bench "many" $ nf sageManyBS lipsum 316 | , bench "some" $ nf sageSomeBS lipsum 317 | , bench "char" $ nf sageCharBS a1000BS 318 | , bench "string" $ nf sageStringBS hello1000BS 319 | ] 320 | ] 321 | , parsersBench 322 | , let manyGoodInput = "hello goopy wonder several plato ticklish" 323 | manyBadInput = "hello goopy wonder several plato ticklish boomy" 324 | in bgroup 325 | "combinator comparisons" 326 | [ bench "sage symbols good" $ nf (\input -> let output@Right{} = manySymbols input in output) manyGoodInput 327 | , bench "sage symbols bad" $ nf (\input -> let output@Left{} = manySymbols input in output) manyBadInput 328 | , bench "sage texts good" $ nf (\input -> let output@Right{} = manyTexts input in output) manyGoodInput 329 | , bench "sage texts bad" $ nf (\input -> let output@Left{} = manyTexts input in output) manyBadInput 330 | , bench "sage texts naive good" $ nf (\input -> let output@Right{} = manyTextsNaive input in output) manyGoodInput 331 | , bench "sage texts naive bad" $ nf (\input -> let output@Left{} = manyTextsNaive input in output) manyBadInput 332 | , bench "attoparsec texts good" $ nf (\input -> let output@Attoparsec.Partial{} = manyTextsAP input in output) manyGoodInput 333 | , bench "attoparsec texts bad" $ nf (\input -> let output@Attoparsec.Fail{} = manyTextsAP input in output) manyBadInput 334 | ] 335 | , bench "sage x (\\y -> z)" $ nf parseLambdaText "x (\\y -> z)" 336 | , bench "attoparsec x (\\y -> z)" $ nf parseLambdaAP "x (\\y -> z)" 337 | , bench "sage x (\\y -> a b c d e)" $ nf parseLambdaText "x (\\y -> a b c d e)" 338 | , bench "attoparsec x (\\y -> a b c d e)" $ nf parseLambdaAP "x (\\y -> a b c d e)" 339 | , bench "sage x (\\y -> a b c d ~)" $ nf parseLambdaText "x (\\y -> a b c d ~)" 340 | , bench "attoparsec x (\\y -> a b c d ~)" $ nf parseLambdaAP "x (\\y -> a b c d ~)" 341 | , let input = "\\x -> \\y -> x (\\z -> z y) y" 342 | in bgroup 343 | "\\x -> \\y -> x (\\z -> z y) y" 344 | [ bench "sage" $ nf parseLambdaText input 345 | , bench "attoparsec" $ nf (\i -> case parseLambdaAP i of Right x -> x; Left e -> error e) input 346 | ] 347 | , env ((,) <$> Text.readFile "bench/res/depth_5.lam" <*> ByteString.readFile "bench/res/depth_5.lam") $ \ ~(file, fileBS) -> 348 | bgroup 349 | "32B file" 350 | [ bgroup 351 | "sage" 352 | [ bench "Text" $ nf parseLambdaText file 353 | , bench "UTF-8 ByteString" $ nf parseLambdaBS fileBS 354 | ] 355 | , bench "attoparsec" $ nf parseLambdaAP file 356 | ] 357 | , env ((,) <$> Text.readFile "bench/res/depth_15.lam" <*> ByteString.readFile "bench/res/depth_15.lam") $ \ ~(file, fileBS) -> 358 | bgroup 359 | "10KB file" 360 | [ bgroup 361 | "just parsing" 362 | [ bgroup 363 | "sage" 364 | [ bench "Text" $ nf parseLambdaText file 365 | , bench "UTF-8 ByteString" $ nf parseLambdaBS fileBS 366 | ] 367 | , bench "attoparsec" $ nf parseLambdaAP file 368 | ] 369 | , bgroup 370 | "read file and parse" 371 | [ bgroup 372 | "sage" 373 | [ bench "Text" $ nfAppIO (\path -> parseLambdaText <$> Text.readFile path) "bench/res/depth_15.lam" 374 | , bench "UTF-8 ByteString" $ nfAppIO (\path -> parseLambdaBS <$> ByteString.readFile path) "bench/res/depth_15.lam" 375 | , bench "UTF-8 ByteString mmapped" $ nfAppIO (\path -> parseLambdaBS <$> Mmap.mmapFileByteString path Nothing) "bench/res/depth_15.lam" 376 | ] 377 | ] 378 | ] 379 | , let input = "a,a,a,a,a,a,a,a" 380 | in bgroup 381 | "commasep" 382 | [ bench "sage" $ nf commasep input 383 | , bench "attoparsec" $ nf commasepAP input 384 | ] 385 | ] 386 | -------------------------------------------------------------------------------- /bench/Parsers.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | module Parsers (parsersBench) where 6 | 7 | import Control.Applicative (many, some, (<|>)) 8 | import Control.DeepSeq (NFData) 9 | import Criterion.Main (Benchmark, bench, bgroup, nf) 10 | import qualified Data.Attoparsec.Text as Attoparsec 11 | import Data.Char (isLower) 12 | import Data.Text (unpack) 13 | import GHC.Generics (Generic) 14 | import Streaming.Chars (Chars) 15 | import Streaming.Chars.Text (StreamText (StreamText)) 16 | import Text.Parser.Char (CharParsing, char, satisfy, string) 17 | import Text.Parser.Combinators (between, skipMany) 18 | import qualified Text.Sage as Sage 19 | 20 | data Expr = Var String | Lam String Expr | App Expr Expr 21 | deriving (Generic) 22 | 23 | instance NFData Expr 24 | 25 | {-# INLINE expr #-} 26 | expr :: (CharParsing m) => m Expr 27 | expr = 28 | lam 29 | <|> app 30 | where 31 | ident = some (satisfy isLower) 32 | spaces = skipMany (char ' ') 33 | lam = Lam <$ char '\\' <*> ident <* spaces <* string "->" <* spaces <*> expr 34 | atom = 35 | ( between (char '(') (char ')') expr 36 | <|> Var <$> ident 37 | ) 38 | <* spaces 39 | app = foldl App <$> atom <*> many atom 40 | 41 | exprSage :: (Chars s) => Sage.Parser s Expr 42 | exprSage = expr 43 | 44 | exprAP :: Attoparsec.Parser Expr 45 | exprAP = expr 46 | 47 | parsersBench :: Benchmark 48 | parsersBench = 49 | bgroup 50 | "parsers" 51 | [ let input = "\\x -> \\y -> x (\\z -> z y) y" 52 | in bgroup 53 | (unpack input) 54 | [ bench "sage" $ nf (Sage.parse exprSage . StreamText) input 55 | , bench "attoparsec" $ nf (Attoparsec.parseOnly exprAP) input 56 | ] 57 | , let input = "\\x -> \\y -> x (\\z -> z y) y (\\x -> (\\y -> ((x y) z) (\\w -> x y w)))" 58 | in bgroup 59 | (unpack input) 60 | [ bench "sage" $ nf (Sage.parse exprSage . StreamText) input 61 | , bench "attoparsec" $ nf (Attoparsec.parseOnly exprAP) input 62 | ] 63 | ] 64 | -------------------------------------------------------------------------------- /bench/res/depth_15.lam: -------------------------------------------------------------------------------- 1 | (\c -> \awbkkvh -> (\gzfdmfh -> \sjopal -> (\bfud -> \k -> \ngncxyz -> \qhl -> uqrkf) (\r -> (\sngu -> \nppqcmxlik -> ljrqfvmop) ((\b -> lxxtipiud) (b tcye))) ((\k -> nppqcmxlik) (vecrgvmhve agfbbwi) (lqifsqtcld usy (\iqquu -> jskltx)) ((\cehzm -> efpk yqz) (k uyvmbh (\agfbbwi -> qxhrzscqfu))) (zastcukeg ly (gzfdmfh rlro) (\as -> \jgzpujcj -> vrflxw) ((\uyvmbh -> qwx bfud) (iesgl agfbbwi (\qahi -> crfpx))))) ((\uoluawg -> \whyyc -> \rwgxh -> uyvmbh lxxtipiud (\itsg -> jrppin)) (\itsg -> (\xghnn -> za zastcukeg) (\ly -> \awbkkvh -> jaqtuv) ((\pd -> kkcanpg) (uoluawg jskltx) (\jaffl -> npodgpjyyn qhl))))) (\hcxjqsatzd -> \vlgrywld -> (\lqifsqtcld -> \hzwfq -> \ly -> (\za -> kkcanpg) (iqquu tgtp) ((\me -> zvi) (\nppqcmxlik -> whyyc))) ((\c -> (\kkcanpg -> bdgonmod) (rlro r)) ((\agfbbwi -> yqz) (cehzm tgtp) (\jaffl -> \jaqtuv -> tadgzk)) (\ly -> ablxwtmde za (\uyvmbh -> gy) (\qhwlb -> qxhrzscqfu c)) ((\ablxwtmde -> \whyyc -> vecrgvmhve vbnul (\whyyc -> pd)) (\hcxjqsatzd -> \ztufcxxjsf -> \nppqcmxlik -> \bntmnxan -> zqqutguk)))) (\vbnul -> (\n -> (\jaffl -> \jskltx -> uyvmbh tgtp) ((\c -> \fgiufk -> ablxwtmde) (\pq -> gy z))) (\tcye -> (\uqrkf -> \zastcukeg -> npnggxo) (npnggxo jaffl (u jrppin)) ((\za -> \oqanmuqcv -> zfdi) (\tadgzk -> \vnyfn -> z))) ((\lxxtipiud -> \cgthlld -> hrve rlro (mw mpkh) (\e -> jaqtuv vnyfn)) (\mpkh -> \mwmzh -> (\whyyc -> vecrgvmhve jskltx) ((\z -> bdgonmod) (uyvmbh iqquu)))) ((\uoluawg -> \zfdi -> \rwgxh -> \qhl -> \kkcanpg -> lxxtipiud tajp) (\me -> (\bfud -> qhl ageluzypcu (qwx uoluawg) (\jaffl -> kkcanpg n)) (\wcnydhkg -> (\agfbbwi -> yqz) (za ablxwtmde) ((\jaqtuv -> za) (tgtp qxhrzscqfu))))) (\bntmnxan -> (\whyyc -> (\vrflxw -> vbnul jskltx) (\qhwlb -> \ageluzypcu -> qahi) ((\za -> lbtyw) (\b -> ftglcoiwkh) (hzwfq c (rlro d)))) ((\iesgl -> zvi ageluzypcu) (\qhwlb -> rlro vecrgvmhve) ((\zastcukeg -> jlhgjkal) (\ageluzypcu -> pqyghfhou) (\sngu -> \jrppin -> gy)) (\bfud -> \bntmnxan -> lqifsqtcld cgthlld (\iqquu -> za))) ((\vmv -> \lxxtipiud -> rwgxh) (\xghnn -> hzwfq za) (\usy -> (\vk -> me) (gzfdmfh qhl)) (\jskltx -> (\me -> lqifsqtcld cehzm) (\itsg -> \qxhrzscqfu -> lbtyw)) ((\jlhgjkal -> \efpk -> \zvi -> \rlro -> mtq) (\pd -> \jskltx -> (\npnggxo -> jlhgjkal) (\d -> vmv))))))) ((\hzwfq -> \b -> (\rlro -> ngncxyz fgiufk (fen agfbbwi) ((\whyyc -> zqqutguk) (qwx mw)) (\crfpx -> \tadgzk -> \k -> hzwfq) ((\d -> (\yqz -> ablxwtmde) (\fz -> jgzpujcj)) (\uyvmbh -> \jaqtuv -> qahi mtq))) ((\d -> (\ztufcxxjsf -> \pqyghfhou -> agfbbwi) (\npodgpjyyn -> ablxwtmde k)) ((\me -> wcnydhkg hrve (efpk z)) (\lxxtipiud -> (\fgiufk -> iqquu) (\ajibwehtid -> z))) (\tcye -> (\lqifsqtcld -> ageluzypcu) (\doo -> d) (\zqqutguk -> \tadgzk -> r) (\agfbbwi -> \vecrgvmhve -> qhl vecrgvmhve)))) (\qxhrzscqfu -> (\za -> \p -> \ljrqfvmop -> \e -> bdgonmod jskltx (\awbkkvh -> usy) ((\pqyghfhou -> yqz) (lqifsqtcld jskltx))) (\lqifsqtcld -> (\pqyghfhou -> (\d -> zqqutguk) (zastcukeg c) ((\nppqcmxlik -> iqquu) (npnggxo vmv)) (\rlro -> iesgl jrppin (\ftglcoiwkh -> rwgxh))) (\qahi -> \awbkkvh -> \zqqutguk -> \hrve -> oqanmuqcv wcnydhkg))) ((\uoluawg -> (\tadgzk -> \uyvmbh -> jlhgjkal vbnul (\rlro -> cgthlld) (\uyvmbh -> k fgiufk)) (\ly -> (\uoluawg -> vlgrywld c (hcxjqsatzd doo)) ((\mpkh -> xghnn) (\zfdi -> qkrrwibjzy) (\zfdi -> \pq -> jlhgjkal)))) ((\jgzpujcj -> \doo -> \uyvmbh -> \hcxjqsatzd -> \ftglcoiwkh -> \crfpx -> n) ((\npodgpjyyn -> (\jlhgjkal -> tajp) (cehzm rlro) (\jgzpujcj -> iesgl uoluawg)) ((\za -> \n -> \za -> jrppin) (\k -> as vbnul (\as -> ngncxyz))) ((\oqanmuqcv -> \zvi -> za ly (me tgtp)) ((\sjopal -> (\vbnul -> b) (\vbnul -> z)) (\mw -> (\qkrrwibjzy -> mtq) (bfud whyyc)))))) ((\jaqtuv -> (\kkcanpg -> \bntmnxan -> \hcxjqsatzd -> \as -> \qahi -> pq) (\bpwjxy -> \e -> \as -> lqifsqtcld jaffl (\vmv -> zfdi))) ((\jaqtuv -> \bdgonmod -> jrppin pqyghfhou (\whyyc -> cgthlld) (\kkcanpg -> \awbkkvh -> vrflxw) (\lbtyw -> (\r -> qhwlb) (bfud fz))) ((\npnggxo -> \ly -> \vk -> kkcanpg rlro) ((\pq -> \usy -> \zvi -> zqqutguk) (\npodgpjyyn -> (\pd -> wcnydhkg) (c gzfdmfh))) ((\pq -> b ajibwehtid (rlro whyyc) (\tadgzk -> vrflxw sngu)) (\ly -> \k -> \crfpx -> mwmzh iqquu))))) ((\usy -> \cgthlld -> (\pq -> fen efpk) (\pd -> \agfbbwi -> zastcukeg) (\ageluzypcu -> \tgtp -> ngncxyz npnggxo) (\iqquu -> (\rwgxh -> gy ajibwehtid) (k mtq (\b -> tcye)))) (\qxhrzscqfu -> (\c -> \pd -> \qxhrzscqfu -> \k -> cgthlld) (\zvi -> xghnn ablxwtmde (\qwx -> awbkkvh) (\mwmzh -> \iesgl -> hzwfq)) (\mtq -> \jskltx -> \rlro -> gzfdmfh ztufcxxjsf (\whyyc -> lbtyw))) ((\zvi -> (\vmv -> efpk npodgpjyyn) (\jskltx -> qxhrzscqfu bntmnxan) ((\uyvmbh -> \vmv -> qhl) (\pq -> kkcanpg lbo)) ((\ftglcoiwkh -> \vbnul -> as ztufcxxjsf) (b n (fz xghnn) (\crfpx -> gy vbnul)))) ((\npodgpjyyn -> \rlro -> (\uyvmbh -> \vlgrywld -> r) (\mwmzh -> as nppqcmxlik)) (\wcnydhkg -> (\crfpx -> \ztufcxxjsf -> b) (wcnydhkg mw (\ngncxyz -> sjopal)) (\d -> zastcukeg ajibwehtid (\whyyc -> npnggxo)))) (\bdgonmod -> \jskltx -> (\sjopal -> (\uqrkf -> whyyc uyvmbh) (bdgonmod iesgl (xghnn mtq))) (\xghnn -> jaffl c (\p -> unlod) (\jgzpujcj -> \lxxtipiud -> hcxjqsatzd)))))) ((\za -> \ztufcxxjsf -> \uyvmbh -> \yqz -> \as -> (\qahi -> \uyvmbh -> unlod doo (qxhrzscqfu gy)) ((\zqqutguk -> yqz itsg) ((\jaffl -> jskltx) (xghnn wcnydhkg)) ((\me -> ztufcxxjsf) (\tadgzk -> lbo) (\ljrqfvmop -> \gzfdmfh -> hzwfq)))) (\fgiufk -> \zqqutguk -> \itsg -> (\ftglcoiwkh -> uqrkf) (\cehzm -> sjopal) (\usy -> \e -> ftglcoiwkh) (\jskltx -> n u (qhl bdgonmod)) (\mwmzh -> \zfdi -> lxxtipiud lbtyw (\c -> za)) (\vnyfn -> (\zvi -> \c -> jskltx sngu) (fz vnyfn (\cgthlld -> qkrrwibjzy) (\usy -> bntmnxan qhwlb))) ((\vecrgvmhve -> (\z -> \iesgl -> hcxjqsatzd) (fz qahi (qhwlb zastcukeg))) (\npodgpjyyn -> rlro d (\r -> whyyc) ((\mtq -> pqyghfhou) (\qhwlb -> cgthlld))) (\b -> (\jrppin -> \k -> uqrkf) (\qahi -> gzfdmfh xghnn) (\mw -> lxxtipiud zastcukeg (\uyvmbh -> agfbbwi)))))) (\jaffl -> \b -> \lxxtipiud -> \vk -> \pqyghfhou -> (\gy -> \z -> (\vbnul -> \uyvmbh -> ljrqfvmop) (jlhgjkal jgzpujcj (fz npnggxo))) ((\zfdi -> \zastcukeg -> \za -> \npnggxo -> ajibwehtid) (\bdgonmod -> (\pd -> \ngncxyz -> jaqtuv) (kkcanpg tajp (fen qxhrzscqfu)))) ((\vecrgvmhve -> (\hcxjqsatzd -> (\vnyfn -> npnggxo) (\bfud -> as)) (\c -> fgiufk itsg (\fen -> qkrrwibjzy))) ((\vk -> qxhrzscqfu k (\doo -> vnyfn)) (\jgzpujcj -> \xghnn -> \za -> mtq) ((\uoluawg -> \hcxjqsatzd -> mtq jlhgjkal) (\zfdi -> \fen -> \mw -> bntmnxan)))))) (\iqquu -> \crfpx -> \jgzpujcj -> (\jgzpujcj -> \d -> (\rlro -> (\bfud -> jlhgjkal) (\pd -> z)) ((\unlod -> z gzfdmfh) ((\r -> bpwjxy) (\oqanmuqcv -> qhl)))) ((\sngu -> \iqquu -> (\pqyghfhou -> \zvi -> ajibwehtid) ((\tcye -> tcye) (\nppqcmxlik -> mwmzh))) ((\rwgxh -> k vbnul) (\rlro -> mwmzh k) (\vnyfn -> \fz -> u d) ((\rwgxh -> \fz -> oqanmuqcv) ((\lqifsqtcld -> bdgonmod) (ftglcoiwkh rwgxh)) (\iqquu -> \c -> jgzpujcj ly)))) ((\mtq -> \unlod -> (\qwx -> \pq -> jskltx) (\e -> fen wcnydhkg) (\za -> (\vbnul -> efpk) (\usy -> vmv))) ((\fgiufk -> lxxtipiud agfbbwi (\ljrqfvmop -> hcxjqsatzd)) (u vlgrywld (\xghnn -> bdgonmod) (zqqutguk lqifsqtcld (\xghnn -> bntmnxan))) ((\d -> \zqqutguk -> bdgonmod unlod) (\k -> \vlgrywld -> p mpkh)) ((\mtq -> \sjopal -> nppqcmxlik tadgzk) ((\rlro -> ageluzypcu) (jskltx yqz) (\ljrqfvmop -> \mtq -> z)) (\k -> (\hzwfq -> lbo qkrrwibjzy) ((\b -> qhl) (npnggxo crfpx)))))) ((\zvi -> \nppqcmxlik -> (\qxhrzscqfu -> \me -> (\jlhgjkal -> bfud) (uoluawg qwx)) ((\qkrrwibjzy -> vmv) (pd vecrgvmhve) (\tajp -> pq npodgpjyyn) ((\gzfdmfh -> fgiufk wcnydhkg) (\npnggxo -> kkcanpg fgiufk)))) ((\nppqcmxlik -> (\za -> itsg me (\lbtyw -> cgthlld)) (\ajibwehtid -> \ageluzypcu -> sngu c) ((\itsg -> \n -> usy pqyghfhou) (\qxhrzscqfu -> \n -> bntmnxan zqqutguk))) ((\r -> bpwjxy vrflxw (\r -> qkrrwibjzy) (\ztufcxxjsf -> vmv p)) (\efpk -> (\za -> jaqtuv) (qahi p) ((\uqrkf -> jrppin) (mw tcye))) (\vecrgvmhve -> \lqifsqtcld -> \whyyc -> \gy -> vlgrywld vlgrywld)))) ((\c -> (\iesgl -> (\npnggxo -> \lbtyw -> nppqcmxlik) (usy as (\u -> uyvmbh))) (\cgthlld -> \c -> (\zastcukeg -> jaffl) (npodgpjyyn vrflxw)) (\lbtyw -> usy hrve (d lqifsqtcld) ((\jlhgjkal -> ajibwehtid) (tgtp zvi)) (\vrflxw -> \c -> as za)) ((\bpwjxy -> \jaffl -> c fen) (\gzfdmfh -> (\qkrrwibjzy -> ablxwtmde) (\c -> sjopal)) ((\ftglcoiwkh -> \gy -> \zqqutguk -> agfbbwi) ((\iqquu -> \oqanmuqcv -> vnyfn) (usy jrppin (bdgonmod vmv)))) (\cehzm -> \b -> (\mtq -> \npnggxo -> e) (\bpwjxy -> \uyvmbh -> mwmzh)))) ((\nppqcmxlik -> \npnggxo -> \lxxtipiud -> \zfdi -> ablxwtmde ageluzypcu) (\bdgonmod -> \c -> qhwlb d (oqanmuqcv vbnul) (jskltx iqquu (\b -> agfbbwi))) ((\itsg -> \tcye -> gy hrve (ztufcxxjsf mtq) (\ajibwehtid -> \k -> mtq)) ((\hzwfq -> hrve vbnul) ((\kkcanpg -> npnggxo) (\hzwfq -> wcnydhkg)) (\qkrrwibjzy -> zastcukeg rlro (usy lbo)) (\d -> (\lqifsqtcld -> \zvi -> qhwlb) (\lbtyw -> whyyc sjopal)))) ((\ztufcxxjsf -> \ztufcxxjsf -> jgzpujcj tgtp (\c -> mwmzh) ((\pqyghfhou -> iesgl) (\vrflxw -> rwgxh))) ((\n -> \xghnn -> \qkrrwibjzy -> jgzpujcj) ((\c -> nppqcmxlik) (\n -> r) ((\zvi -> tcye) (fen cgthlld))) ((\ljrqfvmop -> \yqz -> \lqifsqtcld -> cehzm) (\n -> (\mtq -> agfbbwi) (\ftglcoiwkh -> tadgzk)))) (\zastcukeg -> \uyvmbh -> (\awbkkvh -> me c) ((\yqz -> kkcanpg) (hzwfq c)) (\qwx -> (\cehzm -> usy) (ljrqfvmop qwx)))))) ((\vlgrywld -> (\uyvmbh -> (\b -> \lxxtipiud -> \lqifsqtcld -> vnyfn) (\nppqcmxlik -> \ajibwehtid -> ftglcoiwkh ageluzypcu) (\uoluawg -> \ljrqfvmop -> \tgtp -> \pqyghfhou -> u) (\qxhrzscqfu -> (\vnyfn -> \crfpx -> jaqtuv) ((\za -> jlhgjkal) (\ngncxyz -> nppqcmxlik)) (pqyghfhou lxxtipiud (\c -> ly) (\yqz -> \doo -> cehzm)))) ((\r -> (\fgiufk -> qxhrzscqfu) (qxhrzscqfu n)) (\qhl -> \bdgonmod -> oqanmuqcv mwmzh) (\usy -> (\wcnydhkg -> p vbnul) (\mtq -> iesgl za)) ((\hcxjqsatzd -> (\yqz -> npnggxo) (jgzpujcj p)) (oqanmuqcv ftglcoiwkh (mw crfpx) (qhwlb wcnydhkg (mwmzh zqqutguk))) (sngu b (\mtq -> zvi) ((\doo -> jrppin) (ljrqfvmop iesgl)) ((\k -> \qhwlb -> jskltx) (jskltx jaffl (\awbkkvh -> ly))))) (\yqz -> \pqyghfhou -> pd vecrgvmhve (qkrrwibjzy unlod) (\tgtp -> hzwfq rwgxh) ((\sngu -> \vmv -> k) (\d -> \k -> zfdi))))) ((\jrppin -> \bpwjxy -> \efpk -> \qxhrzscqfu -> (\lbtyw -> (\unlod -> jrppin) (jskltx jaffl)) ((\e -> \vrflxw -> r) (\oqanmuqcv -> \vmv -> qhwlb))) ((\pd -> (\r -> vecrgvmhve u (\sjopal -> hrve) (qxhrzscqfu jgzpujcj (\ljrqfvmop -> lxxtipiud)) (\hcxjqsatzd -> whyyc bfud (uoluawg zfdi))) (\k -> (\e -> xghnn) (jaffl iesgl) (tcye bntmnxan (\zastcukeg -> bntmnxan)) (\qxhrzscqfu -> (\xghnn -> npodgpjyyn) (fgiufk qwx)))) ((\bpwjxy -> (\jskltx -> zqqutguk awbkkvh) ((\jlhgjkal -> ablxwtmde) (\bdgonmod -> sngu))) (\pqyghfhou -> (\uqrkf -> b) (mw qkrrwibjzy) ((\vrflxw -> qhwlb) (jaffl yqz))) (\nppqcmxlik -> (\hzwfq -> \npnggxo -> n) ((\me -> d) (me iqquu)) ((\fz -> whyyc) (iesgl efpk) ((\bfud -> jlhgjkal) (\cehzm -> r)))) (\hzwfq -> (\tadgzk -> \lqifsqtcld -> \vecrgvmhve -> \pq -> ztufcxxjsf) (\vk -> \cehzm -> \uqrkf -> \bpwjxy -> vmv))))))) -------------------------------------------------------------------------------- /bench/res/depth_5.lam: -------------------------------------------------------------------------------- 1 | ((a (\b -> c)) ((\d -> e) f)) g 2 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | tests: True 3 | benchmarks: True 4 | -------------------------------------------------------------------------------- /flake.lock: -------------------------------------------------------------------------------- 1 | { 2 | "nodes": { 3 | "flake-utils": { 4 | "locked": { 5 | "lastModified": 1653893745, 6 | "narHash": "sha256-0jntwV3Z8//YwuOjzhV2sgJJPt+HY6KhU7VZUL0fKZQ=", 7 | "owner": "numtide", 8 | "repo": "flake-utils", 9 | "rev": "1ed9fb1935d260de5fe1c2f7ee0ebaae17ed2fa1", 10 | "type": "github" 11 | }, 12 | "original": { 13 | "owner": "numtide", 14 | "repo": "flake-utils", 15 | "type": "github" 16 | } 17 | }, 18 | "nixpkgs": { 19 | "locked": { 20 | "lastModified": 1712883908, 21 | "narHash": "sha256-icE1IJE9fHcbDfJ0+qWoDdcBXUoZCcIJxME4lMHwvSM=", 22 | "owner": "NixOS", 23 | "repo": "nixpkgs", 24 | "rev": "a0c9e3aee1000ac2bfb0e5b98c94c946a5d180a9", 25 | "type": "github" 26 | }, 27 | "original": { 28 | "owner": "NixOS", 29 | "ref": "nixpkgs-unstable", 30 | "repo": "nixpkgs", 31 | "type": "github" 32 | } 33 | }, 34 | "root": { 35 | "inputs": { 36 | "flake-utils": "flake-utils", 37 | "nixpkgs": "nixpkgs" 38 | } 39 | } 40 | }, 41 | "root": "root", 42 | "version": 7 43 | } 44 | -------------------------------------------------------------------------------- /flake.nix: -------------------------------------------------------------------------------- 1 | { 2 | inputs = { 3 | nixpkgs.url = "github:NixOS/nixpkgs/nixpkgs-unstable"; 4 | flake-utils.url = "github:numtide/flake-utils"; 5 | }; 6 | outputs = { self, nixpkgs, flake-utils }: flake-utils.lib.eachDefaultSystem (system: 7 | let pkgs = import nixpkgs { inherit system; }; in { 8 | devShell = pkgs.mkShell { 9 | buildInputs = with pkgs; [ 10 | haskellPackages.ghc 11 | haskell-language-server 12 | cabal-install 13 | haskellPackages.fourmolu 14 | ]; 15 | }; 16 | }); 17 | } 18 | -------------------------------------------------------------------------------- /fourmolu.yaml: -------------------------------------------------------------------------------- 1 | indentation: 2 2 | comma-style: leading 3 | record-brace-space: false 4 | indent-wheres: true 5 | diff-friendly-import-export: true 6 | respectful: false 7 | haddock-style: multi-line 8 | newlines-between-decls: 1 -------------------------------------------------------------------------------- /sage.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | 3 | name: sage 4 | version: 0.2 5 | synopsis: Efficient parser combinators 6 | description: 7 | Efficient parser combinators for modern Haskell. 8 | . 9 | Sage is about 10% faster and twice as memory-efficient as Attoparsec. 10 | . 11 | Inspired by Ed Kmett's parser, 12 | which for some reason I thought was called 'parsley'. (I don't care for root vegetable puns) 13 | bug-reports: https://github.com/lightandlight/sage/issues 14 | license: BSD-3-Clause 15 | author: Isaac Elliott 16 | maintainer: isaace71295@gmail.com 17 | copyright: 2020-2022 Isaac Elliott 18 | category: Text 19 | extra-source-files: CHANGELOG.md 20 | 21 | library 22 | exposed-modules: Streaming.Chars 23 | , Streaming.Chars.ByteString.Utf8 24 | , Streaming.Chars.Text 25 | , Text.Sage 26 | , Text.Sage.Indentation 27 | build-depends: base >=4.16 && <5 28 | , bytestring 29 | , containers >=0.6 30 | , deepseq >=1.4 31 | , mtl 32 | , parsers 33 | , streaming 34 | , text >=2.0 35 | , transformers 36 | hs-source-dirs: src 37 | default-language: Haskell2010 38 | ghc-options: -Wall -Werror 39 | 40 | benchmark sage-bench 41 | type: exitcode-stdio-1.0 42 | main-is: Main.hs 43 | other-modules: Parsers 44 | build-depends: base 45 | , sage 46 | , attoparsec >=0.14 && <0.15 47 | , bytestring 48 | , criterion 49 | , deepseq 50 | , mmap 51 | , optparse-applicative >=0.18 && <0.19 52 | , parsers 53 | , streaming 54 | , text 55 | , weigh 56 | hs-source-dirs: bench 57 | default-language: Haskell2010 58 | ghc-options: -Wall -Werror 59 | 60 | test-suite sage-test 61 | type: exitcode-stdio-1.0 62 | hs-source-dirs: test 63 | main-is: Main.hs 64 | other-modules: Test.Indentation 65 | , Test.Parser 66 | , Test.Span 67 | build-depends: base 68 | , sage 69 | , containers 70 | , hedgehog 71 | , hspec 72 | , hspec-hedgehog 73 | , parsers 74 | , text 75 | default-language: Haskell2010 76 | ghc-options: -Wall -Werror 77 | -------------------------------------------------------------------------------- /src/Streaming/Chars.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE FunctionalDependencies #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | 7 | module Streaming.Chars (module Data.Functor.Of, Chars (..), toStream) where 8 | 9 | import Data.Functor.Identity (Identity (runIdentity)) 10 | import Data.Functor.Of 11 | import Data.Kind (Type) 12 | import qualified Streaming 13 | 14 | class Chars s where 15 | data Result s :: Type 16 | fromResult :: Result s -> Maybe (Char, s) 17 | uncons :: s -> Result s 18 | 19 | instance (f ~ Of Char, m ~ Identity, a ~ ()) => Chars (Streaming.Stream f m a) where 20 | newtype Result (Streaming.Stream f m a) = Result {getResult :: Either a (f (Streaming.Stream f m a))} 21 | fromResult = either (\() -> Nothing) (\(c :> rest) -> Just (c, rest)) . getResult 22 | uncons s = Result . runIdentity $ Streaming.inspect s 23 | 24 | toStream :: (Chars s, Monad m) => s -> Streaming.Stream (Of Char) m () 25 | toStream = Streaming.unfold (pure . maybe (Left ()) (\(c, rest) -> Right $ c :> rest) . fromResult . uncons) 26 | -------------------------------------------------------------------------------- /src/Streaming/Chars/ByteString/Utf8.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MagicHash #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE UnboxedTuples #-} 7 | {-# LANGUAGE UndecidableInstances #-} 8 | {-# OPTIONS_GHC -ddump-simpl 9 | -ddump-to-file 10 | -dsuppress-idinfo 11 | -dsuppress-coercions 12 | -dsuppress-type-applications 13 | -dsuppress-uniques 14 | -dsuppress-module-prefixes #-} 15 | 16 | module Streaming.Chars.ByteString.Utf8 (StreamUtf8 (..)) where 17 | 18 | {- 19 | 20 | Some code in this module has been copied from the `text` library's `Data.Text.Internal.Unsafe.Char` module. 21 | 22 | (c) 2008, 2009 Tom Harper, (c) 2009, 2010 Bryan O'Sullivan, (c) 2009 Duncan Coutts 23 | 24 | -} 25 | 26 | import Data.ByteString (ByteString) 27 | import qualified Data.ByteString as ByteString 28 | import Data.Word (Word8) 29 | import GHC.Exts (Char (C#), Int#, Word8#, chr#, int8ToInt#, uncheckedIShiftL#, word8ToInt8#, (+#), (-#)) 30 | import GHC.Word (Word8 (W8#)) 31 | import Streaming.Chars (Chars (..)) 32 | 33 | word8ToInt# :: Word8# -> Int# 34 | word8ToInt# w = int8ToInt# (word8ToInt8# w) 35 | 36 | unsafeChr8 :: Word8 -> Char 37 | unsafeChr8 (W8# w#) = C# (chr# (word8ToInt# w#)) 38 | {-# INLINE unsafeChr8 #-} 39 | 40 | chr1 :: Word8 -> ByteString -> (# Char, ByteString #) 41 | chr1 n1 bs = (# unsafeChr8 n1, bs #) 42 | {-# INLINE chr1 #-} 43 | 44 | chr2 :: Word8 -> Word8 -> ByteString -> (# Char, ByteString #) 45 | chr2 (W8# x1#) (W8# x2#) bs = 46 | (# C# (chr# (z1# +# z2#)), bs #) 47 | where 48 | !y1# = word8ToInt# x1# 49 | !y2# = word8ToInt# x2# 50 | !z1# = uncheckedIShiftL# (y1# -# 0xC0#) 6# 51 | !z2# = y2# -# 0x80# 52 | {-# INLINE chr2 #-} 53 | 54 | chr3 :: Word8 -> Word8 -> Word8 -> ByteString -> (# Char, ByteString #) 55 | chr3 (W8# x1#) (W8# x2#) (W8# x3#) bs = 56 | (# C# (chr# (z1# +# z2# +# z3#)), bs #) 57 | where 58 | !y1# = word8ToInt# x1# 59 | !y2# = word8ToInt# x2# 60 | !y3# = word8ToInt# x3# 61 | !z1# = uncheckedIShiftL# (y1# -# 0xE0#) 12# 62 | !z2# = uncheckedIShiftL# (y2# -# 0x80#) 6# 63 | !z3# = y3# -# 0x80# 64 | {-# INLINE chr3 #-} 65 | 66 | chr4 :: Word8 -> Word8 -> Word8 -> Word8 -> ByteString -> (# Char, ByteString #) 67 | chr4 (W8# x1#) (W8# x2#) (W8# x3#) (W8# x4#) bs = 68 | (# C# (chr# (z1# +# z2# +# z3# +# z4#)), bs #) 69 | where 70 | !y1# = word8ToInt# x1# 71 | !y2# = word8ToInt# x2# 72 | !y3# = word8ToInt# x3# 73 | !y4# = word8ToInt# x4# 74 | !z1# = uncheckedIShiftL# (y1# -# 0xF0#) 18# 75 | !z2# = uncheckedIShiftL# (y2# -# 0x80#) 12# 76 | !z3# = uncheckedIShiftL# (y3# -# 0x80#) 6# 77 | !z4# = y4# -# 0x80# 78 | {-# INLINE chr4 #-} 79 | 80 | decodeChar :: Word8 -> ByteString -> (# Char, ByteString #) 81 | decodeChar n1 bs = 82 | if n1 < 0xC0 83 | then chr1 n1 bs 84 | else case ByteString.uncons bs of 85 | Nothing -> error utf8Error 86 | Just (n2, bs') -> 87 | if n1 < 0xE0 88 | then chr2 n1 n2 bs' 89 | else case ByteString.uncons bs' of 90 | Nothing -> error utf8Error 91 | Just (n3, bs'') -> 92 | if n1 < 0xF0 93 | then chr3 n1 n2 n3 bs'' 94 | else case ByteString.uncons bs'' of 95 | Nothing -> error utf8Error 96 | Just (n4, bs''') -> 97 | chr4 n1 n2 n3 n4 bs''' 98 | where 99 | utf8Error = "utf8 encoding error" 100 | 101 | newtype StreamUtf8 = StreamUtf8 ByteString 102 | 103 | instance Chars StreamUtf8 where 104 | data Result StreamUtf8 = Done | More !Char {-# UNPACK #-} !ByteString 105 | 106 | {-# inline fromResult #-} 107 | fromResult Done = Nothing 108 | fromResult (More c b) = Just (c, StreamUtf8 b) 109 | 110 | {-# inline uncons #-} 111 | uncons (StreamUtf8 b) = 112 | case ByteString.uncons b of 113 | Nothing -> Done 114 | Just (w, b') | (# c, b'' #) <- decodeChar w b' -> More c b'' 115 | -------------------------------------------------------------------------------- /src/Streaming/Chars/Text.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | 6 | module Streaming.Chars.Text (StreamText (..)) where 7 | 8 | import Control.DeepSeq (NFData) 9 | import Data.String (IsString) 10 | import Data.Text (Text) 11 | import qualified Data.Text as Text 12 | import Streaming.Chars (Chars (..)) 13 | 14 | newtype StreamText = StreamText Text 15 | deriving (Eq, Show, IsString, NFData) 16 | 17 | instance Chars StreamText where 18 | data Result StreamText = Done | More !Char {-# UNPACK #-} !Text 19 | 20 | {-# inline fromResult #-} 21 | fromResult Done = Nothing 22 | fromResult (More c t) = Just (c, StreamText t) 23 | 24 | {-# inline uncons #-} 25 | uncons (StreamText t) = 26 | case Text.uncons t of 27 | Nothing -> Done 28 | Just (c, t') -> More c t' 29 | -------------------------------------------------------------------------------- /src/Text/Sage.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE MagicHash #-} 5 | {-# LANGUAGE PatternSynonyms #-} 6 | {-# LANGUAGE RankNTypes #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE UnboxedTuples #-} 9 | {-# LANGUAGE UndecidableInstances #-} 10 | {-# OPTIONS_GHC -fno-warn-unused-top-binds #-} 11 | 12 | module Text.Sage ( 13 | -- * Parsing 14 | Parser, 15 | parseText, 16 | parseUtf8, 17 | parse, 18 | 19 | -- * Errors 20 | Label (..), 21 | ParseError (..), 22 | 23 | -- * Spans 24 | Span (..), 25 | spanContains, 26 | spanStart, 27 | spanLength, 28 | 29 | -- * Combinators 30 | label, 31 | string, 32 | count, 33 | skipMany, 34 | getOffset, 35 | ) where 36 | 37 | import Control.Applicative (Alternative (..)) 38 | import Control.DeepSeq (NFData) 39 | import Control.Monad (MonadPlus (..)) 40 | import Data.ByteString (ByteString) 41 | import Data.Set (Set) 42 | import qualified Data.Set as Set 43 | import Data.Text (Text) 44 | import qualified Data.Text as Text 45 | import GHC.Exts (Int (..), Int#, orI#, (+#)) 46 | import GHC.Generics (Generic) 47 | import Streaming.Chars (Chars, fromResult) 48 | import qualified Streaming.Chars as Chars 49 | import Streaming.Chars.ByteString.Utf8 (StreamUtf8 (StreamUtf8)) 50 | import Streaming.Chars.Text (StreamText (StreamText)) 51 | import Text.Parser.Char (CharParsing) 52 | import qualified Text.Parser.Char as CharParsing 53 | import Text.Parser.Combinators (Parsing) 54 | import qualified Text.Parser.Combinators as Parsing 55 | import Text.Parser.LookAhead (LookAheadParsing (..)) 56 | import Text.Parser.Token (TokenParsing (..)) 57 | 58 | -- | Parse a 'Text'. 59 | parseText :: Parser StreamText a -> Text -> Either ParseError a 60 | parseText p = parse p . StreamText 61 | 62 | -- | Parse a UTF-8 encoded 'ByteString'. 63 | parseUtf8 :: Parser StreamUtf8 a -> ByteString -> Either ParseError a 64 | parseUtf8 p = parse p . StreamUtf8 65 | 66 | -- | Parse an arbitrary string. 67 | parse :: Parser s a -> s -> Either ParseError a 68 | parse (Parser p) input = 69 | case p (# input, 0#, mempty #) of 70 | (# _, _, pos, ex, res #) -> 71 | case res of 72 | Nothing# -> Left $ Unexpected (I# pos) ex 73 | Just# a -> Right a 74 | 75 | -- | A parsing error. 76 | data ParseError = Unexpected 77 | -- | Byte offset at which the error occurred. 78 | { position :: Int 79 | -- | Names for things that the parser would have accepted at the point where it failed. 80 | , expected :: Set Label 81 | } 82 | deriving (Eq, Show, Generic) 83 | 84 | instance NFData ParseError 85 | 86 | -- | Names for things the parser is expecting. 87 | data Label 88 | = Eof 89 | | Char Char 90 | | String String 91 | | Text Text 92 | deriving (Eq, Ord, Show, Generic) 93 | 94 | instance NFData Label 95 | 96 | -- | A parser that consumes a string of type @s@ and produces a value of type @a@. 97 | newtype Parser s a = Parser 98 | { unParser :: 99 | (# s, Pos#, Set Label #) -> 100 | (# Consumed#, s, Pos#, Set Label, Maybe# a #) 101 | } 102 | 103 | type Consumed# = Int# 104 | 105 | type Pos# = Int# 106 | 107 | 108 | -- | The unboxed equivalent of 'Maybe'. 109 | -- 110 | -- Contructors: 'Nothing#' and 'Just#' 111 | type Maybe# a = (# (# #) | a #) 112 | 113 | pattern Nothing# :: Maybe# a 114 | pattern Nothing# = (# (# #) | #) 115 | 116 | pattern Just# :: a -> Maybe# a 117 | pattern Just# a = (# | a #) 118 | 119 | {-# COMPLETE Nothing#, Just# #-} 120 | 121 | instance Functor (Parser s) where 122 | fmap f (Parser p) = 123 | Parser $ \input -> 124 | case p input of 125 | (# consumed, input', pos', ex', ra #) -> 126 | let 127 | !rb = 128 | case ra of 129 | Nothing# -> Nothing# 130 | Just# a -> Just# (f a) 131 | in 132 | (# consumed, input', pos', ex', rb #) 133 | 134 | instance Applicative (Parser s) where 135 | pure a = Parser $ \(# input, pos, ex #) -> (# 0#, input, pos, ex, Just# a #) 136 | Parser pf <*> Parser pa = 137 | Parser $ \input -> 138 | case pf input of 139 | (# fConsumed, input', pos', ex', rf #) -> 140 | case rf of 141 | Nothing# -> 142 | (# fConsumed, input', pos', ex', Nothing# #) 143 | Just# f -> 144 | case pa (# input', pos', ex' #) of 145 | (# aConsumed, input'', pos'', ex'', ra #) -> 146 | let 147 | !bConsumed = orI# fConsumed aConsumed 148 | !rb = 149 | case ra of 150 | Nothing# -> 151 | Nothing# 152 | Just# a -> 153 | Just# (f a) 154 | in 155 | (# bConsumed, input'', pos'', ex'', rb #) 156 | 157 | instance Alternative (Parser s) where 158 | empty = Parser $ \(# input, pos, ex #) -> (# 0#, input, pos, ex, Nothing# #) 159 | 160 | Parser pa <|> Parser pb = 161 | Parser $ \(# input, pos, ex #) -> 162 | case pa (# input, pos, ex #) of 163 | (# aConsumed, input', pos', ex', ra #) -> 164 | case ra of 165 | Nothing# -> 166 | case aConsumed of 167 | 1# -> 168 | (# aConsumed, input', pos', ex', ra #) 169 | _ -> 170 | pb (# input', pos', ex' #) 171 | Just# _ -> 172 | (# aConsumed, input', pos', ex', ra #) 173 | 174 | {-# INLINE many #-} 175 | many (Parser p) = 176 | Parser (go 0# id) 177 | where 178 | go consumed acc state = 179 | case p state of 180 | (# consumed', input', pos', ex', ra #) -> 181 | let !consumed'' = orI# consumed consumed' in 182 | case ra of 183 | Nothing# -> 184 | let 185 | !ras = 186 | case consumed' of 187 | 1# -> Nothing# 188 | _ -> let !acc' = acc [] in Just# acc' 189 | in 190 | (# consumed'', input', pos', ex', ras #) 191 | Just# a -> 192 | go consumed'' (acc . (a :)) (# input', pos', ex' #) 193 | 194 | {-# INLINE some #-} 195 | some (Parser p) = 196 | Parser $ \(# !input, pos, ex #) -> 197 | case p (# input, pos, ex #) of 198 | (# consumed, !input', pos', ex', ra #) -> 199 | case ra of 200 | Nothing# -> (# consumed, input', pos', ex', Nothing# #) 201 | Just# a -> go consumed (a :) (# input', pos', ex' #) 202 | where 203 | go consumed acc (# !input, pos, ex #) = 204 | case p (# input, pos, ex #) of 205 | (# consumed', input', pos', ex', ra #) -> 206 | let !consumed'' = orI# consumed consumed' 207 | in case ra of 208 | Nothing# -> 209 | let 210 | !ras = 211 | case consumed' of 212 | 1# -> Nothing# 213 | _ -> let !acc' = acc [] in Just# acc' 214 | in 215 | (# consumed'', input', pos', ex', ras #) 216 | Just# a -> 217 | go consumed'' (acc . (a :)) (# input', pos', ex' #) 218 | 219 | instance Monad (Parser s) where 220 | Parser p >>= f = 221 | Parser $ \(# input, pos, ex #) -> 222 | case p (# input, pos, ex #) of 223 | (# consumed, input', pos', ex', ra #) -> 224 | case ra of 225 | Nothing# -> 226 | (# consumed, input', pos', ex', Nothing# #) 227 | Just# a -> 228 | case unParser (f a) (# input', pos', ex' #) of 229 | (# consumed', input'', pos'', ex'', rb #) -> 230 | let !consumed'' = orI# consumed consumed' in 231 | (# consumed'', input'', pos'', ex'', rb #) 232 | 233 | instance MonadPlus (Parser s) 234 | 235 | {-# INLINEABLE string #-} 236 | string :: forall s. (Chars s) => Text -> Parser s Text 237 | string t = 238 | Parser $ \state@(# input, pos, _ #) -> stringGo state t t input pos 239 | where 240 | stringGo :: 241 | (# s, Pos#, Set Label #) -> 242 | Text -> 243 | Text -> 244 | s -> 245 | Pos# -> 246 | (# Consumed#, s, Pos#, Set Label, Maybe# Text #) 247 | stringGo state t' expect !input' pos' = 248 | -- passing around t' prevents some re-boxing 249 | case Text.uncons expect of 250 | Nothing -> 251 | (# 252 | 1# 253 | , input' 254 | , pos' 255 | , mempty 256 | , Just# t' 257 | #) 258 | Just (!expectedC, !expect') -> 259 | case fromResult $ Chars.uncons input' of 260 | Just (actualC, input'') 261 | | expectedC == actualC -> 262 | stringGo state t' expect' input'' (pos' +# 1#) 263 | _ -> 264 | let !(# input, pos, ex #) = state 265 | in (# 0#, input, pos, Set.insert (Text t') ex, Nothing# #) 266 | 267 | count :: Parser s a -> Parser s Int 268 | count (Parser p) = 269 | Parser (go 0# 0#) 270 | where 271 | go n consumed state = 272 | case p state of 273 | (# consumed', input', pos', ex', res #) -> 274 | let !consumed'' = orI# consumed consumed' 275 | in case res of 276 | Nothing# -> 277 | let 278 | !n' = 279 | case consumed' of 280 | 1# -> Nothing# 281 | _ -> Just# (I# n) 282 | in 283 | (# consumed'', input', pos', ex', n' #) 284 | Just# _ -> 285 | go (1# +# n) consumed'' (# input', pos', ex' #) 286 | 287 | skipMany :: Parser s a -> Parser s () 288 | skipMany (Parser p) = 289 | Parser (go 0#) 290 | where 291 | go consumed state = 292 | case p state of 293 | (# consumed', input', pos', ex', res #) -> 294 | let !consumed'' = orI# consumed consumed' 295 | in case res of 296 | Nothing# -> 297 | let 298 | !result = 299 | case consumed' of 300 | 1# -> Nothing# 301 | _ -> Just# () 302 | in 303 | (# consumed'', input', pos', ex', result #) 304 | Just# _ -> go consumed'' (# input', pos', ex' #) 305 | 306 | label :: Label -> Parser s a -> Parser s a 307 | label l (Parser p) = 308 | Parser $ \(# input, pos, ex #) -> 309 | case p (# input, pos, ex #) of 310 | (# consumed, input', pos', _, res #) -> 311 | (# consumed, input', pos', Set.insert l ex, res #) 312 | 313 | instance (Chars s) => Parsing (Parser s) where 314 | {-# INLINEABLE try #-} 315 | try (Parser p) = 316 | Parser $ \(# input, pos, ex #) -> 317 | case p (# input, pos, ex #) of 318 | (# consumed, input', pos', ex', res #) -> 319 | case res of 320 | Nothing# -> 321 | (# 0#, input, pos, ex, res #) 322 | Just# _ -> 323 | (# consumed, input', pos', ex', res #) 324 | 325 | {-# INLINEABLE () #-} 326 | () p n = label (String n) p 327 | 328 | {-# INLINE skipMany #-} 329 | skipMany = Text.Sage.skipMany 330 | 331 | {-# INLINEABLE skipSome #-} 332 | skipSome (Parser p) = 333 | Parser $ \state -> 334 | case p state of 335 | (# consumed, input', pos', ex', res #) -> 336 | case res of 337 | Nothing# -> (# consumed, input', pos', ex', Nothing# #) 338 | Just# _ -> go consumed (# input', pos', ex' #) 339 | where 340 | go consumed state = 341 | case p state of 342 | (# consumed', input', pos', ex', res #) -> 343 | let !consumed'' = orI# consumed consumed' 344 | in case res of 345 | Nothing# -> 346 | let 347 | !result = 348 | case consumed' of 349 | 1# -> Nothing# 350 | _ -> Just# () 351 | in 352 | (# consumed'', input', pos', ex', result #) 353 | Just# _ -> 354 | go consumed'' (# input', pos', ex' #) 355 | 356 | {-# INLINEABLE notFollowedBy #-} 357 | notFollowedBy (Parser p) = 358 | Parser $ \(# input, pos, ex #) -> 359 | case p (# input, pos, ex #) of 360 | (# _, _, _, _, res #) -> 361 | case res of 362 | Nothing# -> (# 0#, input, pos, ex, Just# () #) 363 | Just# _ -> (# 0#, input, pos, ex, Nothing# #) 364 | 365 | {-# INLINEABLE unexpected #-} 366 | unexpected _ = empty 367 | 368 | {-# INLINEABLE eof #-} 369 | eof = 370 | Parser $ \(# input, pos, ex #) -> 371 | case fromResult $ Chars.uncons input of 372 | Nothing -> (# 0#, input, pos, ex, Just# () #) 373 | Just{} -> (# 0#, input, pos, Set.insert Eof ex, Nothing# #) 374 | 375 | instance (Chars s) => CharParsing (Parser s) where 376 | {-# INLINE satisfy #-} 377 | satisfy f = 378 | Parser $ \(# input, pos, ex #) -> 379 | case fromResult $ Chars.uncons input of 380 | Just (c, input') 381 | | f c -> 382 | (# 1#, input', pos +# 1#, mempty, Just# c #) 383 | _ -> 384 | (# 0#, input, pos, ex, Nothing# #) 385 | 386 | {-# INLINEABLE char #-} 387 | char c = 388 | Parser $ \(# input, pos, ex #) -> 389 | case fromResult $ Chars.uncons input of 390 | Just (c', input') 391 | | c == c' -> 392 | (# 1#, input', pos +# 1#, mempty, Just# c #) 393 | _ -> 394 | (# 0#, input, pos, Set.insert (Char c) ex, Nothing# #) 395 | 396 | {-# INLINEABLE text #-} 397 | text = Text.Sage.string 398 | 399 | instance (Chars s) => TokenParsing (Parser s) where 400 | {-# INLINEABLE token #-} 401 | token p = p <* (someSpace <|> pure ()) 402 | 403 | instance (Chars s) => LookAheadParsing (Parser s) where 404 | {-# INLINEABLE lookAhead #-} 405 | lookAhead (Parser p) = 406 | Parser $ \(# input, pos, ex #) -> 407 | case p (# input, pos, ex #) of 408 | (# _, _, _, _, res #) -> 409 | (# 0#, input, pos, ex, res #) 410 | 411 | getOffset :: Parser s Int 412 | getOffset = Parser $ \(# input, pos, ex #) -> (# 0#, input, pos, ex, Just# (I# pos) #) 413 | 414 | data Span = Span {-# UNPACK #-} !Int {-# UNPACK #-} !Int 415 | deriving (Eq, Ord, Show) 416 | 417 | spanContains :: Span -> Span -> Bool 418 | spanContains (Span p l) (Span p' l') = 419 | case compare p p' of 420 | LT -> p + l >= p' + l' 421 | EQ -> l >= l' 422 | GT -> False 423 | 424 | -- | `Span` is a meet semilattice with respect to the `spanContains` ordering 425 | instance Semigroup Span where 426 | Span p l <> Span p' l' = 427 | case compare p p' of 428 | LT -> Span p (max (p + l) (p' + l') - p) 429 | EQ -> Span p (max l l') 430 | GT -> Span p' (max (p + l) (p' + l') - p') 431 | 432 | spanStart :: Span -> Int 433 | spanStart (Span s _) = s 434 | 435 | spanLength :: Span -> Int 436 | spanLength (Span _ l) = l 437 | -------------------------------------------------------------------------------- /src/Text/Sage/Indentation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE MagicHash #-} 5 | {-# LANGUAGE StandaloneDeriving #-} 6 | {-# LANGUAGE UnboxedSums #-} 7 | {-# LANGUAGE UnboxedTuples #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | 10 | module Text.Sage.Indentation ( 11 | Indented (..), 12 | runIndented, 13 | Amount (..), 14 | indented, 15 | current, 16 | indent, 17 | ) where 18 | 19 | import Control.Applicative (Alternative, empty, many) 20 | import Control.Monad (guard) 21 | import Control.Monad.State (StateT, evalStateT, get, modify, put) 22 | import Control.Monad.Trans.Class (lift) 23 | import Data.List.NonEmpty (NonEmpty (..)) 24 | import qualified Data.List.NonEmpty as NonEmpty 25 | import Streaming.Chars (Chars) 26 | import Text.Parser.Char (CharParsing, char) 27 | import Text.Parser.Combinators (Parsing, try, ()) 28 | import Text.Parser.LookAhead (lookAhead) 29 | import Text.Sage (Label (..), Parser, count, label) 30 | 31 | newtype Indented s a = Indented {unIndented :: StateT (NonEmpty Int) (Parser s) a} 32 | deriving 33 | ( Functor 34 | , Applicative 35 | , Alternative 36 | , Monad 37 | ) 38 | 39 | deriving instance (Chars s) => Parsing (Indented s) 40 | 41 | deriving instance (Chars s) => CharParsing (Indented s) 42 | 43 | runIndented :: Int -> Indented s a -> Parser s a 44 | runIndented lvl (Indented m) = 45 | evalStateT m (pure lvl) 46 | 47 | indentation :: (Chars s) => Int -> Parser s () 48 | indentation expected = 49 | try 50 | ( do 51 | actual <- length <$> many (char ' ') 52 | guard $ actual == expected 53 | ) 54 | ("indent ==" <> show expected) 55 | 56 | currentLevel :: Indented s Int 57 | currentLevel = 58 | Indented $ do 59 | lvl :| _ <- get 60 | pure lvl 61 | 62 | relative :: Int -> Indented s () 63 | relative lvl' = do 64 | lvl <- currentLevel 65 | let !lvl'' = lvl + lvl' 66 | Indented . modify $ NonEmpty.cons lvl'' 67 | 68 | data Amount = Add Int | Any 69 | 70 | indented :: (Chars s) => Amount -> Indented s a -> Indented s a 71 | indented amt p = 72 | case amt of 73 | Add n -> 74 | relative n *> p <* dedent 75 | Any -> do 76 | lvl <- currentLevel 77 | ( Indented $ 78 | lift (lookAhead $ parseIndent lvl) 79 | >>= modify . NonEmpty.cons 80 | ) 81 | *> p 82 | <* dedent 83 | 84 | parseIndent :: (Chars s) => Int -> Parser s Int 85 | parseIndent lvl = 86 | label 87 | (String $ "indent >" <> show lvl) 88 | ( do 89 | n <- count $ char ' ' 90 | n <$ guard (n > lvl) 91 | ) 92 | 93 | indent :: (Chars s) => Indented s Int 94 | indent = currentLevel >>= Indented . lift . parseIndent 95 | 96 | showDedentLevels :: NonEmpty Int -> String 97 | showDedentLevels lvls = 98 | "dedent " 99 | <> ( let x :| xs = NonEmpty.sort lvls 100 | in "==" 101 | <> show x 102 | <> foldMap ((", ==" <>) . show) xs 103 | ) 104 | 105 | dedent :: (Chars s) => Indented s () 106 | dedent = 107 | Indented $ do 108 | _currentLvl :| levels <- get 109 | case levels of 110 | [] -> error "already at base indentation" 111 | previousLvl : rest -> do 112 | mRes <- 113 | lift $ 114 | label 115 | (String $ showDedentLevels (previousLvl :| rest)) 116 | ( do 117 | n <- lookAhead $ count (char ' ') 118 | pure $ 119 | if n `elem` levels 120 | then Just (previousLvl :| rest) 121 | else Nothing 122 | ) 123 | maybe empty put mRes 124 | 125 | current :: (Chars s) => Indented s () 126 | current = do 127 | lvl <- currentLevel 128 | Indented . lift $ indentation lvl 129 | -------------------------------------------------------------------------------- /test/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedLists #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE PatternSynonyms #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | 6 | module Main where 7 | 8 | import Test.Hspec 9 | import Test.Indentation (indentationTests) 10 | import Test.Parser (parserTests) 11 | import Test.Span (spanTests) 12 | 13 | main :: IO () 14 | main = 15 | hspec $ do 16 | indentationTests 17 | parserTests 18 | spanTests 19 | -------------------------------------------------------------------------------- /test/Test/Indentation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE OverloadedLists #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | module Test.Indentation (indentationTests) where 6 | 7 | import Control.Applicative (many, optional, some, (<|>)) 8 | import Data.Text (Text) 9 | import qualified Data.Text as Text 10 | import Streaming.Chars (Chars) 11 | import Streaming.Chars.Text (StreamText (StreamText)) 12 | import Test.Hspec (Spec, describe, it, shouldBe) 13 | import Text.Parser.Char (char, letter, space, string) 14 | import Text.Sage (Label (..), ParseError (..), parse) 15 | import Text.Sage.Indentation (Amount (..), Indented, current, indented, runIndented) 16 | 17 | data Def 18 | = Def Text [Def] 19 | | Print Text 20 | deriving (Eq, Show) 21 | 22 | pythonish :: (Chars s) => Indented s Def 23 | pythonish = 24 | def 25 | <|> print' 26 | where 27 | def = 28 | Def . Text.pack 29 | <$ string "def" 30 | <* space 31 | <*> some letter 32 | <* string "():" 33 | <* char '\n' 34 | <*> indented Any (some (current *> pythonish <* optional (char '\n'))) 35 | print' = 36 | Print . Text.pack 37 | <$ string "print(\"" 38 | <*> many letter 39 | <* string "\")" 40 | 41 | indentationTests :: Spec 42 | indentationTests = do 43 | describe "Text.Sage.Indentation" $ do 44 | describe "indent" $ do 45 | it "2 spaces" $ do 46 | let input = 47 | Text.unlines 48 | [ "a" 49 | , " b" 50 | ] 51 | parse 52 | ( runIndented 0 $ 53 | (,) 54 | <$> char 'a' 55 | <* char '\n' 56 | <*> indented (Add 2) (current *> char 'b') 57 | ) 58 | (StreamText input) 59 | `shouldBe` Right ('a', 'b') 60 | it "4 spaces" $ do 61 | let input = 62 | Text.unlines 63 | [ "a" 64 | , " b" 65 | ] 66 | parse 67 | ( runIndented 0 $ 68 | (,) 69 | <$> char 'a' 70 | <* char '\n' 71 | <*> indented (Add 4) (current *> char 'b') 72 | ) 73 | (StreamText input) 74 | `shouldBe` Right ('a', 'b') 75 | it "expected 2 spaces but got 0" $ do 76 | let input = 77 | Text.unlines 78 | [ "a" 79 | , "b" 80 | ] 81 | parse 82 | ( runIndented 0 $ 83 | (,) 84 | <$> char 'a' 85 | <* char '\n' 86 | <*> indented (Add 2) (current *> char 'b') 87 | ) 88 | (StreamText input) 89 | `shouldBe` Left (Unexpected 2 [String "indent ==2"]) 90 | describe "dedent" $ do 91 | it "2 spaces then back to 0" $ do 92 | let input = 93 | Text.unlines 94 | [ "a" 95 | , " b" 96 | , "c" 97 | ] 98 | parse 99 | ( runIndented 0 $ 100 | (,,) 101 | <$> char 'a' 102 | <* char '\n' 103 | <*> indented (Add 2) (current *> char 'b' <* char '\n') 104 | <*> char 'c' 105 | ) 106 | (StreamText input) 107 | `shouldBe` Right ('a', 'b', 'c') 108 | it "2 spaces then back to 0 but stayed at 2" $ do 109 | let input = 110 | Text.unlines 111 | [ "a" 112 | , " b" 113 | , " c" 114 | ] 115 | parse 116 | ( runIndented 0 $ 117 | (,,) 118 | <$> char 'a' 119 | <* char '\n' 120 | <*> indented (Add 2) (current *> char 'b' <* char '\n') 121 | <*> char 'c' 122 | ) 123 | (StreamText input) 124 | `shouldBe` Left (Unexpected 6 [String "dedent ==0"]) 125 | describe "python-style, enforced 2-space indents" $ do 126 | it "1" $ do 127 | let input = 128 | Text.unlines 129 | [ "def hi():" 130 | , " print(\"yes\")" 131 | ] 132 | parse (runIndented 0 pythonish) (StreamText input) 133 | `shouldBe` Right (Def "hi" [Print "yes"]) 134 | it "2" $ do 135 | let input = 136 | Text.unlines 137 | [ "def f():" 138 | , " def g():" 139 | , " print(\"yes\")" 140 | ] 141 | parse (runIndented 0 pythonish) (StreamText input) 142 | `shouldBe` Right (Def "f" [Def "g" [Print "yes"]]) 143 | it "3" $ do 144 | let input = 145 | Text.unlines 146 | [ "def f():" 147 | , " def g():" 148 | , " print(\"yes\")" 149 | , " print(\"no\")" 150 | ] 151 | parse (runIndented 0 pythonish) (StreamText input) 152 | `shouldBe` Right (Def "f" [Def "g" [Print "yes"], Print "no"]) 153 | it "4" $ do 154 | let input = 155 | Text.unlines 156 | [ "def f():" 157 | , " def g():" 158 | , " print(\"yes\")" 159 | , " print(\"no\")" 160 | ] 161 | parse (runIndented 0 pythonish) (StreamText input) 162 | `shouldBe` Left (Unexpected 39 [String "dedent ==0, ==2", String "indent ==6"]) 163 | it "5" $ do 164 | let input = 165 | Text.unlines 166 | [ "def f():" 167 | , " def g():" 168 | , " def h():" 169 | , " print(\"yes\")" 170 | , " print(\"no\")" 171 | ] 172 | parse (runIndented 0 pythonish) (StreamText input) 173 | `shouldBe` Right (Def "f" [Def "g" [Def "h" [Print "yes"], Print "no"]]) 174 | it "6" $ do 175 | let input = 176 | Text.unlines 177 | [ "def f():" 178 | , " def g():" 179 | , " def h():" 180 | , " print(\"yes\")" 181 | , " print(\"no\")" 182 | ] 183 | parse (runIndented 0 pythonish) (StreamText input) 184 | `shouldBe` Right (Def "f" [Def "g" [Def "h" [Print "yes"]], Print "no"]) 185 | -------------------------------------------------------------------------------- /test/Test/Parser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE OverloadedLists #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | module Test.Parser (parserTests) where 6 | 7 | import Control.Applicative (empty, (<|>)) 8 | import Data.Char (isDigit) 9 | import qualified Data.Set as Set 10 | import Streaming.Chars (Chars) 11 | import Streaming.Chars.Text (StreamText) 12 | import Test.Hspec 13 | import Text.Parser.Char 14 | import Text.Parser.Combinators 15 | import Text.Sage 16 | 17 | decimal :: (Chars s) => Parser s Int 18 | decimal = read <$> some (satisfy isDigit "digit") 19 | 20 | parserTests :: Spec 21 | parserTests = 22 | describe "parser" $ do 23 | it "parse (char 'a') \"a\"" $ do 24 | let input :: StreamText 25 | input = "a" 26 | output = Right 'a' 27 | parse (char 'a') input `shouldBe` output 28 | it "parse (char 'a') \"b\"" $ do 29 | let input :: StreamText 30 | input = "b" 31 | output = Left (Unexpected 0 $ Set.fromList [Char 'a']) 32 | parse (char 'a') input `shouldBe` output 33 | it "parse digit \"5\"" $ do 34 | let input :: StreamText 35 | input = "5" 36 | output = Right '5' 37 | parse digit input `shouldBe` output 38 | it "parse digit \"a\"" $ do 39 | let input :: StreamText 40 | input = "a" 41 | output = Left (Unexpected 0 $ Set.fromList [String "digit"]) 42 | parse digit input `shouldBe` output 43 | it "parse decimal \"11223344\"" $ do 44 | let input :: StreamText 45 | input = "11223344" 46 | output = Right (11223344 :: Int) 47 | parse decimal input `shouldBe` output 48 | it "parse decimal \"a1223344\"" $ do 49 | let input :: StreamText 50 | input = "a1223344" 51 | output = Left (Unexpected 0 $ Set.fromList [String "digit"]) :: Either ParseError Int 52 | parse decimal input `shouldBe` output 53 | it "parse (decimal <* eof) \"1122a344\"" $ do 54 | let input :: StreamText 55 | input = "1122a344" 56 | output = Left (Unexpected 4 $ Set.fromList [Eof, String "digit"]) :: Either ParseError Int 57 | parse (decimal <* eof) input `shouldBe` output 58 | it "parse (text \"ab\") \"ab\"" $ do 59 | let input :: StreamText 60 | input = "ab" 61 | output = Right "ab" 62 | parse (text "ab") input `shouldBe` output 63 | it "parse (text \"ab\") \"ac\"" $ do 64 | let input :: StreamText 65 | input = "ac" 66 | output = Left (Unexpected 0 $ Set.fromList [Text "ab"]) 67 | parse (text "ab") input `shouldBe` output 68 | it "parse (text \"ab\") \"ac\"" $ do 69 | let input :: StreamText 70 | input = "ac" 71 | output = Left (Unexpected 0 $ Set.fromList [Text "ab"]) 72 | parse (text "ab") input `shouldBe` output 73 | it "parse (sepBy (char 'a') (char 'b')) \"a\"" $ do 74 | let input :: StreamText 75 | input = "a" 76 | output = Right ['a'] 77 | parse (sepBy (char 'a') (char 'b')) input `shouldBe` output 78 | it "parse (sepBy (char 'a') (char 'b')) \"ababa\"" $ do 79 | let input :: StreamText 80 | input = "ababa" 81 | output = Right ['a', 'a', 'a'] 82 | parse (sepBy (char 'a') (char 'b')) input `shouldBe` output 83 | it "parse (1 <$ text \"toast\" <|> 2 <$ text \"toot\" <|> 3 <$ text \"tock\") \"toot\"" $ do 84 | let input :: StreamText 85 | input = "toot" 86 | output = Right (2 :: Int) 87 | parse (1 <$ text "toast" <|> 2 <$ text "toot" <|> 3 <$ text "tock") input `shouldBe` output 88 | it "parse (1 <$ text \"toast\" <|> 2 <$ text \"toot\" <|> 3 <$ text \"tock\") \"tool\"" $ do 89 | let input :: StreamText 90 | input = "tool" 91 | output = Left (Unexpected 0 $ Set.fromList [Text "toast", Text "toot", Text "tock"]) 92 | parse ((1 :: Int) <$ text "toast" <|> 2 <$ text "toot" <|> 3 <$ text "tock") input `shouldBe` output 93 | it "parse (char 'a' *> char 'b') \"ab\"" $ do 94 | let input :: StreamText 95 | input = "ab" 96 | output = Right 'b' 97 | parse (char 'a' *> char 'b') input `shouldBe` output 98 | it "parse (char 'a' *> char 'b') \"ac\"" $ do 99 | let input :: StreamText 100 | input = "ac" 101 | output = Left (Unexpected 1 $ Set.fromList [Char 'b']) 102 | parse (char 'a' *> char 'b') input `shouldBe` output 103 | it "parse (char 'a' <|> empty) \"b\"" $ do 104 | let input :: StreamText 105 | input = "b" 106 | output = Left (Unexpected 0 $ Set.fromList [Char 'a']) 107 | parse (char 'a' <|> empty) input `shouldBe` output 108 | it "parse (char 'a' <|> char 'b') \"a\"" $ do 109 | let input :: StreamText 110 | input = "a" 111 | output = Right 'a' 112 | parse (char 'a' <|> char 'b') input `shouldBe` output 113 | it "parse (char 'a' <|> char 'b') \"b\"" $ do 114 | let input :: StreamText 115 | input = "b" 116 | output = Right 'b' 117 | parse (char 'a' <|> char 'b') input `shouldBe` output 118 | it "parse (char 'a' <|> char 'b') \"c\"" $ do 119 | let input :: StreamText 120 | input = "c" 121 | output = Left (Unexpected 0 $ Set.fromList [Char 'a', Char 'b']) 122 | parse (char 'a' <|> char 'b') input `shouldBe` output 123 | it "parse (char 'a' *> char 'x' <|> char 'b' *> char 'y' <|> char 'c' *> char 'z') \"d\"" $ do 124 | let input :: StreamText 125 | input = "d" 126 | output = Left (Unexpected 0 $ Set.fromList [Char 'a', Char 'b', Char 'c']) 127 | parse (char 'a' *> char 'x' <|> char 'b' *> char 'y' <|> char 'c' *> char 'z') input `shouldBe` output 128 | it "parse (char 'a' *> char 'x' <|> char 'b' *> char 'y' <|> char 'c' *> char 'z') \"bz\"" $ do 129 | let input :: StreamText 130 | input = "bz" 131 | output = Left (Unexpected 1 $ Set.fromList [Char 'y']) 132 | parse (char 'a' *> char 'x' <|> char 'b' *> char 'y' <|> char 'c' *> char 'z') input `shouldBe` output 133 | it "parse (char 'a' *> char 'x' <|> char 'b' *> char 'y' <|> char 'c' *> char 'z') \"c\"" $ do 134 | let input :: StreamText 135 | input = "c" 136 | output = Left (Unexpected 1 $ Set.fromList [Char 'z']) 137 | parse (char 'a' *> char 'x' <|> char 'b' *> char 'y' <|> char 'c' *> char 'z') input `shouldBe` output 138 | it "parse (char 'a' *> char 'x' \"ax\" <|> char 'b' *> char 'y' \"by\" <|> char 'c' *> char 'z' \"cz\") \"d\"" $ do 139 | let input :: StreamText 140 | input = "d" 141 | output = Left (Unexpected 0 $ Set.fromList [String "ax", String "by", String "cz"]) 142 | parse 143 | ( (char 'a' *> char 'x' "ax") 144 | <|> (char 'b' *> char 'y' "by") 145 | <|> (char 'c' *> char 'z' "cz") 146 | ) 147 | input 148 | `shouldBe` output 149 | it "parse (some (char 'a') <* char 'b') \"aaac\"" $ do 150 | let input :: StreamText 151 | input = "aaac" 152 | output = Left (Unexpected 3 $ Set.fromList [Char 'a', Char 'b']) 153 | parse (some (char 'a') <* char 'b') input `shouldBe` output 154 | it "parse (char '(' *> some (char 'x') <* char ')') \"(xx)\"" $ do 155 | let input :: StreamText 156 | input = "(xx)" 157 | output = Right ['x', 'x'] 158 | parse (char '(' *> some (char 'x') <* char ')') input `shouldBe` output 159 | it "parse (char '(' *> some (char 'x') <* char ')') \"(xxy\"" $ do 160 | let input :: StreamText 161 | input = "(xxy" 162 | output = Left (Unexpected 3 $ Set.fromList [Char ')', Char 'x']) 163 | parse (char '(' *> some (char 'x') <* char ')') input `shouldBe` output 164 | it "parse (try (char 'a' <* empty)) \"a\"" $ do 165 | let input :: StreamText 166 | input = "a" 167 | output = Left $ Unexpected 0 [] 168 | parse (try (char 'a' <* empty)) input `shouldBe` output 169 | it "parse (try (char 'a' <* empty) \"thing\") \"a\"" $ do 170 | let input :: StreamText 171 | input = "a" 172 | output = Left $ Unexpected 0 [String "thing"] 173 | parse (try (char 'a' <* empty) "thing") input `shouldBe` output 174 | it "parse (char 'a' *> (try (False <$ char 'b' <* char 'c') <|> True <$ char 'b')) \"abc\"" $ do 175 | let input :: StreamText 176 | input = "abc" 177 | output = Right False 178 | parse 179 | ( char 'a' 180 | *> ( try (False <$ char 'b' <* char 'c') 181 | <|> True <$ char 'b' 182 | ) 183 | ) 184 | input 185 | `shouldBe` output 186 | it "parse (char 'a' *> (try (False <$ char 'b' <* char 'c') <|> True <$ char 'b')) \"ab\"" $ do 187 | let input :: StreamText 188 | input = "ab" 189 | output = Right True 190 | parse 191 | ( char 'a' 192 | *> ( try (False <$ char 'b' <* char 'c') 193 | <|> True <$ char 'b' 194 | ) 195 | ) 196 | input 197 | `shouldBe` output 198 | it "parse (char 'a' *> (try (False <$ char 'b' <* char 'c') <|> True <$ char 'b')) \"ac\"" $ do 199 | let input :: StreamText 200 | input = "ac" 201 | output = Left $ Unexpected 1 [Char 'b'] 202 | parse 203 | ( char 'a' 204 | *> ( try (False <$ char 'b' <* char 'c') 205 | <|> True <$ char 'b' 206 | ) 207 | ) 208 | input 209 | `shouldBe` output 210 | describe "let atom = 1 <$ char 'x' <|> char '(' *> fmap sum (many atom) <* char ')' in fmap sum (some atom) <* eof" $ do 211 | let atom = 1 <$ char 'x' <|> char '(' *> fmap sum (many atom) <* char ')' 212 | p = fmap sum (some atom) <* eof 213 | it "\"()\"" $ do 214 | let input :: StreamText 215 | input = "()" 216 | output = Right (0 :: Int) 217 | parse p input `shouldBe` output 218 | it "\"()xxx\"" $ do 219 | let input :: StreamText 220 | input = "()xxx" 221 | output = Right (3 :: Int) 222 | parse p input `shouldBe` output 223 | it "\"()xxx(y\"" $ do 224 | let input :: StreamText 225 | input = "()xxx(y" 226 | output = Left (Unexpected 6 $ Set.fromList [Char '(', Char 'x', Char ')']) 227 | parse p input `shouldBe` output 228 | it "\"()xxx()\"" $ do 229 | let input :: StreamText 230 | input = "()xxx()y" 231 | output = Left (Unexpected 7 $ Set.fromList [Char '(', Char 'x', Eof]) 232 | parse p input `shouldBe` output 233 | -------------------------------------------------------------------------------- /test/Test/Span.hs: -------------------------------------------------------------------------------- 1 | module Test.Span (spanTests) where 2 | 3 | import Hedgehog 4 | import qualified Hedgehog.Gen as Gen 5 | import qualified Hedgehog.Range as Range 6 | import Test.Hspec 7 | import Test.Hspec.Hedgehog (hedgehog, modifyMaxSuccess) 8 | import Text.Sage (Span (..), spanContains) 9 | 10 | genSpan :: Gen Span 11 | genSpan = do 12 | p <- Gen.int $ Range.constant 0 maxBound 13 | l <- Gen.int $ Range.constant 0 (maxBound - p) 14 | pure $ Span p l 15 | 16 | spanTests :: Spec 17 | spanTests = 18 | modifyMaxSuccess (const 10000) . describe "span" $ do 19 | it "associativity" . hedgehog $ do 20 | a <- forAll genSpan 21 | b <- forAll genSpan 22 | c <- forAll genSpan 23 | a <> b <> c === (a <> b) <> c 24 | it "commutativity" . hedgehog $ do 25 | a <- forAll genSpan 26 | b <- forAll genSpan 27 | a <> b === b <> a 28 | it "idempotence" . hedgehog $ do 29 | a <- forAll genSpan 30 | a <> a === a 31 | it "lower bound" . hedgehog $ do 32 | a <- forAll genSpan 33 | b <- forAll genSpan 34 | let c = a <> b 35 | assert $ spanContains c a 36 | assert $ spanContains c b 37 | --------------------------------------------------------------------------------