top-level unquote-splice

src/Gyehoek/CPS/Lower.hs

@@ -70,23 +70,28 @@ data Runtime = MkRuntime
 
 -- | @makeSmallFixnum@ emits an expression injecting the i32 on top
 -- of the stack into the SCM unitype.
--- makeSmallFixnum :: Wasm.Expr
+makeSmallFixnum :: Wasm.Expr
--- makeSmallFixnum = mconcat
+makeSmallFixnum = [expr|
---   [ ins "i32.const" [sxp @Int 1]
+    (i32.const 1)
---   , ins "i32.shl" []
+    i32.shl
---   , ins "ref.i31" []
+    ref.i31
---   ]
+  |]
 
 -- | Given an expression @e@ leaving a @ref eq@ atop the stack,
 -- @pushArg rt n e@ sets the nth slot of the arg-passing array to the
 -- result of @e@.
--- pushArg :: Runtime -> Int -> Wasm.Expr -> Wasm.Expr
+pushArg :: Runtime -> Natural -> Wasm.Expr -> Wasm.Expr
--- pushArg (MkRuntime {argArrayType,argArray}) n e = mconcat
+pushArg (MkRuntime {argArrayType,argArray}) n e = [expr|
---   [ ins "global.get" [sxp argArray]
+    (global.get #{argArray})
---   , ins "i32.const" [sxp n]
+    (global.get #{n})
---   , e
+    ##{e}
---   , ins "array.set" [sxp argArrayType]
+    (array.set #{argArrayType})
---   ]
+  |]
+  -- [ ins "global.get" [sxp argArray]
+  -- , ins "i32.const" [sxp n]
+  -- , e
+  -- , ins "array.set" [sxp argArrayType]
+  -- ]
 
 -- | Pop the nth arg from the arg-passing array onto the stack.
 -- popArg :: Runtime -> Int -> Wasm.Expr
@@ -276,8 +281,8 @@ antiquote_example =
 
 antiquote_splicing_example =
   let
-    metavars :: List Sexp
+    metavars :: Wasm.Expr
-    metavars = [sxs'|i32 i64 f64|]
+    metavars = [expr|i32 i64 f64|]
 
     e1 :: Wasm.Expr
     e1 = [expr|

src/Gyehoek/Sexp.hs

@@ -27,6 +27,7 @@ module Gyehoek.Sexp
   , encodePretty
   , UglySexpIso(..)
   , AsSexpIso(..)
+  , SpliceSexp(..)
   , parseSexpsWithPos
   , parseSexpWithPos
   , parseSexp
@@ -37,10 +38,8 @@ module Gyehoek.Sexp
   , toSexp
   , fromSexp
   , stripLocation
-  , sx'
-  , sxs'
   )
-where
+  where
 
 import Data.Text (Text)
 import Language.SexpGrammar as Sexp hiding (toSexp, List, encode, decode, encodeWith, decodeWith, iso, encodePrettyWith, encodePretty, fromSexp)
@@ -67,14 +66,20 @@ import Data.Void (absurd, Void)
 import Data.Coerce (coerce)
 import qualified Data.Map
 import Language.Haskell.TH.Quote
-import Language.Haskell.TH (Quote, location, Loc (..), ExpQ, varE, mkName, listE, Exp, appE, conE)
+import Language.Haskell.TH (Quote, location, Loc (..), ExpQ, varE, mkName, listE, Exp, appE, conE, Q, Code, unTypeCode)
 import qualified Data.Text as T
 import qualified Control.Category
-import Data.Data (Data, Typeable, cast)
+import Data.Data (Data (..), Typeable, cast)
 import Language.Haskell.TH.Syntax (lift, Lift)
 import GHC.IsList (fromList)
 import Data.Functor.Foldable (cata)
 import Data.Functor.Classes (Show1(..))
+import Data.Vector (Vector)
+import Numeric.Natural (Natural)
+import Data.Maybe (fromMaybe)
+import Control.Applicative (Alternative((<|>)))
+import Debug.Pretty.Simple
+import qualified Data.Vector as V
 
 
 sexp :: SexpIso a => Iso' a Text
@@ -99,7 +104,7 @@ decodeWith g = Sexp.decodeWith g "FILE" . view lazy . encodeUtf8
 
 encodePrettyWith :: SexpGrammar a -> a -> Either String Text
 encodePrettyWith g =
-  (_Right %~ decodeUtf8 . view strict) . Sexp.encodePrettyWith g 
+  (_Right %~ decodeUtf8 . view strict) . Sexp.encodePrettyWith g
 
 parseSexps :: SexpIso a => FilePath -> Text -> Either String (List a)
 parseSexps f = marshal . SL.parseSexps f . view lazy . encodeUtf8
@@ -109,6 +114,12 @@ parseSexp :: SexpIso a => FilePath -> Text -> Either String a
 parseSexp f = marshal . SL.parseSexp f . view lazy . encodeUtf8
   where marshal = join . traverseOf _Right (Sexp.fromSexp sexpIso)
 
+readSexpWithPos :: Position -> Text -> Either String Sexp
+readSexpWithPos pos = SL.parseSexpWithPos pos . view lazy . encodeUtf8
+
+readSexpsWithPos :: Position -> Text -> Either String (List Sexp)
+readSexpsWithPos pos = SL.parseSexpsWithPos pos . view lazy . encodeUtf8
+
 parseSexpsWithPos :: SexpGrammar a -> Position -> Text -> Either String (List a)
 parseSexpsWithPos g pos =
   marshal . SL.parseSexpsWithPos pos . view lazy . encodeUtf8
@@ -242,6 +253,9 @@ getPos = do
 fromSexp :: SexpIso a => Sexp -> a
 fromSexp = either error id . Sexp.fromSexp sexpIso
 
+fromSexp' :: SexpGrammar a -> Sexp -> a
+fromSexp' g = either error id . Sexp.fromSexp g
+
 toSexp :: SexpIso a => a -> Sexp
 toSexp = either error id . Sexp.toSexp sexpIso
 
@@ -269,23 +283,66 @@ stripLocation = cata \case
   SL.Compose (a SL.:< e) ->
     SL.Fix . SL.Compose $ SL.dummyPos SL.:< e
 
-metaSexp :: Sexp.Sexp -> Maybe ExpQ
+instance SexpIso Natural where
-metaSexp (Unquote x) =
+  sexpIso = Sexp.integer >>> Sexp.partialOsi f g
-  Just [| stripLocation . toSexp $ $(varE (mkName (T.unpack x))) |]
+    where
-metaSexp (SL.ParenList xs)
+      f n | n < 0 = Left $ Sexp.unexpected "negative"
-  | (_:_) <- xs ^.. each . _UnquoteSplicing
+                        <> Sexp.expected "natural"
-  = Just [| stripLocation . toSexp $ SL.ParenList (mconcat $(listE spans)) |]
+          | otherwise = Right $ fromIntegral n
+      g n = fromIntegral n
+
+
+class SpliceSexp a where
+  spliceSexp :: a -> List Sexp
+
+instance SexpIso a => SpliceSexp (Vector a) where
+  spliceSexp = toSexps
+
+instance SexpIso a => SpliceSexp (List a) where
+  spliceSexp = toSexps
+
+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 _) _ -> False
+          (UnquoteSplicing _; Unquote _) _ -> False
-          _ (UnquoteSplicing _) -> False
+          _ (UnquoteSplicing _; Unquote _) -> False
-          _ _                   -> True
+          _ _                              -> True
       & fmap \case
+        [e@(Unquote _)] ->
+          case unquote e of
+            Just x -> [| [$(x)] |]
+            Nothing -> error "unreachable"
         [UnquoteSplicing x] ->
-          [| stripLocation <$> toSexps $(varE (mkName (T.unpack x))) |]
+          [| stripLocation <$> spliceSexp $(varE (mkName (T.unpack x))) |]
         x -> [| stripLocation <$> x |]
-metaSexp _ = Nothing
+      & listE
+unquoteSplicing _ = Nothing
+
+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
+  _ -> Nothing
+
+metaSexps :: List Sexp.Sexp -> Maybe ExpQ
+metaSexps = unquoteSplicing
+
+metaSexpsV :: Vector Sexp.Sexp -> Maybe ExpQ
+metaSexpsV = unquoteSplicing . V.toList
+
+metaSexp :: Sexp.Sexp -> Maybe ExpQ
+metaSexp x = unquote x
 
 -- 뻘짓뻘짓뻘짓뻘짓뻘짓
 class Lift1 f where
@@ -312,7 +369,7 @@ instance Lift1 SL.SexpF where
     SL.ParenListF es -> [|SL.ParenListF $(liftLift l es)|]
     SL.BracketListF es -> [|SL.BracketListF $(liftLift l es)|]
     SL.BraceListF es -> [|SL.BraceListF $(liftLift l es)|]
-    SL.ModifiedF p e -> [|SL.Modified $(lift p) $(l e)|]
+    SL.ModifiedF p e -> [|SL.ModifiedF $(lift p) $(l e)|]
 
 -- deriving instance Lift a => Lift (SL.SexpF a)
 deriving instance Lift SL.Atom
@@ -322,36 +379,37 @@ deriving instance Lift SL.Prefix
 extQ :: (Typeable a, Typeable b) => (a -> r) -> (b -> r) -> a -> r
 extQ f g a = maybe (f a) g (cast a)
 
-makeSxs
+makeSxs :: Data r => Code Q (List Sexp -> r) -> QuasiQuoter
-  :: Data b
+makeSxs f = QuasiQuoter
-  => (List a -> b) -> SexpGrammar a -> QuasiQuoter
-makeSxs f g = QuasiQuoter
   { quoteExp = \str -> do
       pos <- getPos
-      case parseSexpsWithPos g pos (T.pack str) of
+      case readSexpsWithPos pos (T.pack str) of
         Left e -> fail e
-        Right xs -> dataToExpQ (const Nothing `extQ` metaSexp) (f xs)
+        Right xs -> [| $(unTypeCode f) $e |]
+          where
+            e = dataToExpQ
+              (const Nothing `extQ` metaSexp `extQ` metaSexps)
+              xs
   , quotePat = undefined
   , quoteType = undefined
   , quoteDec = undefined
   }
 
-makeSx
+makeSx :: Data r => Code Q (Sexp -> r) -> QuasiQuoter
-  :: (Data a, Data r)
+makeSx f = QuasiQuoter
-  => (a -> r) -> SexpGrammar a -> QuasiQuoter
-makeSx f g = QuasiQuoter
   { quoteExp = \str -> do
       pos <- getPos
-      case parseSexpWithPos g pos (T.pack str) of
+      case readSexpWithPos pos (T.pack str) of
         Left e -> fail e
-        Right x -> dataToExpQ (const Nothing `extQ` metaSexp) (f x)
+        Right x -> [| $(unTypeCode f) $e |]
+          where
+            e = dataToExpQ
+              (const Nothing `extQ` metaSexp `extQ` metaSexps)
+              x
   , quotePat = undefined
   , quoteType = undefined
   , quoteDec = undefined
   }
 
-sxs = makeSxs id (sexpIso @Sexp)
+sxs = makeSxs [||id||]
-sx = makeSx id (sexpIso @Sexp)
+sx = makeSx [||id||]
-
-sxs' = makeSxs (fmap stripLocation) (sexpIso @Sexp)
-sx' = makeSx stripLocation (sexpIso @Sexp)

src/Gyehoek/Wasm.hs

@@ -10,6 +10,7 @@
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE ImpredicativeTypes #-}
 {-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE TemplateHaskellQuotes #-}
 module Gyehoek.Wasm
   (
     -- * syntax
@@ -20,8 +21,6 @@ module Gyehoek.Wasm
   , expr
   , Gyehoek.Sexp.sx
   , Gyehoek.Sexp.sxs
-  , Gyehoek.Sexp.sx'
-  , Gyehoek.Sexp.sxs'
   -- * GenMod effect
   , GenMod
   , runGenMod
@@ -176,10 +175,13 @@ instance SexpIso Idx where
 instance SexpIso Instr where
   sexpIso = with id
 
+instance Gyehoek.Sexp.SpliceSexp Expr where
+  spliceSexp = toListOf $ #inner . each . #inner
+
 
 -- quasiquoters
 
 expr :: QuasiQuoter
 expr = Gyehoek.Sexp.makeSxs
-  (MkExpr . V.fromList . (each . #inner %~ Gyehoek.Sexp.stripLocation))
+  [||MkExpr . V.fromList . (each . #inner %~ Gyehoek.Sexp.stripLocation)
-  (sexpIso @Instr)
+   . fmap (Gyehoek.Sexp.fromSexp @Instr) ||]