tests again

gyehoek.cabal

@@ -96,11 +96,14 @@ test-suite test
     main-is:          Main.hs
     other-modules:
         Gyehoek.Test.Golden
+        Gyehoek.Test.Sexp
     build-depends:    base
                     , gyehoek
                     , filepath
                     , tasty
                     , tasty-silver
+                    , tasty-hunit
                     , directory
                     , process-extras
+                    , sexp-grammar
     default-language: GHC2024

src/Gyehoek/CPS/Lower.hs

@@ -291,51 +291,3 @@ lower e = fmap Wasm.renderModule . Wasm.execGenMod $ do
   
 lowerProgram :: Program -> Eff es Text
 lowerProgram (MkProgram e) = lower e
-
-antiquote_example =
-  let
-    metavar :: Integer
-    metavar = 123
-
-    e1 :: Wasm.Expr
-    e1 = [expr|
-      (func $blah (result i32)
-        (i32.const #{metavar}))
-    |]
-
-    e2 :: Wasm.Expr
-    e2 = [expr|
-      (func $blah (result i32)
-        (i32.const 123))
-    |]
-  in (metavar,e1,e2,e1==e2)
-
-antiquote_splicing_example =
-  let
-    metavars :: Wasm.Expr
-    metavars = [expr|i32 i64 f64|]
-
-    e1 :: Wasm.Expr
-    e1 = [expr|
-      (func $blah (param ##{metavars}))
-    |]
-
-    e2 :: Wasm.Expr
-    e2 = [expr|
-      (func $blah (param i32 i64 f64))
-    |]
-  in (metavars, e1, e2, e1 == e2)
-
-antiquote_both_example =
-  let
-    m1 = 123 :: Int
-    ms = [expr|i32 i64|]
-
-    e1 = [expr|
-      a (b #{m1} c) d ##{ms} e
-    |]
-
-    e2 = [expr|
-      a (b 123 c) d i32 i64 e
-    |]
-  in (e1,e2,e1==e2)

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

test/Gyehoek/Test/Sexp.hs

@@ -0,0 +1,50 @@
+module Gyehoek.Test.Sexp (root) where
+
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit
+import Language.Sexp.Located qualified as SL
+import Language.SexpGrammar ()
+import Gyehoek.Sexp (sx, equivalent)
+import Data.Function (on)
+
+
+root :: IO TestTree
+root = pure . testGroup "sexp" $
+  [ sxTree
+  ]
+
+newtype EquivSexp = MkEquiv SL.Sexp
+  deriving newtype (Show)
+
+instance Eq EquivSexp where
+  MkEquiv x == MkEquiv y = equivalent x y
+
+assertEquiv
+  :: HasCallStack
+  => String -> SL.Sexp -> SL.Sexp -> Assertion
+assertEquiv prefix = assertEqual prefix `on` MkEquiv
+
+equivto = assertEquiv ""
+
+sxTree :: TestTree
+sxTree = testGroup "sx"
+  [ testCase "quotation" do
+      equivto (SL.Symbol "abc") [sx|abc|]
+      equivto (SL.ParenList [SL.Symbol "a", SL.Symbol "b"]) [sx|(a b)|]
+  , testCase "antiquotation" do
+      equivto [sx|123|]
+        let meta = 123 :: Int
+        in [sx|#{meta}|]
+      equivto [sx|(blah (blah blah) blah)|]
+        let meta = [sx|blah|]
+        in [sx|(#{meta} (#{meta} #{meta}) #{meta})|]
+  , testCase "splicing" do
+      equivto [sx|(a b c d e f g)|]
+        let metas = SL.Symbol <$> ["c","d","e"]
+        in [sx|(a b ##{metas} f g)|]
+      equivto [sx|(a (b c d) e f g)|]
+        let
+          e1 = SL.Symbol "c"
+          e2 = SL.Symbol <$> ["e","f"]
+        in [sx|(a (b #{e1} d) ##{e2} g)|]
+  ]

test/Main.hs

@@ -4,6 +4,7 @@ import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.Silver.Interactive (defaultMain)
 import qualified Gyehoek.Test.Golden
 import Data.List (List)
+import qualified Gyehoek.Test.Sexp
 
 
 main :: IO ()
@@ -12,5 +13,6 @@ main = defaultMain =<< root
 root :: IO TestTree
 root = testGroup "test" <$> sequenceA
   [ Gyehoek.Test.Golden.root
+  , Gyehoek.Test.Sexp.root
   ]