Add support for source locations
cskksc
7 years ago
| 25 | 25 | -- ** Numeric Literals for Arbitrary Bases |
| 26 | 26 | , commonLispNumberAnyBase |
| 27 | 27 | , gnuM4NumberAnyBase |
| 28 | -- ** Source locations | |
| 29 | , Location(..), Located(..), located | |
| 28 | 30 | ) where |
| 29 | 31 | |
| 30 | 32 | #if !MIN_VERSION_base(4,8,0) |
| 332 | 334 | signedHexNumber :: Parser Integer |
| 333 | 335 | signedHexNumber = ($) <$> sign <*> hexNumber |
| 334 | 336 | |
| 337 | ||
| 338 | -- | | |
| 339 | data Location = Span !SourcePos !SourcePos | |
| 340 | deriving (Eq, Ord, Show) | |
| 341 | ||
| 342 | -- | Add support for source locations while parsing S-expressions, as described in this | |
| 343 | -- <https://www.reddit.com/r/haskell/comments/4x22f9/labelling_ast_nodes_with_locations/d6cmdy9/ Reddit> | |
| 344 | -- thread. | |
| 345 | data Located a = At !Location a | |
| 346 | deriving (Eq, Ord, Show) | |
| 347 | ||
| 348 | -- | Adds a source span to a parser. | |
| 349 | located :: Parser a -> Parser (Located a) | |
| 350 | located parser = do | |
| 351 | begin <- getPosition | |
| 352 | result <- parser | |
| 353 | end <- getPosition | |
| 354 | return $ At (Span begin end) result | |
| 355 | ||
| 356 | ||
| 335 | 357 | {- $intro |
| 336 | 358 | |
| 337 | 359 | This module contains a selection of parsers for different kinds of |
| 5 | 5 | -- $descr |
| 6 | 6 | basicParser |
| 7 | 7 | , basicPrinter |
| 8 | , locatedBasicParser | |
| 8 | 9 | ) where |
| 9 | 10 | |
| 10 | 11 | import Control.Applicative ((<$>)) |
| 11 | 12 | import Data.Char (isAlphaNum) |
| 12 | 13 | import Text.Parsec (many1, satisfy) |
| 13 | 14 | import Data.Text (Text, pack) |
| 15 | import Data.Functor.Identity (Identity) | |
| 16 | import Text.Parsec.Prim (ParsecT) | |
| 14 | 17 | |
| 18 | import Data.SCargot.Common (Located, located) | |
| 15 | 19 | import Data.SCargot.Repr.Basic (SExpr) |
| 16 | 20 | import Data.SCargot ( SExprParser |
| 17 | 21 | , SExprPrinter |
| 24 | 28 | || c == '-' || c == '*' || c == '/' |
| 25 | 29 | || c == '+' || c == '<' || c == '>' |
| 26 | 30 | || c == '=' || c == '!' || c == '?' |
| 31 | ||
| 32 | pToken :: ParsecT Text a Identity Text | |
| 33 | pToken = pack <$> many1 (satisfy isAtomChar) | |
| 27 | 34 | |
| 28 | 35 | -- $descr |
| 29 | 36 | -- The 'basicSpec' describes S-expressions whose atoms are simply |
| 43 | 50 | -- Right [SCons (SAtom "1") (SCons (SAtom "elephant") SNil)] |
| 44 | 51 | basicParser :: SExprParser Text (SExpr Text) |
| 45 | 52 | basicParser = mkParser pToken |
| 46 | where pToken = pack <$> many1 (satisfy isAtomChar) | |
| 53 | ||
| 54 | -- | A 'basicParser' which produces 'Located' values | |
| 55 | -- | |
| 56 | -- >>> decode locatedBasicParser $ pack "(1 elephant)" | |
| 57 | -- Right [SCons (SAtom (At (Span (line 1, column 2) (line 1, column 3)) "1")) (SCons (SAtom (At (Span (line 1, column 4) (line 1, column 12)) "elephant")) SNil)] | |
| 58 | -- | |
| 59 | -- >>> decode locatedBasicParser $ pack "(let ((x 1))\n x)" | |
| 60 | -- Right [SCons (SAtom (At (Span (line 1, column 2) (line 1, column 5)) "let")) (SCons (SCons (SCons (SAtom (At (Span (line 1, column 8) (line 1, column 9)) "x")) (SCons (SAtom (At (Span (line 1, column 10) (line 1, column 11)) "1")) SNil)) SNil) (SCons (SAtom (At (Span (line 2, column 3) (line 2, column 4)) "x")) SNil))] | |
| 61 | locatedBasicParser :: SExprParser (Located Text) (SExpr (Located Text)) | |
| 62 | locatedBasicParser = mkParser $ located pToken | |
| 47 | 63 | |
| 48 | 64 | -- | A 'SExprPrinter' that prints textual atoms directly (without quoting |
| 49 | 65 | -- or any other processing) onto a single line. |
| 9 | 9 | , parseHaskellString |
| 10 | 10 | , parseHaskellFloat |
| 11 | 11 | , parseHaskellInt |
| 12 | , locatedHaskLikeParser | |
| 12 | 13 | ) where |
| 13 | 14 | |
| 14 | 15 | #if !MIN_VERSION_base(4,8,0) |
| 157 | 158 | haskLikeParser :: SExprParser HaskLikeAtom (SExpr HaskLikeAtom) |
| 158 | 159 | haskLikeParser = mkParser pHaskLikeAtom |
| 159 | 160 | |
| 161 | -- | A 'haskLikeParser' which produces 'Located' values | |
| 162 | -- | |
| 163 | -- >>> decode locatedHaskLikeParser $ pack "(0x01 \"\\x65lephant\")" | |
| 164 | -- Right [SCons (SAtom (At (Span (line 1, column 2) (line 1, column 6)) (HSInt 1))) (SCons (SAtom (At (Span (line 1, column 7) (line 1, column 20)) (HSString "elephant"))) SNil)] | |
| 165 | -- | |
| 166 | -- >>> decode locatedHaskLikeParser $ pack "(1 elephant)" | |
| 167 | -- Right [SCons (SAtom (At (Span (line 1, column 2) (line 1, column 3)) (HSInt 1))) (SCons (SAtom (At (Span (line 1, column 4) (line 1, column 12)) (HSIdent "elephant"))) SNil)] | |
| 168 | locatedHaskLikeParser :: SExprParser (Located HaskLikeAtom) (SExpr (Located HaskLikeAtom)) | |
| 169 | locatedHaskLikeParser = mkParser $ located pHaskLikeAtom | |
| 170 | ||
| 171 | ||
| 160 | 172 | -- | This 'SExprPrinter' emits s-expressions that contain Scheme-like |
| 161 | 173 | -- tokens as well as string literals, integer literals, and floating-point |
| 162 | 174 | -- literals, which will be emitted as the literals produced by Haskell's |