execute macro actions in phase 1

src/Core.hs

@@ -73,12 +73,12 @@ instance Show MacroVar where
   show (MacroVar i) = "(MacroVar " ++ show (hashUnique i) ++ ")"
 
 data TypePattern
-  = TypePattern (TyF (Ident, Var))
-  | AnyType Ident Var
+  = TypeCtorPattern (TyF (Ident, Var))
+  | TypePatternVar Ident Var
   deriving (Data, Eq, Show)
 
 data ConstructorPatternF pat
-  = CtorPattern !Constructor [pat]
+  = DataCtorPattern !Constructor [pat]
   | PatternVar Ident Var
   deriving (Data, Eq, Foldable, Functor, Show, Traversable)
 makePrisms ''ConstructorPatternF
@@ -391,8 +391,8 @@ instance AlphaEq ConstructorPattern where
     alphaCheck (unConstructorPattern p1) (unConstructorPattern p2)
 
 instance AlphaEq a => AlphaEq (ConstructorPatternF a) where
-  alphaCheck (CtorPattern c1 vars1)
-             (CtorPattern c2 vars2) = do
+  alphaCheck (DataCtorPattern c1 vars1)
+             (DataCtorPattern c2 vars2) = do
     alphaCheck c1 c2
     for_ (zip vars1 vars2) (uncurry alphaCheck)
   alphaCheck (PatternVar _ x1)
@@ -401,11 +401,11 @@ instance AlphaEq a => AlphaEq (ConstructorPatternF a) where
   alphaCheck _ _ = notAlphaEquivalent
 
 instance AlphaEq TypePattern where
-  alphaCheck (TypePattern t1)
-             (TypePattern t2) =
+  alphaCheck (TypeCtorPattern t1)
+             (TypeCtorPattern t2) =
     alphaCheck t1 t2
-  alphaCheck (AnyType _ x1)
-             (AnyType _ x2) =
+  alphaCheck (TypePatternVar _ x1)
+             (TypePatternVar _ x2) =
     alphaCheck x1 x2
   alphaCheck _ _ = notAlphaEquivalent
 
@@ -599,18 +599,18 @@ instance ShortShow ConstructorPattern where
   shortShow = shortShow . unConstructorPattern
 
 instance ShortShow a => ShortShow (ConstructorPatternF a) where
-  shortShow (CtorPattern ctor vars) =
+  shortShow (DataCtorPattern ctor vars) =
     "(" ++ shortShow ctor ++
     " " ++ intercalate " " (map shortShow vars) ++
     ")"
   shortShow (PatternVar ident _var) =
     "(PatternVar " ++ shortShow ident ++ " )"
 
 instance ShortShow TypePattern where
-  shortShow (TypePattern t) =
+  shortShow (TypeCtorPattern t) =
     "(" ++ shortShow (fmap fst t) ++ ")"
-  shortShow (AnyType ident _var) =
-    "(AnyConstructor " ++ shortShow ident ++ " )"
+  shortShow (TypePatternVar ident _var) =
+    "(TypePatternVar " ++ shortShow ident ++ " )"
 
 
 instance ShortShow SyntaxPattern where

src/Evaluator.hs

@@ -284,7 +284,7 @@ doDataCase loc v0 ((pat, rhs) : ps) =
       [(ConstructorPatternF ConstructorPattern, Value)] {- ^ Subpatterns and their scrutinees -} ->
       Eval Value
     match _fk sk [] = sk
-    match fk sk ((CtorPattern ctor subPats, tgt) : more) =
+    match fk sk ((DataCtorPattern ctor subPats, tgt) : more) =
       case tgt of
         ValueCtor c args
           | c == ctor ->
@@ -300,7 +300,7 @@ doTypeCase blameLoc v0 [] = throwError (EvalErrorCase blameLoc (ValueType v0))
 doTypeCase blameLoc (Ty v0) ((p, rhs0) : ps) = match (doTypeCase blameLoc (Ty v0) ps) p rhs0 v0
   where
     match :: Eval Value -> TypePattern -> Core -> TyF Ty -> Eval Value
-    match next (TypePattern t) rhs scrut =
+    match next (TypeCtorPattern t) rhs scrut =
       case (t, scrut) of
         -- unification variables never match; instead, type-case remains stuck
         -- until the variable is unified with a concrete type constructor or a
