Several changes: new helper functions for decoding from various

reprs; new Comments module; new IsString instance for SExpr types...

Data/SCargot/Basic.hs

@@ -6,7 +6,7 @@ module Data.SCargot.Basic
   , asWellFormed
   , addReader
   , setComment
-  , withSemicolonComments
+  , withLispComments
   , withQuote
   ) where
 
@@ -15,7 +15,8 @@ import           Data.Attoparsec.Text (Parser, takeWhile1)
 import           Data.Text (Text)
 
 import           Data.SCargot.Repr.Basic
-import           Data.SCargot.General hiding (withQuote)
+import           Data.SCargot.General
+import           Data.SCargot.Comments (withLispComments)
 
 isAtomChar :: Char -> Bool
 isAtomChar c = isAlphaNum c
@@ -38,12 +39,3 @@ isAtomChar c = isAlphaNum c
 --   storage or configuration formats.
 basicSpec :: SExprSpec Text (SExpr Text)
 basicSpec = mkSpec (takeWhile1 isAtomChar) id
-
-withQuote :: SExprSpec Text a -> SExprSpec Text a
-withQuote = addReader '\'' (fmap go)
-  where go s = SCons (SAtom "quote") (SCons s SNil)

Data/SCargot/Comments.hs

@@ -0,0 +1,160 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Data.SCargot.Comments
+  ( -- * Comment Syntax
+    -- $intro
+    -- * Lisp Comments
+    withLispComments
+    -- * Other Existing Comment Syntaxes
+    -- ** Scripting Language Syntax
+    -- $script
+  , withOctothorpeComments
+    -- ** C-Like Syntax
+    -- $clike
+  , withCLikeLineComments
+  , withCLikeBlockComments
+  , withCLikeComments
+    -- ** Haskell Syntax
+    -- $haskell
+  , withHaskellLineComments
+  , withHaskellBlockComments
+  , withHaskellComments
+    -- * Comment Syntax Helper Functions
+  , lineComment
+  , simpleBlockComment
+  ) where
+
+import           Control.Applicative ((<|>))
+import           Control.Monad (void)
+import           Data.Attoparsec.Text
+import           Data.Text (Text)
+
+import           Prelude hiding (takeWhile)
+
+import Data.SCargot.General
+
+-- | Given a string, produce a comment parser that matches that
+--   initial string and ignores everything until the end of the
+--   line.
+lineComment :: Text -> Comment
+lineComment s = string s >> takeWhile (/= '\n') >> return ()
+
+-- | Given two strings, a begin and an end delimeter, produce a
+--   parser that matches the beginning delimeter and then ignores
+--   everything until it finds the end delimiter. This does not
+--   consider nesting, so, for example, a comment created with
+--
+-- > curlyComment :: Comment
+-- > curlyComment = simpleBlockComment "{" "}"
+--
+-- will consider
+--
+-- > { this { comment }
+--
+-- to be a complete comment, despite the improper nesting. This is
+-- analogous to standard C-style comments in which
+--
+-- > /* this /* comment */
+--
+-- is a complete comment.
+simpleBlockComment :: Text -> Text -> Comment
+simpleBlockComment begin end =
+  string begin >>
+  manyTill anyChar (string end) >>
+  return ()
+
+-- | Lisp-style line-oriented comments start with @;@ and last
+--   until the end of the line. This is usually the comment
+--   syntax you want.
+withLispComments :: SExprSpec t a -> SExprSpec t a
+withLispComments = setComment (lineComment ";")
+
+-- | C++-like line-oriented comment start with @//@ and last
+--   until the end of the line.
+withCLikeLineComments :: SExprSpec t a -> SExprSpec t a
+withCLikeLineComments = setComment (lineComment "//")
+
+-- | C-like block comments start with @/*@ and end with @*/@.
+--   They do not nest.
+withCLikeBlockComments :: SExprSpec t a -> SExprSpec t a
+withCLikeBlockComments = setComment (simpleBlockComment "/*" "*/")
+
+-- | C-like comments include both line- and block-comments, the
+--   former starting with @//@ and the latter contained within
+--   @//* ... *//@.
+withCLikeComments :: SExprSpec t a -> SExprSpec t a
+withCLikeComments = setComment (lineComment "//" <|>
+                                simpleBlockComment "/*" "*/")
+
+-- | Haskell line-oriented comments start with @--@ and last
+--   until the end of the line.
+withHaskellLineComments :: SExprSpec t a -> SExprSpec t a
+withHaskellLineComments = setComment (lineComment "--")
+
+-- | Haskell block comments start with @{-@ and end with @-}@.
+--   They do not nest.
+withHaskellBlockComments :: SExprSpec t a -> SExprSpec t a
+withHaskellBlockComments = setComment (simpleBlockComment "{-" "-}")
+
+-- | Haskell comments include both the line-oriented @--@ comments
+--   and the block-oriented @{- ... -}@ comments
+withHaskellComments :: SExprSpec t a -> SExprSpec t a
+withHaskellComments = setComment (lineComment "--" <|>
+                                  simpleBlockComment "{-" "-}")
+
+-- | Many scripting and shell languages use these, which begin with
+--   @#@ and last until the end of the line.
+withOctothorpeComments :: SExprSpec t a -> SExprSpec t a
+withOctothorpeComments = setComment (lineComment "#")
+
+
+{- $intro
+
+By default a 'SExprSpec' will not understand any kind of comment
+syntax. Most varieties of s-expression will, however, want some kind
+of commenting capability, so the below functions will produce a new
+'SExprSpec' which understands various kinds of comment syntaxes.
+
+For example:
+
+> mySpec :: SExprSpec Text (SExpr Text)
+> mySpec = asWellFormed (mkSpec (takeWhile1 isAlphaNum) id)
+>
+> myLispySpec :: SExprSpec Text (SExpr Text)
+> myLispySpec = withLispComments mySpec
+>
+> myCLikeSpec :: SExprSpec Text (SExpr Text)
+> myCLikeSpec = withCLikeComment mySpec
+
+We can then use these to parse s-expressions with different kinds of
+comment syntaxes:
+
+> decode mySpec "(foo ; a lisp comment\n  bar)\n"
+> Left "Failed reading: takeWhile1"
+> decode myLispySpec "(foo ; a lisp comment\n  bar)\n"
+> Right [WFSList [WFSAtom "foo", WFSAtom "bar"]]
+> decode mySpec "(foo /* a c-like\n   comment */ bar)\n"
+> Left "Failed reading: takeWhile1"
+> decode myCLikeSpec "(foo /* a c-like\n   comment */ bar)\n"
+> Right [WFSList [WFSAtom "foo", WFSAtom "bar"]]
+
+-}
+
+{- $script
+> (one   # a comment
+>   two  # another one
+>   three)
+-}
+
+{- $clike
+> (one // a comment
+>   two /* another
+>          one */
+>   three)
+-}
+
+-- $haskell
+-- > (one -- a comment
+-- >   two {- another
+-- >          one -}
+-- >   three)

Data/SCargot/General.hs

@@ -11,7 +11,6 @@ module Data.SCargot.General
     -- * Specific SExprSpec Conversions
   , asRich
   , asWellFormed
-  , withSemicolonComments
   , withQuote
     -- * Using a SExprSpec
   , decode
@@ -30,6 +29,7 @@ import           Data.Char (isAlpha, isDigit, isAlphaNum)
 import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
 import           Data.Monoid ((<>))
+import           Data.String (IsString)
 import           Data.Text (Text, pack, unpack)
 import qualified Data.Text as T
 
@@ -163,18 +163,14 @@ addReader c reader spec = spec
 setComment :: Comment -> SExprSpec a c -> SExprSpec a c
 setComment c spec = spec { comment = Just c }
 
-withSemicolonComments :: SExprSpec a c -> SExprSpec a c
-withSemicolonComments = setComment (char ';' >> takeWhile (/='\n') >> return ())
-
 -- | Add the ability to understand a quoted S-Expression. In general,
 --   many Lisps use @'sexpr@ as sugar for @(quote sexpr)@. This is
 --   a convenience function which allows you to easily add quoted
 --   expressions to a 'SExprSpec', provided that you supply which
 --   atom you want substituted in for the symbol @quote@.
-withQuote :: a -> SExprSpec a (SExpr a) -> SExprSpec a (SExpr a)
-withQuote q = addReader '\'' (fmap go)
-  where go s  = SCons (SAtom q) (SCons s SNil)
+withQuote :: IsString t => SExprSpec t (SExpr t) -> SExprSpec t (SExpr t)
+withQuote = addReader '\'' (fmap go)
+  where go s  = SCons "quote" (SCons s SNil)
 
 parseGenericSExpr ::
   Parser atom  -> ReaderMacroMap atom -> Parser () -> Parser (SExpr atom)

Data/SCargot/Repr.hs

@@ -13,6 +13,8 @@ module Data.SCargot.Repr
        , fromWellFormed
        ) where
 
