From bf5595f1854cf4eeabfa7a8d4b1d284139b53cf7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Madeleine=20Sydney=20=C5=9Alaga?= Date: Sat, 22 Aug 2026 21:55:16 -0600 Subject: [PATCH] qq --- gyehoek.cabal | 3 + src/Gyehoek/Lift1.hs | 30 ++++++++ src/Gyehoek/Prelude.hs | 2 +- src/Gyehoek/Sexp/Grammar.hs | 8 ++- src/Gyehoek/Sexp/Print.hs | 1 + src/Gyehoek/Sexp/QQ.hs | 128 +++++++++++++++++++++++++++++++++++ src/Gyehoek/Sexp/Read.hs | 56 +++++++++++++-- src/Gyehoek/Sexp/Syntax.hs | 57 ++++++++++++++-- test/Gyehoek/Test/Sexp/QQ.hs | 47 +++++++++++++ 9 files changed, 318 insertions(+), 14 deletions(-) create mode 100644 src/Gyehoek/Lift1.hs create mode 100644 src/Gyehoek/Sexp/QQ.hs create mode 100644 test/Gyehoek/Test/Sexp/QQ.hs diff --git a/gyehoek.cabal b/gyehoek.cabal index ddab5d9..ccb2fa4 100644 --- a/gyehoek.cabal +++ b/gyehoek.cabal @@ -62,6 +62,7 @@ library Gyehoek.GenSym Gyehoek.Jalmot Gyehoek.Language + Gyehoek.Lift1 Gyehoek.Options Gyehoek.Prelude Gyehoek.Scheme.Syntax @@ -69,6 +70,7 @@ library Gyehoek.Sexp.Grammar Gyehoek.Sexp.Grammar.Base Gyehoek.Sexp.Print + Gyehoek.Sexp.QQ Gyehoek.Sexp.Read Gyehoek.Sexp.Syntax Gyehoek.Stack.Syntax @@ -131,6 +133,7 @@ test-suite test Gyehoek.Test.Scheme.Syntax Gyehoek.Test.Sexp Gyehoek.Test.Sexp.Print + Gyehoek.Test.Sexp.QQ Gyehoek.Test.Sexp.Read Gyehoek.Test.Stack.VM Gyehoek.TestUtil diff --git a/src/Gyehoek/Lift1.hs b/src/Gyehoek/Lift1.hs new file mode 100644 index 0000000..8b42a72 --- /dev/null +++ b/src/Gyehoek/Lift1.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE TemplateHaskell #-} +module Gyehoek.Lift1 + ( Lift1(..) + , lift1 + ) where + +import Gyehoek.Prelude hiding ((:<)) +import Language.Haskell.TH (Quote, Exp, listE) +import Language.Haskell.TH.Syntax (Lift (..)) +import Control.Comonad.Cofree (Cofree(..)) + + +-- 뻘짓뻘짓뻘짓뻘짓뻘짓 +class Lift1 f where + liftLift :: Quote m => (a -> m Exp) -> f a -> m Exp + +lift1 :: (Lift1 f, Lift a, Quote m) => f a -> m Exp +lift1 = liftLift lift + + +--- instances + +instance Lift1 f => Lift1 (Cofree f) where + liftLift l (a :< e) = [|(:<) $(l a) $(liftLift (liftLift l) e)|] + +instance Lift1 List where + liftLift l xs = listE $ l <$> xs + +instance Lift1 NonEmpty where + liftLift l (x :| xs) = [|(:|) $(l x) $(liftLift l xs)|] diff --git a/src/Gyehoek/Prelude.hs b/src/Gyehoek/Prelude.hs index 5327396..9355d2f 100644 --- a/src/Gyehoek/Prelude.hs +++ b/src/Gyehoek/Prelude.hs @@ -21,7 +21,7 @@ module Gyehoek.Prelude , (<=<) ) where -import Control.Lens hiding (List) +import Control.Lens hiding (List, (:<)) import Data.List (List) import Data.Text (Text) import Effectful diff --git a/src/Gyehoek/Sexp/Grammar.hs b/src/Gyehoek/Sexp/Grammar.hs index b321b5b..a75e1c8 100644 --- a/src/Gyehoek/Sexp/Grammar.hs +++ b/src/Gyehoek/Sexp/Grammar.hs @@ -22,7 +22,7 @@ module Gyehoek.Sexp.Grammar where import Gyehoek.Sexp.Grammar.Base -import Gyehoek.Prelude +import Gyehoek.Prelude hiding (traversed, iso) import Data.InvertibleGrammar (backward, sealed, forward, runGrammar) import Gyehoek.Sexp.Print (printDatum, printDatum', printData) import Gyehoek.Jalmot @@ -31,6 +31,7 @@ import qualified Gyehoek.Sexp.Read as Read import qualified Data.Text.IO as TIO import Text.Pretty.Simple (pPrintNoColor) import Data.InvertibleGrammar.Generic +import qualified Control.Category toDatum :: Jalmot :> es => DatumGrammar a -> a -> Eff es Datum @@ -95,3 +96,8 @@ instance DatumIso a => DatumIso (List a) where instance DatumIso Bool where datumIso = boolean instance DatumIso Int where datumIso = int + +instance DatumIso Datum where datumIso = Control.Category.id + +instance DatumIso a => DataIso (List a) where + dataIso = onHead . traversed . sealed $ datumIso @a diff --git a/src/Gyehoek/Sexp/Print.hs b/src/Gyehoek/Sexp/Print.hs index aba1df2..467e40c 100644 --- a/src/Gyehoek/Sexp/Print.hs +++ b/src/Gyehoek/Sexp/Print.hs @@ -65,6 +65,7 @@ prettyDatum depth datum = case datum of Ordinary; NSpecial _ -> pparen depth $ group . align . vsep $ prettyDatum (depth+1) <$> xs + _ -> error [i|unimplemented: #{datum}|] pparen depth = enclose (delim depth "(") (delim depth ")") delim depth = annotate (SynParen depth) diff --git a/src/Gyehoek/Sexp/QQ.hs b/src/Gyehoek/Sexp/QQ.hs new file mode 100644 index 0000000..12834cd --- /dev/null +++ b/src/Gyehoek/Sexp/QQ.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE TemplateHaskell #-} +module Gyehoek.Sexp.QQ + ( makeSxs + , makeSx + , makeSx' + , sx + , sxs + ) where + +import Data.Data (Typeable, cast) +import Gyehoek.Prelude +import Gyehoek.Sexp.Syntax +import Language.Haskell.TH +import qualified Data.Text as T +import Data.List (groupBy) +import Language.Haskell.TH.Syntax (liftData, Lift (lift)) +import Gyehoek.Jalmot +import Gyehoek.Sexp.Grammar +import Control.Exception (throw) +import Language.Haskell.TH.Quote (QuasiQuoter(..)) +import Language.Haskell.TH.Syntax (dataToExpQ) +import qualified Gyehoek.Sexp.Read as Read +import Text.Megaparsec.Pos (mkPos) +import Gyehoek.Lift1 +import Data.Foldable (toList) + + +extQ :: (Typeable a, Typeable b) => (a -> r) -> (b -> r) -> a -> r +extQ f g a = maybe (f a) g (cast a) + +spliceMeta :: (HasCallStack, DataIso a) => a -> List Datum +spliceMeta x = + case runPureEff . runJalmot . toData dataIso $ x of + Left (cs,e) -> throw $ MkAJalmotCS cs e + Right xs -> xs + +meta :: (HasCallStack, DatumIso a) => a -> Datum +meta x = + case runPureEff . runJalmot . toDatum datumIso $ x of + Left (cs,e) -> throw $ MkAJalmotCS cs e + Right xs -> xs + +unquoteSplicingRecursive :: List Datum -> ExpQ +unquoteSplicingRecursive xs = [| mconcat $(spans) |] + where + spans = xs + & groupBy \cases + (MetaSplice _) _ -> False + _ (MetaSplice _) -> False + _ _ -> True + & fmap \case + [MetaSplice x] -> + [| spliceMeta $(varE (mkName (T.unpack x))) |] + es -> listE $ unquoteRecursive <$> es + & listE + +unquoteRecursive :: Datum -> ExpQ +unquoteRecursive = \case + Meta x -> [| meta $(varE (mkName (T.unpack x))) |] + a :< CompoundF x -> [| $(liftData a) :< CompoundF $c|] + where + c = case x of + ListF ind xs -> + [| ListF $(lift ind) $(unquoteSplicingRecursive xs) |] + VectorF xs -> + [| VectorF $(unquoteSplicingRecursive xs) |] + DotListF xs t -> + [| DotListF $(liftLift unquoteRecursive xs) $(unquoteRecursive t) |] + AbbrevF p t -> + [| AbbrevF $(lift p) $(unquoteRecursive t) |] + e -> liftData e + + + +getPos :: Q SourcePos +getPos = do + Loc {loc_filename,loc_start} <- location + pure $ SourcePos + { sourceName = loc_filename + , sourceLine = mkPos $ fst loc_start + , sourceColumn = mkPos $ snd loc_start + } + +readq + :: (SourcePos -> Text -> Eff '[Jalmot, IOE] a) + -> String -> Q a +readq f s = do + pos <- getPos + liftIO . runJalmotIO . f pos . T.pack $ s + +makeSxs :: Data r => Code Q (List Datum -> r) -> QuasiQuoter +makeSxs f = QuasiQuoter + { quoteExp = \str -> do + xs <- readq Read.readStringWithPos str + let e = dataToExpQ + (const Nothing + `extQ` (Just . unquoteRecursive) + `extQ` (Just . unquoteSplicingRecursive)) + xs + [| $(unTypeCode f) $e |] + , quotePat = undefined + , quoteType = undefined + , quoteDec = undefined + } + +-- | An untyped variant of 'makeSx', useful when the user function is +-- polymorphic in its return value. +makeSx' :: ExpQ -> QuasiQuoter +makeSx' f = QuasiQuoter + { quoteExp = \str -> do + x <- readq Read.readStringWithPos1 str + let e = dataToExpQ + (const Nothing + `extQ` (Just . unquoteRecursive) + `extQ` (Just . unquoteSplicingRecursive)) + x + [| $f $e |] + , quotePat = undefined + , quoteType = undefined + , quoteDec = undefined + } + +makeSx :: Data r => Code Q (Datum -> r) -> QuasiQuoter +makeSx = makeSx' . unTypeCode + +sx, sxs :: QuasiQuoter +sxs = makeSxs [|| id @(List Datum) ||] +sx = makeSx [|| id @Datum ||] diff --git a/src/Gyehoek/Sexp/Read.hs b/src/Gyehoek/Sexp/Read.hs index 7dc7a69..1d6ffb0 100644 --- a/src/Gyehoek/Sexp/Read.hs +++ b/src/Gyehoek/Sexp/Read.hs @@ -2,6 +2,9 @@ module Gyehoek.Sexp.Read ( readFile , readString , readString1 + , SourcePos(..) + , readStringWithPos + , readStringWithPos1 ) where import Text.Megaparsec @@ -34,10 +37,48 @@ readString s = readString1 :: Jalmot :> es => Text -> Eff es Datum readString1 s = - case runParser (sc *> datum <* eof) "" s of + case runParser file1 "" s of Right x -> pure x Left eb -> throwError . ReaderError $ eb +initialStateFromSourcePos :: SourcePos -> s -> State s e +initialStateFromSourcePos pos s = State + { stateInput = s + , stateOffset = 0 + , stateParseErrors = [] + , statePosState = PosState + { pstateInput = s + , pstateOffset = 0 + , pstateSourcePos = pos + , pstateTabWidth = defaultTabWidth + , pstateLinePrefix = "" + } + } + +readStringWithPos1 + :: Jalmot :> es + => SourcePos + -> Text + -> Eff es Datum +readStringWithPos1 pos s = + case snd $ runParser' file1 st of + Right x -> pure x + Left eb -> throwError . ReaderError $ eb + where + st = initialStateFromSourcePos pos s + +readStringWithPos + :: Jalmot :> es + => SourcePos + -> Text + -> Eff es (List Datum) +readStringWithPos pos s = + case snd $ runParser' file st of + Right x -> pure x + Left eb -> throwError . ReaderError $ eb + where + st = initialStateFromSourcePos pos s + type P = Parsec Void Text @@ -134,16 +175,19 @@ string = label "string" . lexeme $ metaSplice :: P Text metaSplice = label "splicing meta" . lexeme . between "##{" "}" $ - takeWhileP Nothing (/= '}') + takeWhile1P Nothing (/= '}') meta :: P Text meta = label "meta" . lexeme . between "#{" "}" $ - takeWhileP Nothing (/= '}') + takeWhile1P Nothing (/= '}') file :: P (List Datum) -file = many datum <* eof +file = sc *> many datum <* eof + +file1 :: P Datum +file1 = sc *> datum <* eof datum :: P Datum datum = do @@ -153,6 +197,8 @@ datum = do , Simple <$> simpleDatum -- , labeled -- , labelRef + , MetaSplice <$> metaSplice + , Meta <$> meta ] simpleDatum :: P Simple @@ -163,8 +209,6 @@ simpleDatum = choice , SimpleString <$> string , SimpleSymbol <$> symbol -- , SimpleBytevector <$> bytevector - , SimpleMetaSplice <$> metaSplice - , SimpleMeta <$> meta ] compoundDatum :: P Compound diff --git a/src/Gyehoek/Sexp/Syntax.hs b/src/Gyehoek/Sexp/Syntax.hs index 63aac31..31517e6 100644 --- a/src/Gyehoek/Sexp/Syntax.hs +++ b/src/Gyehoek/Sexp/Syntax.hs @@ -19,6 +19,8 @@ module Gyehoek.Sexp.Syntax , pattern Compound , pattern Labeled , pattern LabelRef + , pattern Meta + , pattern MetaSplice , pattern Abbrev , pattern Vector , pattern DotList @@ -38,19 +40,26 @@ module Gyehoek.Sexp.Syntax , ann , pattern List' , position + , stripAnn ) where -import Language.Haskell.TH.Syntax (Lift) +import Language.Haskell.TH.Syntax (Lift (lift), liftData) import Data.Scientific (Scientific) import Data.ByteString (ByteString) import Gyehoek.Prelude hiding ((:<), Simple) import Text.Megaparsec.Pos (SourcePos(..), sourcePosPretty) -import Control.Comonad.Cofree (Cofree((:<)), _extract) +import Control.Comonad.Cofree (Cofree((:<)), _extract, _unwrap) import Data.Fix (Fix (..)) import Data.Functor.Foldable import Text.Show.Deriving (deriveShow1) +import Data.Eq.Deriving (deriveEq1) import qualified Control.Comonad.Trans.Cofree as F import Prettyprinter (Pretty (pretty), viaShow) +import Gyehoek.Lift1 (Lift1 (liftLift)) +import Data.Data (Typeable, cast) +import Language.Haskell.TH +import qualified Data.Text as T +import Control.Comonad.Trans.Cofree (tailF) data DatumF a @@ -58,6 +67,8 @@ data DatumF a | CompoundF (CompoundF a) | LabeledF Label a | LabelRefF Label + | MetaF Text + | MetaSpliceF Text deriving stock (Show, Eq, Data, Generic, Lift, Functor, Foldable, Traversable) deriving anyclass (NFData) @@ -68,8 +79,6 @@ data Simple | SimpleString Text | SimpleSymbol Text | SimpleBytevector ByteString - | SimpleMeta Text - | SimpleMetaSplice Text deriving stock (Show, Eq, Data, Generic, Lift) deriving anyclass (NFData) @@ -135,10 +144,13 @@ noAnn = MkAnn instance Pretty Ann where pretty = pretty . maybe "" sourcePosPretty . view #position - - deriveShow1 ''CompoundF +deriveEq1 ''CompoundF deriveShow1 ''DatumF +deriveEq1 ''DatumF + + +--- modification and extraction of annotations ann :: Lens' Datum Ann ann = _extract @@ -161,6 +173,12 @@ adorn = set syntax indentWith :: Indentation -> Datum -> Datum indentWith = set indentation +stripAnn :: Datum -> Fix DatumF +stripAnn = hoist tailF + + +--- pattern synonyms + pattern Simple :: Simple -> Datum pattern Simple a <- _ :< SimpleF a where Simple a = noAnn :< SimpleF a @@ -177,6 +195,14 @@ pattern LabelRef :: Label -> Datum pattern LabelRef l <- _ :< LabelRefF l where LabelRef l = noAnn :< LabelRefF l +pattern MetaSplice :: Text -> Datum +pattern MetaSplice x <- _ :< MetaSpliceF x + where MetaSplice x = noAnn :< MetaSpliceF x + +pattern Meta :: Text -> Datum +pattern Meta x <- _ :< MetaF x + where Meta x = noAnn :< MetaF x + pattern List :: List Datum -> Datum pattern List a <- _ :< CompoundF (ListF _ a) where List a = noAnn :< CompoundF (ListF Ordinary a) @@ -203,3 +229,22 @@ pattern Character a = Simple (SimpleCharacter a) pattern String a = Simple (SimpleString a) pattern Symbol a = Simple (SimpleSymbol a) pattern Bytevector a = Simple (SimpleBytevector a) + + +--- Lift1 instances + +instance Lift1 DatumF where + liftLift l = \case + SimpleF s -> [|SimpleF $(lift s)|] + CompoundF c -> [|CompoundF $(liftLift l c)|] + LabeledF lbl x -> [|LabeledF $(lift lbl) $(l x)|] + LabelRefF lbl -> [|LabelRefF $(lift lbl)|] + MetaF x -> [|MetaF $(lift x)|] + MetaSpliceF x -> [|MetaSpliceF $(lift x)|] + +instance Lift1 CompoundF where + liftLift l = \case + ListF ind xs -> [|ListF $(lift ind) $(liftLift l xs)|] + DotListF xs t -> [|DotListF $(liftLift l xs) $(l t)|] + VectorF xs -> [|VectorF $(liftLift l xs)|] + AbbrevF p x -> [|AbbrevF $(lift p) $(l x)|] diff --git a/test/Gyehoek/Test/Sexp/QQ.hs b/test/Gyehoek/Test/Sexp/QQ.hs new file mode 100644 index 0000000..d1acea1 --- /dev/null +++ b/test/Gyehoek/Test/Sexp/QQ.hs @@ -0,0 +1,47 @@ +module Gyehoek.Test.Sexp.QQ where + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit +import Gyehoek.Sexp.QQ (sx) +import Data.Function (on) +import Gyehoek.Sexp.Syntax +import Data.Coerce (coerce) + + +newtype EquivDatum = MkEquiv Datum + deriving newtype (Show) + +instance Eq EquivDatum where + (==) = (==) `on` (stripAnn . coerce) + +assertEquiv + :: HasCallStack + => String -> Datum -> Datum -> Assertion +assertEquiv prefix = assertEqual prefix `on` MkEquiv + +equivto :: HasCallStack => Datum -> Datum -> Assertion +equivto = assertEquiv "" + +test_qq :: TestTree +test_qq = testGroup "sexp quasiquoter" + [ testCase "quotation" do + equivto (Symbol "abc") [sx|abc|] + equivto (List [Symbol "a", 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 simple" do + equivto [sx|(a b c d e f g)|] + let metas = Symbol <$> ["c","d","e"] + in [sx|(a b ##{metas} f g)|] + , testCase "splicing multiple" do + equivto [sx|(a (b c d) e f g)|] + let + e1 = Symbol "c" + e2 = Symbol <$> ["e","f"] + in [sx|(a (b #{e1} d) ##{e2} g)|] + ]