From 1a93f168a9ca6be5b77ad5c813185eb3b364197f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Madeleine=20Sydney=20=C5=9Alaga?= Date: Fri, 11 Sep 2026 16:32:15 -0600 Subject: [PATCH] --- flake.nix | 2 +- gyehoek.cabal | 6 +- macroexpand.scm | 11 ++ src/Gyehoek/Scheme/Expand.hs | 233 +++++++++++++++++++++++++++++++ src/Gyehoek/Sexp/Grammar/Base.hs | 35 ++++- t.scm | 6 +- 6 files changed, 282 insertions(+), 11 deletions(-) create mode 100644 macroexpand.scm create mode 100644 src/Gyehoek/Scheme/Expand.hs diff --git a/flake.nix b/flake.nix index a56eecd..9878b84 100644 --- a/flake.nix +++ b/flake.nix @@ -55,7 +55,7 @@ nodejs wasm-tools wac-cli - guile + gauche rust-analyzer wasmtime # bashInteractive is necessary to work around an diff --git a/gyehoek.cabal b/gyehoek.cabal index 268c55d..4499135 100644 --- a/gyehoek.cabal +++ b/gyehoek.cabal @@ -69,6 +69,7 @@ library Gyehoek.Lift1 Gyehoek.Options Gyehoek.Prelude + Gyehoek.Scheme.Expand Gyehoek.Scheme.Syntax Gyehoek.Sexp Gyehoek.Sexp.Grammar @@ -110,13 +111,16 @@ library , recursion-schemes , scientific , string-interpolate + , tardis , template-haskell , text , text-short , typed-process , unordered-containers , vector - , tardis + , witherable + , semialign + , these hs-source-dirs: src default-language: GHC2024 diff --git a/macroexpand.scm b/macroexpand.scm new file mode 100644 index 0000000..afab6ba --- /dev/null +++ b/macroexpand.scm @@ -0,0 +1,11 @@ +(define-syntax if-not + (syntax-rules () + ((_ c t f) (if (not c) t f)) + ((_ c t) (if (not c) t)))) + +(write (macroexpand-1 '(if-not #t 123 456))) + +(define (main) + (let loop ((datum (read))) + (unless (eof-object? datum) + ()))) diff --git a/src/Gyehoek/Scheme/Expand.hs b/src/Gyehoek/Scheme/Expand.hs new file mode 100644 index 0000000..5f06f81 --- /dev/null +++ b/src/Gyehoek/Scheme/Expand.hs @@ -0,0 +1,233 @@ +{-# LANGUAGE ViewPatterns #-} +module Gyehoek.Scheme.Expand + ( + ) where + +import Gyehoek.Sexp.Syntax +import Gyehoek.Sexp qualified as S +import Gyehoek.Prelude +import Gyehoek.Scheme.Syntax (Name, Lit(..)) +import qualified Data.HashSet as HS +import qualified Data.HashMap.Strict as H +import Data.Foldable +import Data.These +import Data.Zip +import Prelude hiding (zip) +import qualified Data.List.NonEmpty as NE +import Data.Monoid (Ap(Ap, getAp)) +import Gyehoek.Sexp.Grammar.Base ((:-)(..)) +import Control.Lens.Extras (is) + + +data Scope = MkScope + { identity :: Natural + , bindings :: HashSet Name + } + deriving (Show, Generic) + +data Syntax + = SyntaxTrans Trans + | SyntaxPrim Prim + deriving (Show, Generic) + +data Prim + = PrimLambda + | PrimLet + | PrimIf + deriving (Show, Generic) + +data Trans = MkTrans + { ellipsis :: Name + , keywords :: List Name + , rules :: List Rule + } + deriving (Show, Generic) + +data Rule = MkRule Pat Tem + deriving (Show, Generic) + +data Pat + = PatWildcard + | PatVar Name + | PatList + { init :: List Pat + , ellipsis :: Maybe (List Pat) + , tail :: Maybe Pat + } + -- | PatVec + -- { init :: List Pat + -- , ellipsis :: Maybe (List Pat) + -- } + deriving (Show, Generic) + +data Tem + -- | @(⟨element⟩ …)@ + -- @(⟨element⟩ ⟨element⟩ … . ⟨element⟩)@ + = TemList + { init :: List El + , tail :: Maybe Tem + } + -- | @(⟨ellipsis⟩ ⟨template⟩)@ + | TemTrail Tem + | TemLit Lit + | TemVar Name + deriving (Show, Generic) + +data El + -- | @⟨template⟩ ⟨ellipsis⟩@ + = Ellipsis Tem + -- | @⟨template⟩@ + | El Tem + deriving (Show, Generic) + + + +instance S.DatumIso Trans where + datumIso = S.with \g -> + S.listWithIndentation + (NSpecial 1) + ( S.el (S.symBuiltin "syntax-rules") + >>> S.Iso (\(ctx:-t) -> ctx:-"...":-t) (\(ctx:-_:-t) -> ctx:-t) + >>> S.el (S.list $ S.rest (S.datumIso @Name)) + >>> S.rest (S.datumIso @Rule) + ) + >>> g + +instance S.DatumIso Rule where + datumIso = S.with \g -> + S.list (S.el S.datumIso >>> S.el S.datumIso) >>> g + +instance S.DatumIso Pat where + datumIso = S.match + $ S.With (S.sym "_" >>>) + $ S.With (S.datumIso >>>) + $ S.With (lst >>>) + $ S.End + where + lst :: S.G (Datum :- t) (Maybe Pat :- Maybe (List Pat) :- List Pat :- t) + lst = S.coproduct + [ S.list $ + ellipsis + >>> S.onTail (S.push Nothing (is _Nothing) (const mempty)) + , S.dottedList + ellipsis + ( S.datumIso @Pat + >>> S.partialIso Just (maybe (Left mempty) Right) ) + ] + ellipsis = + S.restData split + >>> S.onTail + ( S.onHead (S.traversed . S.traversed . S.sealed $ + S.datumIso @Pat) + >>> S.onTail (S.onHead . S.traversed . S.sealed $ + S.datumIso @Pat) + ) + split + :: forall t. S.G (List Datum :- t) + (Maybe (List Datum) :- List Datum :- t) + split = S.Iso + (\(ps0:-t) -> + let (ps,ell) = splitEllipsis ps0 + in ell :- ps :- t) + (\(ell:-ps:-t) -> (ps ++ foldMap ([Symbol "..."]++) ell) :- t) + +splitEllipsis :: List Datum -> (List Datum, Maybe (List Datum)) +splitEllipsis [] = ([], Nothing) +splitEllipsis (Symbol "..." : xs) = ([], Just xs) +splitEllipsis (x:xs) = splitEllipsis xs & _1 %~ (x:) + +instance S.DataIso El where + dataIso = S.match + $ S.With (ellipsis >>>) + $ S.With (noellipsis >>>) + $ S.End + where + ellipsis = S.recontextualise $ + S.el (S.datumIso @Tem) >>> S.el (S.sym "...") + noellipsis = S.recontextualise $ S.el (S.datumIso @Tem) + +instance S.DatumIso Tem where + datumIso = S.match + $ S.With (lst >>>) + $ S.With (trail >>>) + $ S.With (S.datumIso @Lit >>>) + $ S.With (S.datumIso @Name >>>) + $ S.End + where + trail = S.list $ S.el (S.sym "...") >>> S.el (S.datumIso @Tem) + + lst :: S.G (S.Datum :- t) (Maybe Tem :- List El :- t) + lst = S.coproduct + [ S.list els + >>> (S.push Nothing (is _Nothing) (const mempty)) + , S.dottedList els $ + S.datumIso @Tem + >>> S.partialIso Just (maybe (Left mempty) Right) + ] + els :: S.G (S.ListContext :- t) (S.ListContext :- List El :- t) + els = + S.iso + (\(S.MkListContext ds) -> affixEllipses ds) + (S.MkListContext . foldMap \(d,b) -> + d : if b then [Symbol "..."] else []) + >>> S.onHead (S.traversed . S.sealed $ + S.flipped S.pair + >>> S.onTail (S.datumIso @Tem) + >>> S.pair + >>> S.iso + (\(t,b) -> if b then Ellipsis t else El t) + (\case + Ellipsis t -> (t,True) + El t -> (t,False))) + >>> S.push (S.MkListContext []) + (\(S.MkListContext xs) -> null xs) + (const mempty) + affixEllipses :: List Datum -> List (Datum, Bool) + affixEllipses (x : Symbol "..." : xs) = (x,True) : affixEllipses xs + affixEllipses (x : xs) = (x,False) : affixEllipses xs + affixEllipses [] = [] + + + +-- | +-- >>> match (PatList [PatVar "x"] Nothing (Just (PatVar "y"))) [S.sx|(1 2 . 2)|] +-- Nothing +-- >>> match (PatList [PatVar "x"] Nothing (Just (PatVar "y"))) [S.sx|(1 . 2)|] +-- Just +-- ... +match :: Pat -> Datum -> Maybe (HashMap Name Datum) + +match PatWildcard _ = Just mempty + +match (PatVar x) e = Just $ H.singleton x e + +match (PatList ps Nothing Nothing) (List es) = matches ps es + +match (PatList ps Nothing (Just p)) (DotList es e) = + matches (p:|ps) (NE.cons e es) + +match _ _ = _ + +matches + :: (Semialign f, Foldable f) + => f Pat -> f Datum -> Maybe (HashMap Name Datum) +matches ps es = getAp . foldMap Ap $ alignWith f ps es + where + f (These a b) = match a b + f _ = Nothing + + + +trans_and :: Trans +trans_and = MkTrans + { ellipsis = "..." + , keywords = [] + , rules = + [ MkRule + (PatList + [PatVar "and"] + Nothing + Nothing) + (TemLit (LitBool True)) + ] + } diff --git a/src/Gyehoek/Sexp/Grammar/Base.hs b/src/Gyehoek/Sexp/Grammar/Base.hs index 82fb8f9..8a33b2b 100644 --- a/src/Gyehoek/Sexp/Grammar/Base.hs +++ b/src/Gyehoek/Sexp/Grammar/Base.hs @@ -44,7 +44,7 @@ module Gyehoek.Sexp.Grammar.Base , lambdaLike , lambdaKeyword , kappaKeyword - , beginLike, headTagged2', dottedList + , beginLike, headTagged2', dottedList, reifyContext, recontextualise, decontextualise ) where import Data.InvertibleGrammar @@ -52,7 +52,7 @@ import Data.InvertibleGrammar.Base import Data.InvertibleGrammar.Base as Re ( Grammar(..)) import Data.InvertibleGrammar.Combinators -import Gyehoek.Prelude hiding (traversed, iso, cons, coerced, Iso, Simple, simple) +import Gyehoek.Prelude hiding (flipped, traversed, iso, cons, coerced, Iso, Simple, simple) import Gyehoek.Sexp.Syntax hiding (position) import Gyehoek.Sexp.Print (printDatum') import Data.Scientific (Scientific) @@ -169,6 +169,33 @@ el -> G (ListContext :- t) (ListContext :- t') el g = coerced (Flip cons >>> onTail g >>> Step) +reifyContext :: G (ListContext :- t) (List Datum :- t) +reifyContext = iso coerce coerce + +decontextualise + :: G (List Datum :- t) (List Datum :- t') + -> G (ListContext :- t) t' +decontextualise g = reifyContext >>> g >>> end + where + end = Flip $ PartialIso + (\t -> [] :- t) + (\(lst :- t) -> + case lst of + [] -> Right t + d:_ -> Left $ unexpectedDatum d) + +recontextualise + :: G (ListContext :- t) (ListContext :- t') + -> G (List Datum :- t) t' +recontextualise g = flipped reifyContext >>> g >>> end + where + end = Flip $ PartialIso + (\t -> MkListContext [] :- t) + (\(MkListContext lst :- t) -> + case lst of + [] -> Right t + d:_ -> Left $ unexpectedDatum d) + -- | matches the remainder of a list as repetition of a given -- grammar. -- @@ -235,8 +262,8 @@ rest g = -- >>> encodeTest dataRestGrammar $ MkExample [1,2,3] "end" -- (1 2 3 end) restData - :: G (List Datum :- t) (a :- t) - -> G (ListContext :- t) (ListContext :- a :- t) + :: G (List Datum :- t) t' + -> G (ListContext :- t) (ListContext :- t') restData g = iso coerce coerce >>> g diff --git a/t.scm b/t.scm index ccd981e..8cd1be1 100644 --- a/t.scm +++ b/t.scm @@ -1,5 +1 @@ -((λ () - (* 2 (call/cc - (λ (k) - (begin (k 6) - 3)))))) +(define lambda 123)