+import Data.String (IsString(..))
+
 -- | All S-Expressions can be understood as a sequence
 --   of @cons@ cells (represented here by 'SCons'), the
 --   empty list @nil@ (represented by 'SNil') or an
@@ -23,6 +25,9 @@ data SExpr atom
   | SNil
     deriving (Eq, Show, Read, Functor)
 
+instance IsString atom => IsString (SExpr atom) where
+  fromString = SAtom . fromString
+
 -- | Sometimes, the cons-based interface is too low
 --   level, and we'd rather have the lists themselves
 --   exposed. In this case, we have 'RSList' to
@@ -40,6 +45,9 @@ data RichSExpr atom
   | RSAtom atom
     deriving (Eq, Show, Read, Functor)
 
+instance IsString atom => IsString (RichSExpr atom) where
+  fromString = RSAtom . fromString
+
 -- |  It should always be true that
 --
 --   > fromRich (toRich x) == x
@@ -70,6 +78,9 @@ data WellFormedSExpr atom
   | WFSAtom atom
     deriving (Eq, Show, Read, Functor)
 
+instance IsString atom => IsString (WellFormedSExpr atom) where
+  fromString = WFSAtom . fromString
+
 -- | This will be @Nothing@ if the argument contains an
 --   improper list. It should hold that
 --