@@ -315,7 +315,7 @@ doTypeCase blameLoc (Ty v0) ((p, rhs0) : ps) = match (doTypeCase blameLoc (Ty v0
                                 | arg <- args2]
                                 (eval rhs)
         (_, _) -> next
-    match _next (AnyType n x) rhs scrut =
+    match _next (TypePatternVar n x) rhs scrut =
       withExtendedEnv n x (ValueType (Ty scrut)) (eval rhs)
 
 doCase :: SrcLoc -> Value -> [(SyntaxPattern, Core)] -> Eval Value

src/Expander.hs

@@ -51,6 +51,7 @@
 import Data.Foldable
 import Data.Function (on)
 import Data.List (nub)
+import Data.List.NonEmpty (NonEmpty((:|)))
 import qualified Data.HashMap.Strict as HM
 import Data.Maybe
 import Data.Sequence (Seq(..))
@@ -387,9 +388,10 @@
   traverse_ (uncurry addDeclPrimitive) declPrims
   traverse_ (uncurry addTypePrimitive) typePrims
   traverse_ (uncurry addPatternPrimitive) patternPrims
+  traverse_ (uncurry addTypePatternPrimitive) typePatternPrims
+  traverse_ (uncurry addPolyProblemPrimitive) polyProblemPrims
   traverse_ addDatatypePrimitive datatypePrims
   traverse_ addFunPrimitive funPrims
-  addUniversalPrimitive "with-unknown-type" Prims.makeLocalType
 
 
   where
@@ -410,7 +412,7 @@
       [ ( "open-syntax"
         , Scheme [] $ tFun [tSyntax] (Prims.primitiveDatatype "Syntax-Contents" [tSyntax])
         , ValueClosure $ HO $
           \(ValueSyntax stx) ->
             case syntaxE stx of
               Id name ->
                 primitiveCtor "identifier-contents" [ValueString name]
@@ -428,9 +430,9 @@
         , Scheme [] $
           tFun [tSyntax, tSyntax, Prims.primitiveDatatype "Syntax-Contents" [tSyntax]] tSyntax
         , ValueClosure $ HO $
           \(ValueSyntax locStx) ->
             ValueClosure $ HO $
             \(ValueSyntax scopesStx) ->
               ValueClosure $ HO $
               -- N.B. Assuming correct constructors
               \(ValueCtor ctor [arg]) ->
@@ -615,10 +617,10 @@
         )
       ]
 
-    modPrims :: [(Text, DeclTreePtr -> Syntax -> Expand ())]
+    modPrims :: [(Text, Prims.ModulePrim)]
     modPrims = [("#%module", Prims.makeModule expandDeclForms)]
 
-    declPrims :: [(Text, DeclTreePtr -> DeclOutputScopesPtr -> Syntax -> Expand ())]
+    declPrims :: [(Text, Prims.DeclPrim)]
     declPrims =
       [ ("define", Prims.define)
       , ("datatype", Prims.datatype)
@@ -631,7 +633,7 @@
       , ("group", Prims.group expandDeclForms)
       ]
 
-    exprPrims :: [(Text, Ty -> SplitCorePtr -> Syntax -> Expand ())]
+    exprPrims :: [(Text, Prims.ExprPrim)]
     exprPrims =
       [ ("error", Prims.err)
       , ("the", Prims.the)
@@ -663,8 +665,17 @@
       , ("type-case", Prims.typeCase)
       ]
 
-    patternPrims :: [(Text, Either (Ty, PatternPtr) TypePatternPtr -> Syntax -> Expand ())]
-    patternPrims = [("else", Prims.elsePattern)]
+    patternPrims :: [(Text, Prims.PatternPrim)]
+    patternPrims = []
+
+    typePatternPrims :: [(Text, Prims.TypePatternPrim)]
+    typePatternPrims = []
+
+    polyProblemPrims :: [(Text, Prims.PolyProblemPrim)]
+    polyProblemPrims =
+      [ ("else", Prims.elsePattern)
+      , ("with-unknown-type", Prims.makeLocalType)
+      ]
 
     addToKernel name p b =
       modifyState $ over expanderKernelExports $ addExport p name b
@@ -722,13 +733,21 @@
 
 
     addPatternPrimitive ::
-      Text -> (Either (Ty, PatternPtr) TypePatternPtr -> Syntax -> Expand ()) -> Expand ()
+      Text -> (Ty -> PatternPtr -> Syntax -> Expand ()) -> Expand ()
     addPatternPrimitive name impl = do
       let val = EPrimPatternMacro impl
       b <- freshBinding
       bind b val
       addToKernel name runtime b
 
+    addTypePatternPrimitive ::
+      Text -> (TypePatternPtr -> Syntax -> Expand ()) -> Expand ()
+    addTypePatternPrimitive name impl = do
+      let val = EPrimTypePatternMacro impl
+      b <- freshBinding
+      bind b val
+      addToKernel name runtime b
+
     addModulePrimitive :: Text -> (DeclTreePtr -> Syntax -> Expand ()) -> Expand ()
     addModulePrimitive name impl = do
       let val = EPrimModuleMacro impl
@@ -761,9 +780,9 @@
       bind b val
       addToKernel name runtime b
 
-    addUniversalPrimitive :: Text -> (MacroDest -> Syntax -> Expand ()) -> Expand ()
-    addUniversalPrimitive name impl = do
-      let val = EPrimUniversalMacro impl
+    addPolyProblemPrimitive :: Text -> (MacroDest -> Syntax -> Expand ()) -> Expand ()
+    addPolyProblemPrimitive name impl = do
+      let val = EPrimPolyProblemMacro impl
       b <- freshBinding
       bind b val
       addToKernel name runtime b
@@ -915,6 +934,7 @@
             Ty (TyF (TMetaVar ptr) _) | ptr == ptr' -> stillStuck tid task
             _ -> forkAwaitingTypeCase loc dest (tMetaVar ptr') env cases kont
         other -> do
+          -- TODO: should this expandEval be 'inEarlierPhase'?
           selectedBranch <- expandEval $ withEnv env $ doTypeCase loc (Ty other) cases
           case selectedBranch of
             ValueMacroAction nextStep -> do
@@ -974,7 +994,7 @@
         Just newScopeSet ->
           expandDeclForms dest (earlierScopeSet <> newScopeSet) outScopesDest (addScopes newScopeSet stx)
     InterpretMacroAction dest act outerKont ->
-      interpretMacroAction dest act >>= \case
+      inEarlierPhase (interpretMacroAction dest act) >>= \case
         StuckOnType loc ty env cases innerKont ->
           forkAwaitingTypeCase loc dest ty env cases (innerKont ++ outerKont)
         Done value -> do
@@ -985,11 +1005,11 @@
           forkExpandSyntax dest syntax
         other -> expandEval $ evalErrorType "syntax" other
     ContinueMacroAction dest value (closure:kont) -> do
-      result <- expandEval $ apply closure value
+      result <- inEarlierPhase $ expandEval $ apply closure value
       case result of
         ValueMacroAction macroAction -> do
           forkInterpretMacroAction dest macroAction kont
-        other -> expandEval $ evalErrorType "macro action" other
+        other -> inEarlierPhase $ expandEval $ evalErrorType "macro action" other
     EvalDefnAction x n p expr ->
       linkedCore expr >>=
       \case
@@ -1159,40 +1179,37 @@
     stringLiteral = Syntax (Stx scs loc (Id "#%string-literal"))
     s' = Syntax (Stx scs loc (String s))
 
-problemCategory :: MacroDest -> SyntacticCategory
-problemCategory (ModuleDest {}) = ModuleCat
-problemCategory (DeclTreeDest {}) = DeclarationCat
-problemCategory (TypeDest {}) = TypeCat
-problemCategory (ExprDest {}) = ExpressionCat
-problemCategory (PatternDest {}) = PatternCaseCat
-problemCategory (TypePatternDest {}) = TypePatternCaseCat
-
 requireDeclarationCat :: Syntax -> MacroDest -> Expand (DeclTreePtr, DeclOutputScopesPtr)
 requireDeclarationCat _ (DeclTreeDest dest outScopesDest) = return (dest, outScopesDest)
 requireDeclarationCat stx other =
   throwError $
-  WrongSyntacticCategory stx (tenon DeclarationCat) (mortise $ problemCategory other)
+  WrongSyntacticCategory stx (tenon DeclarationCat :| []) (mortise $ problemCategory other)
 
 requireTypeCat :: Syntax -> MacroDest -> Expand (Kind, SplitTypePtr)
 requireTypeCat _ (TypeDest kind dest) = return (kind, dest)
 requireTypeCat stx other =
   throwError $
-  WrongSyntacticCategory stx (tenon TypeCat) (mortise $ problemCategory other)
+  WrongSyntacticCategory stx (tenon TypeCat :| []) (mortise $ problemCategory other)
 
 requireExpressionCat :: Syntax -> MacroDest -> Expand (Ty, SplitCorePtr)
 requireExpressionCat _ (ExprDest ty dest) = return (ty, dest)
 requireExpressionCat stx other =
   throwError $
-  WrongSyntacticCategory stx (tenon ExpressionCat) (mortise $ problemCategory other)
+  WrongSyntacticCategory stx (tenon ExpressionCat :| []) (mortise $ problemCategory other)
 
-requirePatternCat :: Syntax -> MacroDest -> Expand (Either (Ty, PatternPtr) TypePatternPtr)
+requirePatternCat :: Syntax -> MacroDest -> Expand (Ty, PatternPtr)
 requirePatternCat _ (PatternDest scrutTy dest) =
-  return $ Left (scrutTy, dest)
-requirePatternCat _ (TypePatternDest dest) =
-  return $ Right dest
+  return (scrutTy, dest)
 requirePatternCat stx other =
   throwError $
-  WrongSyntacticCategory stx (tenon PatternCaseCat) (mortise $ problemCategory other)
+  WrongSyntacticCategory stx (tenon PatternCat :| []) (mortise $ problemCategory other)
+
+requireTypePatternCat :: Syntax -> MacroDest -> Expand TypePatternPtr
+requireTypePatternCat _ (TypePatternDest dest) =
+  return dest
+requireTypePatternCat stx other =
+  throwError $
+  WrongSyntacticCategory stx (tenon TypePatternCat :| []) (mortise $ problemCategory other)
 
 
 expandOneForm :: MacroDest -> Syntax -> Expand ()
@@ -1238,17 +1255,17 @@
                     pure ptr
                   modifyState $ set (expanderPatternBinders . at dest) $ Just $ Left subPtrs
                   linkPattern dest $
-                    CtorPattern ctor subPtrs
+                    DataCtorPattern ctor subPtrs
             other ->
               throwError $
-              WrongSyntacticCategory stx (tenon ExpressionCat) (mortise $ problemCategory other)
+              WrongSyntacticCategory stx (tenon ExpressionCat :| []) (mortise $ problemCategory other)
         EPrimModuleMacro impl ->
           case prob of
             ModuleDest dest -> do
               impl dest stx
             other ->
               throwError $
-              WrongSyntacticCategory stx (tenon ModuleCat) (mortise $ problemCategory other)
+              WrongSyntacticCategory stx (tenon ModuleCat :| []) (mortise $ problemCategory other)
         EPrimDeclMacro impl -> do
           (dest, outScopesDest) <- requireDeclarationCat stx prob
           impl dest outScopesDest stx
@@ -1260,11 +1277,14 @@
               implP dest stx
             otherDest ->
               throwError $
-              WrongSyntacticCategory stx (tenon TypeCat) (mortise $ problemCategory otherDest)
+              WrongSyntacticCategory stx (tenon TypeCat :| []) (mortise $ problemCategory otherDest)
         EPrimPatternMacro impl -> do
-          dest <- requirePatternCat stx prob
+          (scrutTy, dest) <- requirePatternCat stx prob
+          impl scrutTy dest stx
+        EPrimTypePatternMacro impl -> do
+          dest <- requireTypePatternCat stx prob
           impl dest stx
-        EPrimUniversalMacro impl ->
+        EPrimPolyProblemMacro impl ->
           impl prob stx
         EVarMacro var -> do
           (t, dest) <- requireExpressionCat stx prob
@@ -1306,7 +1326,7 @@
                           ValueSyntax $ addScope p stepScope stx
               case macroVal of
                 ValueMacroAction act -> do
-                  res <- interpretMacroAction prob act
+                  res <- inEarlierPhase $ interpretMacroAction prob act
                   case res of
                     StuckOnType loc ty env cases kont ->
                       forkAwaitingTypeCase loc prob ty env cases kont
@@ -1432,8 +1452,8 @@
         getIdent (ValueSyntax stx) = mustBeIdent stx
         getIdent _other = throwError $ InternalError $ "Not a syntax object in " ++ opName
         compareFree id1 id2 = do
-          b1 <- resolve id1
-          b2 <- resolve id2
+          b1 <- inLaterPhase $ resolve id1
+          b2 <- inLaterPhase $ resolve id2
           return $ Done $
             flip primitiveCtor [] $
             if b1 == b2 then "true" else "false"