Merge branch 'master' of github.com:aisamanra/s-cargot

Data/SCargot/Common.hs

@@ -25,6 +25,8 @@ module Data.SCargot.Common ( -- $intro
                              -- ** Numeric Literals for Arbitrary Bases
                            , commonLispNumberAnyBase
                            , gnuM4NumberAnyBase
+                             -- ** Source locations
+                           , Location(..), Located(..), located, dLocation
                            ) where
 
 #if !MIN_VERSION_base(4,8,0)
@@ -35,6 +37,7 @@ import           Data.Char
 import           Data.Text (Text)
 import qualified Data.Text as T
 import           Text.Parsec
+import           Text.Parsec.Pos  (newPos)
 import           Text.Parsec.Text (Parser)
 
 -- | Parse an identifier according to the R5RS Scheme standard. This
@@ -332,6 +335,30 @@ hexNumber = number 16 hexDigit
 signedHexNumber :: Parser Integer
 signedHexNumber = ($) <$> sign <*> hexNumber
 
+
+-- |
+data Location = Span !SourcePos !SourcePos
+  deriving (Eq, Ord, Show)
+
+-- | Add support for source locations while parsing S-expressions, as described in this
+--   <https://www.reddit.com/r/haskell/comments/4x22f9/labelling_ast_nodes_with_locations/d6cmdy9/ Reddit>
+-- thread.
+data Located a = At !Location a
+  deriving (Eq, Ord, Show)
+
+-- | Adds a source span to a parser.
+located :: Parser a -> Parser (Located a)
+located parser = do
+  begin <- getPosition
+  result <- parser
+  end <- getPosition
+  return $ At (Span begin end) result
+
+-- | A default location value
+dLocation :: Location
+dLocation = Span dPos dPos
+  where dPos = newPos "" 0 0
+
 {- $intro
 
 This module contains a selection of parsers for different kinds of

Data/SCargot/Language/Basic.hs

@@ -5,13 +5,18 @@ module Data.SCargot.Language.Basic
     -- $descr
     basicParser
   , basicPrinter
+  , locatedBasicParser
+  , locatedBasicPrinter
   ) where
 
 import           Control.Applicative ((<$>))
 import           Data.Char (isAlphaNum)
 import           Text.Parsec (many1, satisfy)
 import           Data.Text (Text, pack)
+import           Data.Functor.Identity (Identity)
+import           Text.Parsec.Prim (ParsecT)
 
+import           Data.SCargot.Common (Located(..), located)
 import           Data.SCargot.Repr.Basic (SExpr)
 import           Data.SCargot ( SExprParser
                               , SExprPrinter
@@ -25,6 +30,9 @@ isAtomChar c = isAlphaNum c
   || c == '+' || c == '<' || c == '>'
   || c == '=' || c == '!' || c == '?'
 
+pToken :: ParsecT Text a Identity Text
+pToken = pack <$> many1 (satisfy isAtomChar)
+
 -- $descr
 -- The 'basicSpec' describes S-expressions whose atoms are simply
 -- text strings that contain alphanumeric characters and a small
@@ -43,7 +51,16 @@ isAtomChar c = isAlphaNum c
 -- Right [SCons (SAtom "1") (SCons (SAtom "elephant") SNil)]
 basicParser :: SExprParser Text (SExpr Text)
 basicParser = mkParser pToken
-  where pToken = pack <$> many1 (satisfy isAtomChar)
+
+-- | A 'basicParser' which produces 'Located' values
+--
+-- >>> decode locatedBasicParser $ pack "(1 elephant)"
+-- 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)]
+--
+-- >>> decode locatedBasicParser $ pack "(let ((x 1))\n  x)"
+-- 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))]
+locatedBasicParser :: SExprParser (Located Text) (SExpr (Located Text))
+locatedBasicParser = mkParser $ located pToken
 
 -- | A 'SExprPrinter' that prints textual atoms directly (without quoting
 --   or any other processing) onto a single line.
@@ -52,3 +69,15 @@ basicParser = mkParser pToken
 -- "(1 elephant)"
 basicPrinter :: SExprPrinter Text (SExpr Text)
 basicPrinter = flatPrint id
+
+-- | A 'SExprPrinter' for 'Located' values. Works exactly like 'basicPrinter'
+--   It ignores the location tags when printing the result.
+--
+-- >>> let (Right dec) = decode locatedBasicParser $ pack "(1 elephant)"
+-- [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)]
+--
+-- >>> encode locatedBasicPrinter dec
+-- "(1 elephant)"
+locatedBasicPrinter :: SExprPrinter (Located Text) (SExpr (Located Text))
+locatedBasicPrinter = flatPrint unLoc
+  where unLoc (At _loc e) = e

Data/SCargot/Language/HaskLike.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 module Data.SCargot.Language.HaskLike
@@ -5,6 +6,8 @@ module Data.SCargot.Language.HaskLike
     HaskLikeAtom(..)
   , haskLikeParser
   , haskLikePrinter
+  , locatedHaskLikeParser
+  , locatedHaskLikePrinter
     -- * Individual Parsers
   , parseHaskellString
   , parseHaskellFloat
@@ -56,6 +59,9 @@ data HaskLikeAtom
 instance IsString HaskLikeAtom where
   fromString = HSIdent . fromString
 
+instance IsString (Located HaskLikeAtom) where
+  fromString = (At dLocation) . HSIdent . fromString
+
 -- | Parse a Haskell string literal as defined by the Haskell 2010
 -- language specification.
 parseHaskellString :: Parser Text
@@ -157,6 +163,16 @@ sHaskLikeAtom (HSFloat f)  = pack (show f)
 haskLikeParser :: SExprParser HaskLikeAtom (SExpr HaskLikeAtom)
 haskLikeParser = mkParser pHaskLikeAtom
 
+-- | A 'haskLikeParser' which produces 'Located' values
+--
+-- >>> decode locatedHaskLikeParser $ pack "(0x01 \"\\x65lephant\")"
+-- 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)]
+--
+-- >>> decode locatedHaskLikeParser $ pack "(1 elephant)"
+-- 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)]
+locatedHaskLikeParser :: SExprParser (Located HaskLikeAtom) (SExpr (Located HaskLikeAtom))
+locatedHaskLikeParser = mkParser $ located pHaskLikeAtom
+
 -- | This 'SExprPrinter' emits s-expressions that contain Scheme-like
 --   tokens as well as string literals, integer literals, and floating-point
 --   literals, which will be emitted as the literals produced by Haskell's
@@ -167,3 +183,18 @@ haskLikeParser = mkParser pHaskLikeAtom
 -- "(1 \"elephant\")"
 haskLikePrinter :: SExprPrinter HaskLikeAtom (SExpr HaskLikeAtom)
 haskLikePrinter = flatPrint sHaskLikeAtom
+
+-- | Ignore location tags when packing values into text
+sLocatedHasklikeAtom :: Located HaskLikeAtom -> Text
+sLocatedHasklikeAtom (At _loc e) = sHaskLikeAtom e
+
+-- | A 'SExprPrinter' for 'Located' values. Works exactly like 'haskLikePrinter'
+--   It ignores the location tags when printing the result.
+--
+-- >>> let (Right dec) = decode locatedHaskLikeParser $ pack "(1 elephant)"
+-- [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)]
+--
+-- >>> encode locatedHaskLikePrinter dec
+-- "(1 elephant)"
+locatedHaskLikePrinter :: SExprPrinter (Located HaskLikeAtom) (SExpr (Located HaskLikeAtom))
+locatedHaskLikePrinter = flatPrint sLocatedHasklikeAtom