From 33fb0f831c41b6886768fa679173b7ad7f441c28 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Madeleine=20Sydney=20=C5=9Alaga?= Date: Sat, 18 Jul 2026 18:23:10 -0600 Subject: [PATCH] tests again --- gyehoek.cabal | 3 +++ src/Gyehoek/CPS/Lower.hs | 48 ------------------------------------- src/Gyehoek/Sexp.hs | 35 +++++++-------------------- test/Gyehoek/Test/Sexp.hs | 50 +++++++++++++++++++++++++++++++++++++++ test/Main.hs | 2 ++ 5 files changed, 63 insertions(+), 75 deletions(-) create mode 100644 test/Gyehoek/Test/Sexp.hs diff --git a/gyehoek.cabal b/gyehoek.cabal index 12a41fb..1b222f7 100644 --- a/gyehoek.cabal +++ b/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 diff --git a/src/Gyehoek/CPS/Lower.hs b/src/Gyehoek/CPS/Lower.hs index 683c95f..76a85ce 100644 --- a/src/Gyehoek/CPS/Lower.hs +++ b/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) diff --git a/src/Gyehoek/Sexp.hs b/src/Gyehoek/Sexp.hs index a458aeb..6ffc0df 100644 --- a/src/Gyehoek/Sexp.hs +++ b/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 diff --git a/test/Gyehoek/Test/Sexp.hs b/test/Gyehoek/Test/Sexp.hs new file mode 100644 index 0000000..b91b639 --- /dev/null +++ b/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)|] + ] diff --git a/test/Main.hs b/test/Main.hs index 44bb284..9bd6592 100644 --- a/test/Main.hs +++ b/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 ]