diff --git a/src/Core.hs b/src/Core.hs index ece6aff9..92683bd8 100644 --- a/src/Core.hs +++ b/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,7 +599,7 @@ 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) ++ ")" @@ -607,10 +607,10 @@ instance ShortShow a => ShortShow (ConstructorPatternF a) where "(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 diff --git a/src/Evaluator.hs b/src/Evaluator.hs index d5aa114c..97a3225e 100644 --- a/src/Evaluator.hs +++ b/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 diff --git a/src/Expander.hs b/src/Expander.hs index 3d5e28d3..2ae7ddf5 100644 --- a/src/Expander.hs +++ b/src/Expander.hs @@ -1254,7 +1254,7 @@ expandOneForm prob stx 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) diff --git a/src/Expander/Primitives.hs b/src/Expander/Primitives.hs index bf25b48f..14a31f74 100644 --- a/src/Expander/Primitives.hs +++ b/src/Expander/Primitives.hs @@ -546,9 +546,9 @@ typeConstructor ctor argKinds = (implT, implP) sch <- trivialScheme tType -- FIXME kind check here linkTypePattern dest - (TypePattern $ TyF ctor [ (varStx, var) - | (_, varStx, var) <- varInfo - ]) + (TypeCtorPattern $ TyF ctor [ (varStx, var) + | (_, varStx, var) <- varInfo + ]) [ (sc, n, x, sch) | (sc, n, x) <- varInfo ] @@ -679,7 +679,7 @@ elsePattern (TypePatternDest dest) stx = do ty <- trivialScheme tType (sc, x, v) <- prepareVar var linkTypePattern dest - (AnyType x v) + (TypePatternVar x v) [(sc, x, v, ty)] elsePattern other stx = do throwError $ diff --git a/src/Pretty.hs b/src/Pretty.hs index 238d37c5..2f0016e7 100644 --- a/src/Pretty.hs +++ b/src/Pretty.hs @@ -210,16 +210,16 @@ instance PrettyBinder VarInfo BinderPair where (annotate (BindingSite x) (text n), Env.singleton x ident ()) instance PrettyBinder VarInfo TypePattern where - ppBind env (TypePattern t) = + ppBind env (TypeCtorPattern t) = ppBind env (fmap BinderPair t) - ppBind env (AnyType ident x) = + ppBind env (TypePatternVar ident x) = ppBind env (BinderPair (ident, x)) instance PrettyBinder VarInfo ConstructorPattern where ppBind env pat = ppBind env (unConstructorPattern pat) instance PrettyBinder VarInfo a => PrettyBinder VarInfo (ConstructorPatternF a) where - ppBind env (CtorPattern ctor subPats) = + ppBind env (DataCtorPattern ctor subPats) = case subPats of [] -> (pp env ctor, Env.empty) _nonEmpty ->