diff --git a/src/Gyehoek/Scheme/Expand.hs b/src/Gyehoek/Scheme/Expand.hs index 0f1acfe..b8104d1 100644 --- a/src/Gyehoek/Scheme/Expand.hs +++ b/src/Gyehoek/Scheme/Expand.hs @@ -60,7 +60,7 @@ data PrimLet e = MkPrimLet (Maybe Name) (List (Name, e)) (List e) deriving (Show, Generic, Functor, Foldable, Traversable) data PrimIf e = MkPrimIf e e (Maybe e) deriving (Show, Generic, Functor, Foldable, Traversable) -data PrimLetSyntax e = MkPrimLetSyntax (List (Name, Trans)) (List e) +data PrimLetSyntax e = MkPrimLetSyntax (List (Name, e)) (List e) deriving (Show, Generic, Functor, Foldable, Traversable) data Prim e @@ -68,166 +68,15 @@ data Prim e | PrimLet (PrimLet e) | PrimIf (PrimIf e) | PrimLetSyntax (PrimLetSyntax e) + | PrimSyntaxRules Trans deriving (Show, Generic) -data Trans = MkTrans - { ellipsis :: Name - , keywords :: List Name - , rules :: List Rule - } - deriving (Show, Generic) - -data Rule = MkRule - { rhs :: Pat - , lhs :: Tem - } - deriving (Show, Generic, Data) - -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) - -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) - -data El - -- | @⟨template⟩ ⟨ellipsis⟩@ - = Ellipsis Tem - -- | @⟨template⟩@ - | El Tem - deriving (Show, Generic, Data) - data Key = MkKey Name (HashSet Scope) deriving stock (Show, Generic, Eq) deriving anyclass (Hashable) -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 [] = [] - instance S.DatumIso Scope where datumIso = S.with (S.datumIso >>>) @@ -307,7 +156,7 @@ prim_let_syntax :: S.DatumIso e => S.DatumGrammar (PrimLetSyntax e) prim_let_syntax = S.with \g -> (S.listWithIndentation (NSpecial 1) $ S.el (anykw "let-syntax") - >>> S.el (S.list $ S.rest $ S.datumIso @(Name,Trans)) + >>> S.el (S.list $ S.rest $ S.datumIso) >>> S.rest S.datumIso) >>> g @@ -436,6 +285,8 @@ data Denot = DenotVar | DenotMacro Trans | DenotPrim Name + | DenotSyntax Datum + | DenotKeyword Name deriving stock (Show, Generic) newtype Env = MkEnv { names :: HashMap Bind Denot } @@ -574,7 +425,7 @@ expand g scopes datum = case datum of expandMacro :: (Expand es, Jalmot :> es) => Env -> ScopeSet -> Trans -> Datum -> Eff es CommandOrDef -expandMacro = _ +expandMacro g scopes trans datum = _ expandPrim :: (Expand es, Jalmot :> es) @@ -582,6 +433,17 @@ expandPrim expandPrim g scopes primName datum | Just prim <- parsePrim @Datum primName datum = case prim of + PrimLetSyntax (MkPrimLetSyntax bs [body]) -> do + scopes' <- flip HS.insert scopes <$> gensym + (rhss,g') <- (_2 %~ (g<>) . fold) . Prelude.unzip <$> for bs \(x,trans) -> + expandAsExp g scopes trans >>= \case + ExpSyntaxRules trans' -> + (trans',) <$> bindLexical scopes' x (DenotMacro trans') + e -> err [i|syntax-rules를 원하는데 이것 받는다: #{e}|] + Command <$> (ExpLetSyntax + (zip (bs ^.. each . _1) rhss) + <$> expandAsExp g' scopes' body + ) PrimLet (MkPrimLet Nothing bs [body]) -> do scopes' <- flip HS.insert scopes <$> gensym g' <- (g<>) . fold <$> for (bs ^.. each . _1) \x -> diff --git a/src/Gyehoek/Scheme/Syntax.hs b/src/Gyehoek/Scheme/Syntax.hs index de8a243..854ce97 100644 --- a/src/Gyehoek/Scheme/Syntax.hs +++ b/src/Gyehoek/Scheme/Syntax.hs @@ -20,6 +20,11 @@ module Gyehoek.Scheme.Syntax , ExpF(..) , Program(..) , CommandOrDef(..) + , Trans(..) + , Rule(..) + , Pat(..) + , Tem(..) + , El(..) , primDatumIso , free , subst @@ -115,6 +120,7 @@ data Def data Exp = ExpLet (List (Name, Exp)) Exp + | ExpLetSyntax (List (Name, Trans)) Exp | ExpLetRec (List (Name, Exp)) Exp | ExpPrim (Prim Exp) | ExpBegin (NonEmpty Exp) @@ -122,10 +128,63 @@ data Exp | ExpLit Lit | ExpLambda (List Name) Exp | ExpVar Name + | ExpSyntaxRules Trans | ExpApply Exp (List Exp) deriving stock (Show, Generic, Data) deriving anyclass (NFData) +data Trans = MkTrans + { ellipsis :: Name + , keywords :: List Name + , rules :: List Rule + } + deriving stock (Show, Generic, Data) + deriving anyclass (NFData) + +data Rule = MkRule + { rhs :: Pat + , lhs :: Tem + } + deriving (Show, Generic, Data) + deriving anyclass (NFData) + +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) + deriving anyclass (NFData) + +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) + deriving anyclass (NFData) + +data El + -- | @⟨template⟩ ⟨ellipsis⟩@ + = Ellipsis Tem + -- | @⟨template⟩@ + | El Tem + deriving (Show, Generic, Data) + deriving anyclass (NFData) + data CommandOrDef = Command Exp | Definition Def @@ -248,20 +307,42 @@ instance DatumIso Def where >>> S.el args >>> S.rest S.datumIso args = S.list $ S.el S.datumIso >>> S.rest S.datumIso +instance DatumIso Trans where + datumIso = S.with \g -> + S.listWithIndentation + (S.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 DatumIso Exp where datumIso = S.match $ S.With (. S.letLike "let" S.datumIso S.datumIso S.datumIso) + $ S.With (letsyntax >>>) $ S.With (. S.letLike "letrec" S.datumIso S.datumIso S.datumIso) $ S.With (. S.datumIso) $ S.With (. begin) - $ S.With (. S.ifLike "if" S.datumIso S.datumIso S.datumIso) + $ S.With (. if_) $ S.With (. S.datumIso) $ S.With (. lam) $ S.With (. S.datumIso) + $ S.With (. S.datumIso) $ S.With (\app -> app . S.list (S.el S.datumIso >>> S.rest S.datumIso)) $ S.End where + letsyntax = S.listWithIndentation (S.NSpecial 1) $ + S.el (S.symBuiltin "let-syntax") + >>> S.el (S.list $ S.rest $ S.datumIso) + >>> S.el S.datumIso lam = S.lambdaLike S.lambdaKeyword S.datumIso (S.el S.datumIso) + if_ = S.ifLike "if" S.datumIso S.datumIso $ S.datumIso @Exp >>> S.iso + Just + \case + Just x -> x + Nothing -> error "안 괜찮다ㅠㅠ" begin :: forall t. G (S.Datum :- t) (NonEmpty Exp :- t) begin = S.beginLike "begin" $ S.el (S.datumIso @Exp) >>> S.rest (S.datumIso @Exp) @@ -269,6 +350,101 @@ instance DatumIso Exp where (\(xs:-x:-t) -> (x:|xs):-t) (\((x:|xs):-t) -> xs:-x:-t)) +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 (S.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 S.Datum :- t) + (Maybe (List S.Datum) :- List S.Datum :- t) + split = S.Iso + (\(ps0:-t) -> + let (ps,ell) = splitEllipsis ps0 + in ell :- ps :- t) + (\(ell:-ps:-t) -> (ps ++ foldMap ([S.Symbol "..."]++) ell) :- t) + +splitEllipsis :: List S.Datum -> (List S.Datum, Maybe (List S.Datum)) +splitEllipsis [] = ([], Nothing) +splitEllipsis (S.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 [S.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 S.Datum -> List (S.Datum, Bool) + affixEllipses (x : S.Symbol "..." : xs) = (x,True) : affixEllipses xs + affixEllipses (x : xs) = (x,False) : affixEllipses xs + affixEllipses [] = [] + + instance DatumIso CommandOrDef where datumIso = S.match $ S.With (\_Command -> _Command . S.datumIso)