@@ -77,9 +88,9 @@ data WellFormedSExpr atom
 --
 --   and also (more tediously) that
 --
+--   > case toWellFormed x of
 --   >   Left _  -> True
+--   >   Right y -> x == fromWellFormed y
 toWellFormed :: SExpr atom -> Either String (WellFormedSExpr atom)
 toWellFormed SNil      = return (WFSList [])
 toWellFormed (SAtom a) = return (WFSAtom a)

Data/SCargot/Repr/Basic.hs

@@ -7,8 +7,12 @@ module Data.SCargot.Repr.Basic
        , pattern (:::)
        , pattern A
        , pattern Nil
+         -- * Useful processing functions
+       , fromPair
+       , fromList
        ) where
 
+import Control.Applicative ((<$>), (<*>), pure)
 import Data.SCargot.Repr as R
 
 -- | A shorter infix alias for `SCons`
@@ -19,3 +23,39 @@ pattern A x = SAtom x
 
 -- | A (slightly) shorter alias for `SNil`
 pattern Nil = SNil
+
+
+type S t = R.SExpr t
+type Parse t a = R.SExpr t -> Either String a
+
+-- | Utility function for parsing a pair of things.
+fromPair :: Parse t a -> Parse t b -> Parse t (a, b)
+fromPair pl pr (l ::: r ::: Nil) = (,) <$> pl l <*> pr r
+fromPair _  _  sx = fail ("Expected two-element list")
+
+-- | Utility function for parsing a list of things.
+fromList :: Parse t a -> Parse t [a]
+fromList p (s ::: ss) = (:) <$> p s <*> fromList p ss
+fromList p Nil        = pure []
+fromList _ sx         = fail ("Expected list")
+
+gatherList :: S t -> Either String [S t]
+gatherList (x ::: xs) = (:) <$> pure x <*> gatherList xs
+gatherList Nil        = pure []
+gatherList sx         = fail ("Expected list")
+
+asPair :: ((S t, S t) -> Either String a) -> S t -> Either String a
+asPair f (l ::: r ::: SNil) = f (l, r)
+asPair _ sx = fail ("Expected two-element list")
+
+asList :: ([S t] -> Either String a) -> S t -> Either String a
+asList f ls = gatherList ls >>= f
+
+asSymbol :: (t -> Either String a) -> S t -> Either String a
+asSymbol f (A s) = f s
+asSymbol _ sx    = fail ("Expected symbol")
+
+asAssoc :: ([(S t, S t)] -> Either String a) -> S t -> Either String a
+asAssoc f ss = gatherList ss >>= mapM go >>= f
+  where go (a ::: b ::: Nil) = return (a, b)
+        go sx = fail ("Expected two-element list")

