tests again

src/Gyehoek/Sexp.hs

@@ -39,6 +39,7 @@ module Gyehoek.Sexp
   , fromSexp
   , stripLocation
   , format
+  , equivalent
   )
   where
 
@@ -82,6 +83,7 @@ import Control.Applicative (Alternative((<|>)))
 import Debug.Pretty.Simple
 import qualified Data.Vector as V
 import qualified Data.Vector.Strict
+import Data.Function (on)
 
 
 sexp :: SexpIso a => Iso' a Text
@@ -288,6 +290,11 @@ stripLocation = cata \case
   SL.Compose (a SL.:< e) ->
     SL.Fix . SL.Compose $ SL.dummyPos SL.:< e
 
+-- | @('==')@ for 'Sexp's modulo source location — return true if the
+-- two sexps are equal in all but 'Position' fields.
+equivalent :: Sexp -> Sexp -> Bool
+equivalent = (==) `on` stripLocation
+
 instance SexpIso Natural where
   sexpIso = Sexp.integer >>> Sexp.partialOsi f g
     where
@@ -311,27 +318,6 @@ instance SexpIso a => SpliceSexp (List a) where
 instance SpliceSexp Sexp where
   spliceSexp = toListOf each
 
-unquoteSplicing :: List Sexp.Sexp -> Maybe ExpQ
-unquoteSplicing xs
-  | (_:_) <- xs ^.. folded . _UnquoteSplicing
-  = Just [| mconcat $(spans) |]
-  where
-    spans = xs
-      & groupBy \cases
-          (UnquoteSplicing _; Unquote _) _ -> False
-          _ (UnquoteSplicing _; Unquote _) -> False
-          _ _                              -> True
-      & fmap \case
-        [e@(Unquote _)] ->
-          case unquote e of
-            Just x -> [| [$(x)] |]
-            Nothing -> error "unreachable"
-        [UnquoteSplicing x] ->
-          [| stripLocation <$> spliceSexp $(varE (mkName (T.unpack x))) |]
-        x -> [| stripLocation <$> x |]
-      & listE
-unquoteSplicing _ = Nothing
-
 unquoteSplicingRecursive :: List Sexp.Sexp -> ExpQ
 unquoteSplicingRecursive xs = [| mconcat $(spans) |]
   where
@@ -352,15 +338,10 @@ unquoteSplicingRecursive xs = [| mconcat $(spans) |]
 
 unquoteRecursive :: Sexp.Sexp -> ExpQ
 unquoteRecursive = \case
-  Unquote x -> [| stripLocation (toSexp $(varE (mkName (T.unpack x)))) |]
+  Unquote x -> [| toSexp $(varE (mkName (T.unpack x))) |]
   SL.ParenList xs -> [|SL.ParenList $(unquoteSplicingRecursive xs)|]
   e -> liftData e
 
-unquote :: Sexp.Sexp -> Maybe ExpQ
-unquote (Unquote x) =
-  Just [| stripLocation . toSexp $ $(varE (mkName (T.unpack x))) |]
-unquote _ = Nothing
-
 _ParenList :: Prism' Sexp (List Sexp)
 _ParenList = prism' SL.ParenList \case
   SL.ParenList xs -> Just xs