Added richer bidirectional pattern synonyms and changed the semantics of ::: to be more consistent

Data/SCargot/Repr/Basic.hs

@@ -1,11 +1,17 @@
 {-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ViewPatterns #-}
 
 module Data.SCargot.Repr.Basic
        ( -- * Basic 'SExpr' representation
          R.SExpr(..)
+         -- * Constructing and Deconstructing
+       , cons
+       , uncons
          -- * Shorthand Patterns
        , pattern (:::)
        , pattern A
+       , pattern L
+       , pattern DL
        , pattern Nil
          -- * Lenses
        , _car
@@ -48,17 +54,73 @@ _cdr f (x ::: xs) = (:::) <$> pure x <*> f xs
 _cdr _ (A a)      = pure (A a)
 _cdr _ Nil        = pure Nil
 
+-- | Produce the head and tail of the s-expression (if possible).
+--
+-- >>> uncons (A "el" ::: A "eph" ::: A "ant" ::: Nil)
+-- Just (A "el",SCons (SAtom "eph") (SCons (SAtom "ant") SNil))
+uncons :: SExpr a -> Maybe (SExpr a, SExpr a)
+uncons (SCons x xs) = Just (x, xs)
+uncons _            = Nothing
+
+-- | Combine the two s-expressions into a new one.
+--
+-- >>> cons (A "el") (L ["eph", A "ant"])
+-- SCons (SAtom "el) (SCons (SAtom "eph") (SCons (SAtom "ant") SNil))
+cons :: SExpr a -> SExpr a -> SExpr a
+cons = SCons
+
+mkList :: [SExpr a] -> SExpr a
+mkList []     = SNil
+mkList (x:xs) = SCons x (mkList xs)
+
+mkDList :: [SExpr a] -> a -> SExpr a
+mkDList []     a = SAtom a
+mkDList (x:xs) a = SCons x (mkDList xs a)
+
+gatherDList :: SExpr a -> Maybe ([SExpr a], a)
+gatherDList SNil     = Nothing
+gatherDList SAtom {} = Nothing
+gatherDList sx       = go sx
+  where go SNil = Nothing
+        go (SAtom a) = return ([], a)
+        go (SCons x xs) = do
+          (ys, a) <- go xs
+          return (x:ys, a)
+
 infixr 5 :::
 
 -- | A shorter infix alias for `SCons`
+--
+-- >>> A "pachy" ::: A "derm"
+-- SCons (SAtom "pachy") (SAtom "derm")
 pattern x ::: xs = SCons x xs
 
 -- | A shorter alias for `SAtom`
+--
+-- >>> A "elephant"
+-- SAtom "elephant"
 pattern A x = SAtom x
 
 -- | A (slightly) shorter alias for `SNil`
+--
+-- >>> Nil
+-- SNil
 pattern Nil = SNil
 
+-- | An alias for matching a proper list.
+--
+-- >>> L [A "pachy", A "derm"]
+-- SCons (SAtom "pachy") (SCons (SAtom "derm") SNil)
+pattern L xs <- (gatherList -> Right xs)
+  where L xs = mkList xs
+
+-- | An alias for matching a dotted list.
+--
+-- >>> DL [A "pachy"] A "derm"
+-- SCons (SAtom "pachy") (SAtom "derm")
+pattern DL xs x <- (gatherDList -> Just (xs, x))
+  where DL xs x = mkDList xs x
+
 getShape :: SExpr a -> String
 getShape Nil = "empty list"
 getShape sx = go 0 sx

Data/SCargot/Repr/Rich.hs

@@ -1,10 +1,14 @@
 {-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ViewPatterns #-}
 
 module Data.SCargot.Repr.Rich
        ( -- * 'RichSExpr' representation
          R.RichSExpr(..)
        , R.toRich
        , R.fromRich
+         -- * Constructing and Deconstructing
+       , cons
+       , uncons
          -- * Useful pattern synonyms
        , pattern (:::)
        , pattern A
@@ -71,20 +75,54 @@ _cdr f (DL (x:xs) a) =
 _cdr _ (A a)      = pure (A a)
 _cdr _ Nil        = pure Nil
 
+-- | Produce the head and tail of the s-expression (if possible).
+--
+-- >>> uncons (L [A "el", A "eph", A "ant"])
+-- Just (A "el",L [A "eph",A "ant"])
+uncons :: RichSExpr a -> Maybe (RichSExpr a, RichSExpr a)
+uncons R.RSAtom {}           = Nothing
+uncons (R.RSList (x:xs))     = Just (x, R.RSList xs)
+uncons (R.RSDotted (x:xs) a) = Just (x, R.RSDotted xs a)
+
+-- | Combine the two s-expressions into a new one.
+--
+-- >>> cons (A "el") (L [A "eph", A "ant"])
+-- L [A "el",A "eph",A "ant"]
+cons :: RichSExpr a -> RichSExpr a -> RichSExpr a
+cons x (R.RSList xs)     = R.RSList (x:xs)
+cons x (R.RSDotted xs a) = R.RSDotted (x:xs) a
+cons x (R.RSAtom a)      = R.RSDotted [x] a
+
 -- | A shorter infix alias to grab the head
 --   and tail of an `RSList`.
-pattern x ::: xs = R.RSList (x : xs)
+--
+-- >>> A "one" ::: L [A "two", A "three"]
+-- RSList [RSAtom "one",RSAtom "two",RSAtom "three"]
+pattern x ::: xs <- (uncons -> Just (x, xs))
+  where x ::: xs = cons x xs
 
 -- | A shorter alias for `RSAtom`
+--
+-- >>> A "elephant"
+-- RSAtom "elephant"
 pattern A a       = R.RSAtom a
 
 -- | A shorter alias for `RSList`
+--
+-- >>> L [A "pachy", A "derm"]
+-- RSList [RSAtom "pachy",RSAtom "derm"]
 pattern L xs      = R.RSList xs
 
 -- | A shorter alias for `RSDotted`
+--
+-- >>> DL [A "pachy"] "derm"
+-- RSDotted [RSAtom "pachy"] "derm"
 pattern DL xs x = R.RSDotted xs x
 
 -- | A shorter alias for `RSList` @[]@
+--
+-- >>> Nil
+-- RSList []
 pattern Nil = R.RSList []
 
 -- | Utility function for parsing a pair of things: this parses a two-element list,

Data/SCargot/Repr/WellFormed.hs

@@ -1,10 +1,14 @@
 {-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ViewPatterns #-}
 
 module Data.SCargot.Repr.WellFormed
        ( -- * 'WellFormedSExpr' representation
          R.WellFormedSExpr(..)
        , R.toWellFormed
        , R.fromWellFormed
+         -- * Constructing and Deconstructing
+       , cons
+       , uncons
          -- * Useful pattern synonyms
        , pattern (:::)
        , pattern L
@@ -26,17 +30,38 @@ module Data.SCargot.Repr.WellFormed
 import Control.Applicative ((<$>), (<*>), pure)
 import Data.SCargot.Repr as R
 
-pattern x ::: xs = R.WFSList (x : xs)
+uncons :: WellFormedSExpr a -> Maybe (WellFormedSExpr a, WellFormedSExpr a)
+uncons R.WFSAtom {}       = Nothing
+uncons (R.WFSList (x:xs)) = Just (x, R.WFSList xs)
+
+cons :: WellFormedSExpr a -> WellFormedSExpr a -> Maybe (WellFormedSExpr a)
+cons _ (R.WFSAtom {}) = Nothing
+cons x (R.WFSList xs) = Just (R.WFSList (x:xs))
+
+-- | A shorter infix alias to grab the head and tail of a `WFSList`. This
+--   pattern is unidirectional, because it cannot be guaranteed that it
+--   is used to construct well-formed s-expressions; use the function "cons"
+--   instead.
+--
+-- >>> let sum (x ::: xs) = x + sum xs; sum Nil = 0
+pattern x ::: xs <- (uncons -> Just (x, xs))
 
 -- | A shorter alias for `WFSList`
+--
+-- >>> L [A "pachy", A "derm"]
+-- WFSList [WFSAtom "pachy",WFSAtom "derm"]
 pattern L xs = R.WFSList xs
 
 -- | A shorter alias for `WFSAtom`
+--
+-- >>> A "elephant"
+-- WFSAtom "elephant"
 pattern A a  = R.WFSAtom a
 
 -- | A shorter alias for `WFSList` @[]@
+--
+-- >>> Nil
+-- WFSList []
 pattern Nil = R.WFSList []
 
 getShape :: WellFormedSExpr a -> String