Data/SCargot/Repr/Rich.hs

@@ -11,8 +11,12 @@ module Data.SCargot.Repr.Rich
        , pattern L
        , pattern DL
        , pattern Nil
+         -- * Useful processing functions
+       , fromPair
+       , fromList
        ) where
 
+import Control.Applicative ((<$>), (<*>), pure)
 import Data.SCargot.Repr as R
 
 -- | A shorter infix alias to grab the head
@@ -30,3 +34,33 @@ pattern DL xs x = R.RSDotted xs x
 
 -- | A shorter alias for `RSList []`
 pattern Nil = R.RSList []
+
+type S t = R.RichSExpr t
+type Parse t a = S t -> Either String a
+
+-- | Utility function for parsing a pair of things.
+fromPair :: Parse t a -> Parse t b -> Parse t (a, b)
+fromPair pl pr = asPair $ \(l,r) -> (,) <$> pl l <*> pr r
+
+-- | Utility function for parsing a list of things.
+fromList :: Parse t a -> Parse t [a]
+fromList p = asList $ \ss -> mapM p ss
+
+asPair :: ((S t, S t) -> Either String a) -> S t -> Either String a
+asPair f (L [l, r]) = f (l, r)
+asPair _ sx         = fail ("Expected two-element list")
+
+asList :: ([S t] -> Either String a) -> S t -> Either String a
+asList f (L ls) = f ls
+asList _ sx     = fail ("Expected list")
+
+asSymbol :: (t -> Either String a) -> S t -> Either String a
+asSymbol f (A s) = f s
+asSymbol _ sx    = fail ("Expected symbol")
+
+asAssoc :: ([(S t, S t)] -> Either String a) -> S t -> Either String a
+asAssoc f (L ss) = gatherPairs ss >>= f
+  where gatherPairs (L [a, b] : ss) = (:) <$> pure (a, b) <*> gatherPairs ss
+        gatherPairs []              = pure []
+        gatherPairs _               = fail "..."
+asAssoc _ sx     = fail ("Expected assoc list")

Data/SCargot/Repr/WellFormed.hs

@@ -10,8 +10,12 @@ module Data.SCargot.Repr.WellFormed
        , pattern L
        , pattern A
        , pattern Nil
+         -- * Useful processing functions
+       , fromPair
+       , fromList
        ) where
 
+import Control.Applicative ((<$>), (<*>), pure)
 import Data.SCargot.Repr as R
 
 -- | A shorter infix alias to grab the head
