diff --git a/src/Gyehoek/CPS/Lower.hs b/src/Gyehoek/CPS/Lower.hs index 4f63e5a..11ba71e 100644 --- a/src/Gyehoek/CPS/Lower.hs +++ b/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 = mconcat --- [ ins "i32.const" [sxp @Int 1] --- , ins "i32.shl" [] --- , ins "ref.i31" [] --- ] +makeSmallFixnum :: Wasm.Expr +makeSmallFixnum = [expr| + (i32.const 1) + i32.shl + 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 (MkRuntime {argArrayType,argArray}) n e = mconcat --- [ ins "global.get" [sxp argArray] --- , ins "i32.const" [sxp n] --- , e --- , ins "array.set" [sxp argArrayType] --- ] +pushArg :: Runtime -> Natural -> Wasm.Expr -> Wasm.Expr +pushArg (MkRuntime {argArrayType,argArray}) n e = [expr| + (global.get #{argArray}) + (global.get #{n}) + ##{e} + (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 = [sxs'|i32 i64 f64|] + metavars :: Wasm.Expr + metavars = [expr|i32 i64 f64|] e1 :: Wasm.Expr e1 = [expr| diff --git a/src/Gyehoek/Sexp.hs b/src/Gyehoek/Sexp.hs index ba85dee..cc1f13c 100644 --- a/src/Gyehoek/Sexp.hs +++ b/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 -metaSexp (Unquote x) = - Just [| stripLocation . toSexp $ $(varE (mkName (T.unpack x))) |] -metaSexp (SL.ParenList xs) - | (_:_) <- xs ^.. each . _UnquoteSplicing - = Just [| stripLocation . toSexp $ SL.ParenList (mconcat $(listE spans)) |] +instance SexpIso Natural where + sexpIso = Sexp.integer >>> Sexp.partialOsi f g + where + f n | n < 0 = Left $ Sexp.unexpected "negative" + <> Sexp.expected "natural" + | 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 _) -> False - _ _ -> True + (UnquoteSplicing _; Unquote _) _ -> False + _ (UnquoteSplicing _; Unquote _) -> False + _ _ -> 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 - :: Data b - => (List a -> b) -> SexpGrammar a -> QuasiQuoter -makeSxs f g = QuasiQuoter +makeSxs :: Data r => Code Q (List Sexp -> r) -> QuasiQuoter +makeSxs f = 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 - :: (Data a, Data r) - => (a -> r) -> SexpGrammar a -> QuasiQuoter -makeSx f g = QuasiQuoter +makeSx :: Data r => Code Q (Sexp -> r) -> QuasiQuoter +makeSx f = 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) -sx = makeSx id (sexpIso @Sexp) - -sxs' = makeSxs (fmap stripLocation) (sexpIso @Sexp) -sx' = makeSx stripLocation (sexpIso @Sexp) +sxs = makeSxs [||id||] +sx = makeSx [||id||] diff --git a/src/Gyehoek/Wasm.hs b/src/Gyehoek/Wasm.hs index 6bf6400..6c57aa0 100644 --- a/src/Gyehoek/Wasm.hs +++ b/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)) - (sexpIso @Instr) + [||MkExpr . V.fromList . (each . #inner %~ Gyehoek.Sexp.stripLocation) + . fmap (Gyehoek.Sexp.fromSexp @Instr) ||]