@@ -26,3 +30,36 @@ pattern A a  = R.WFSAtom a
 
 -- | A shorter alias for `WFSList []`
 pattern Nil = R.WFSList []
+
+type S t = R.WellFormedSExpr t
+type Parse t a = R.WellFormedSExpr t -> Either String a
+
+-- | Utility function for parsing a pair of things.
+fromPair :: Parse t a -> Parse t b -> Parse t (a, b)
+fromPair pl pr (L [l, r]) = (,) <$> pl l <*> pr r
+fromPair _  _  sx = fail ("Expected two-element list")
+
+-- | Utility function for parsing a list of things.
+fromList :: Parse t a -> Parse t [a]
+fromList p (L ss) = mapM p ss
+fromList _ sx     = fail ("Expected list")
+
+
+asPair :: ((S t, S t) -> Either String a) -> S t -> Either String a
+asPair f (L [l, r]) = f (l, r)
+asPair _ sx         = fail ("Expected two-element list")
+
+asList :: ([S t] -> Either String a) -> S t -> Either String a
+asList f (L ls) = f ls
+asList _ sx     = fail ("Expected list")
+
+asSymbol :: (t -> Either String a) -> S t -> Either String a
+asSymbol f (A s) = f s
+asSymbol _ sx    = fail ("Expected symbol")
+
+asAssoc :: ([(S t, S t)] -> Either String a) -> S t -> Either String a
+asAssoc f (L ss) = gatherPairs ss >>= f
+  where gatherPairs (L [a, b] : ss) = (:) <$> pure (a, b) <*> gatherPairs ss
+        gatherPairs []              = pure []
+        gatherPairs _               = fail "..."
+asAssoc _ sx     = fail ("Expected assoc list")

Data/SCargot/Rivest.hs

@@ -7,7 +7,32 @@ import           Data.Text (Text)
 import qualified Data.Text as T
 
 pToken :: Parser ByteString
-pToken = undefined
+pToken = do
+  x <- char (isAlpha || isTokenPunct)
+  xs <- takeWhile1 (isAlpha || isDigit || isTokenPunct)
+
+isTokenPunct :: Char -> Bool
+isTokenPunct c = c `elem` "-./_:*+="
+
+pWithLength :: Parser ByteString
+pWithLength = do
+  n <- takeWhile1 isDigit
+  pFindType (Just (read (T.unpack n)))
+
+pFindType :: Maybe Int -> Parser ByteString
+pFindType len = do
+  c <- peekChar
+  case c of
+    ':' -> case len of
+             Just l  -> pVerbatim l
+             Nothing -> fail "Verbatim encoding without length given"
+    '"' -> pQuoted len
+    '#' -> pHex len
+    '{' -> pBase64Verbatim len
+    '|' -> pBase64 len
+    _   -> case len of
+             Just _  -> fail "Unexpected length field"
+             Nothing -> pToken
 
 pQuoted :: Maybe Int -> Parser ByteString
 pQuoted = do
@@ -17,12 +42,16 @@ pQuoted = do
   return ss
 
 pHex :: Parser ByteString
-pHex = undefined
+pHex = do
+
 
 pVerbatim :: Int -> Parser ByteString
 pVerbatim = do
   char ':'
   take n
 
-pBase64Verbatim :: Parser ByteString
-pBase64 :: Parser ByteString
+pBase64Verbatim :: Maybe Int -> Parser ByteString
+pBase64Verbatim = undefined
+
+pBase64 :: Maybe Int -> Parser ByteString
+pBase64 = undefined

s-cargot.cabal

@@ -18,6 +18,8 @@ library
                        Data.SCargot.Repr.Rich,
                        Data.SCargot.Repr.WellFormed,
                        Data.SCargot.General,
+                       Data.SCargot.Basic,
+                       Data.SCargot.Comments,
                        Data.SCargot.Tutorial
   -- other-modules:
   -- other-extensions: