From b2a5c061def4958f0166da1c2294bae8788bf5e5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20G=C3=A9lineau?= Date: Wed, 8 May 2024 09:01:38 -0400 Subject: [PATCH 01/15] execute macro actions in phase 1 --- src/Expander.hs | 6 +++--- src/Expander/Monad.hs | 5 +++++ src/Phase.hs | 5 ++++- 3 files changed, 12 insertions(+), 4 deletions(-) diff --git a/src/Expander.hs b/src/Expander.hs index ff581681..a20b07d0 100644 --- a/src/Expander.hs +++ b/src/Expander.hs @@ -1306,7 +1306,7 @@ expandOneForm prob stx 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 +1432,8 @@ interpretMacroAction prob = 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" diff --git a/src/Expander/Monad.hs b/src/Expander/Monad.hs index 7a8c34c4..330d8b53 100644 --- a/src/Expander/Monad.hs +++ b/src/Expander/Monad.hs @@ -45,6 +45,7 @@ module Expander.Monad , getDecl , getState , inEarlierPhase + , inLaterPhase , inPhase , isExprChecked , importing @@ -407,6 +408,10 @@ inEarlierPhase :: Expand a -> Expand a inEarlierPhase act = Expand $ local (over (expanderLocal . expanderPhase) prior) $ runExpand act +inLaterPhase :: Expand a -> Expand a +inLaterPhase act = + Expand $ local (over (expanderLocal . expanderPhase) posterior) $ runExpand act + moduleScope :: ModuleName -> Expand Scope moduleScope mn = moduleScope' mn diff --git a/src/Phase.hs b/src/Phase.hs index b622e0a7..c6f3a894 100644 --- a/src/Phase.hs +++ b/src/Phase.hs @@ -3,7 +3,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Phase (Phase(..), runtime, prior, Phased(..)) where +module Phase (Phase(..), runtime, prior, posterior, Phased(..)) where import Control.Lens import Data.Data (Data) @@ -34,6 +34,9 @@ runtime = Phase 0 prior :: Phase -> Phase prior (Phase i) = Phase (i + 1) +posterior :: Phase -> Phase +posterior (Phase i) = Phase (i - 1) + class Phased a where shift :: Natural -> a -> a From a706a1077532b6393b60bd7bce70a6b6780b9f58 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20G=C3=A9lineau?= Date: Mon, 13 May 2024 16:06:14 -0400 Subject: [PATCH 02/15] one more inEarlierPhase was missing --- src/Expander.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Expander.hs b/src/Expander.hs index a20b07d0..ee0f9761 100644 --- a/src/Expander.hs +++ b/src/Expander.hs @@ -1309,7 +1309,7 @@ expandOneForm prob stx res <- inEarlierPhase $ interpretMacroAction prob act case res of StuckOnType loc ty env cases kont -> - forkAwaitingTypeCase loc prob ty env cases kont + inEarlierPhase $ forkAwaitingTypeCase loc prob ty env cases kont Done expanded -> case expanded of ValueSyntax expansionResult -> From 7392b3cdd99491303200d63a13afee376976651c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20G=C3=A9lineau?= Date: Thu, 16 May 2024 22:03:35 -0400 Subject: [PATCH 03/15] with-unknown-type examples --- src/Expander/Primitives.hs | 62 +++++++++++++++++++++++++++++++++----- 1 file changed, 54 insertions(+), 8 deletions(-) diff --git a/src/Expander/Primitives.hs b/src/Expander/Primitives.hs index b8c5b8f8..41458eb2 100644 --- a/src/Expander/Primitives.hs +++ b/src/Expander/Primitives.hs @@ -47,7 +47,7 @@ module Expander.Primitives , elsePattern -- * Module primitives , makeModule - -- * Anywhere primitives + -- * Poly-Problem primitives , makeLocalType -- * Primitive values , unaryIntegerPrim @@ -567,13 +567,59 @@ makeModule expandDeclForms bodyPtr stx = pure () --------------- --- Anywhere -- --------------- - --- | with-unknown-type's implementation: create a named fresh --- unification variable for macros that only can annotate part of a --- type. +------------------ +-- Poly-Problem -- +------------------ + +-- | with-unknown-type binds a fresh unification variable. +-- +-- with-unknown-type works in any Problem. In a type, it acts like a named +-- wildcard in Haskell. That is, +-- +-- > (example +-- > (the (with-unknown-type [_i] +-- > (-> (Pair Integer _i) +-- > (Pair _i Integer))) +-- > id)) +-- +-- infers to +-- +-- > (example +-- > (the (-> (Pair Integer Integer) +-- > (Pair Integer Integer)) +-- > id)) +-- +-- In an expression, with-unknown-type makes it possible to specify that +-- multiple parts of that expression must have related types. For example, +-- +-- > (example +-- > (with-unknown-type [_i2i] +-- > (pair (the _i2i negate) +-- > (the _i2i id)))) +-- +-- infers to +-- +-- > (example +-- > (pair (the (-> Integer Integer) negate) +-- > (the (-> Integer Integer) id))) +-- +-- And in a declaration block, with-unknown-type makes it possible to specify +-- that multiple declarations must have related types. For example, +-- +-- > (with-unknown-type [_i2i] +-- > (group +-- > (example (the _i2i negate)) +-- > (example (the _i2i id)))) +-- +-- infers to +-- +-- > (group +-- > (example (the (-> Integer Integer) negate)) +-- > (example (the (-> Integer Integer) id))) +-- +-- If there were pattern macros which took a type as an argument, +-- with-unknown-type would be useful in those Problems as well, to bind a +-- unification variable whose scope is limited to a portion of that pattern. makeLocalType :: MacroDest -> Syntax -> Expand () makeLocalType dest stx = do Stx _ _ (_, binder, body) <- mustHaveEntries stx From d1d4335917c1e600a346670cdc50f51ed150de4d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20G=C3=A9lineau?= Date: Mon, 20 May 2024 00:41:37 -0400 Subject: [PATCH 04/15] generalize alts --- src/Expander/Error.hs | 30 +++++++++++++++++------------- src/Expander/Syntax.hs | 19 ++++++++++--------- 2 files changed, 27 insertions(+), 22 deletions(-) diff --git a/src/Expander/Error.hs b/src/Expander/Error.hs index c4134733..9003d4d0 100644 --- a/src/Expander/Error.hs +++ b/src/Expander/Error.hs @@ -1,7 +1,9 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} module Expander.Error ( ExpansionErr(..) , SyntacticCategory(..) @@ -12,6 +14,7 @@ module Expander.Error import Control.Lens import Numeric.Natural +import Data.List.NonEmpty (NonEmpty((:|))) import Data.Text (Text) import Data.Sequence (Seq) import qualified Data.Text as T @@ -44,7 +47,7 @@ data ExpansionErr | NotInteger Syntax | NotString Syntax | NotModName Syntax - | NotRightLength [Natural] Syntax + | NotRightLength (NonEmpty Natural) Syntax | NotVec Syntax | NotImportSpec Syntax | NotExportSpec Syntax @@ -89,7 +92,7 @@ tenon :: a -> Tenon a tenon = Tenon notRightLength :: Natural -> Syntax -> ExpansionErr -notRightLength n = NotRightLength [n] +notRightLength n = NotRightLength (n :| []) data TypeCheckError = TypeMismatch (Maybe SrcLoc) Ty Ty (Maybe (Ty, Ty)) @@ -107,6 +110,17 @@ data SyntacticCategory | TypePatternCaseCat deriving Show +alts + :: NonEmpty (Doc ann) -> Doc ann +alts (x :| []) + = x +alts (x :| y : []) + = x <> " or " <> y +alts (x :| y : z : []) + = x <> ", " <> y <> ", or " <> z +alts (x1 :| x2 : xs) + = x1 <> ", " <> alts (x2 :| xs) + instance Pretty VarInfo ExpansionErr where pp env (Ambiguous p x candidates) = hang 4 $ @@ -148,19 +162,9 @@ instance Pretty VarInfo ExpansionErr where ] pp env (NotRightLength lengths0 stx) = hang 2 $ group $ - vsep [ text "Expected" <+> alts lengths0 <+> text "entries between parentheses, but got" + vsep [ text "Expected" <+> alts (fmap viaShow lengths0) <+> text "entries between parentheses, but got" , pp env stx ] - where - alts :: [Natural] -> Doc ann - alts [] - = error "internal error: NotRightLength doesn't offer any acceptable lengths" - alts [len] - = viaShow len - alts [len1, len2] - = viaShow len1 <+> "or" <+> viaShow len2 - alts (len:lengths) - = viaShow len <> "," <+> alts lengths pp env (NotVec stx) = hang 2 $ group $ vsep [text "Expected square-bracketed vec but got", pp env stx] pp env (NotImportSpec stx) = diff --git a/src/Expander/Syntax.hs b/src/Expander/Syntax.hs index 2a3202b5..9da735bd 100644 --- a/src/Expander/Syntax.hs +++ b/src/Expander/Syntax.hs @@ -10,7 +10,8 @@ module Expander.Syntax where import Control.Monad.Except import Control.Monad.IO.Class import Data.Functor.Identity (Identity(Identity)) -import Data.List (nub, sort) +import Data.List.NonEmpty (NonEmpty((:|))) +import qualified Data.List.NonEmpty as NonEmpty import Data.Text (Text) import qualified Data.Text as T import Numeric.Natural @@ -79,7 +80,7 @@ mustHaveEntries other = do throwError (NotList other) class FixedLengthList item r where - checkLength :: [item] -> Either [Natural] r + checkLength :: [item] -> Either (NonEmpty Natural) r instance ( FixedLengthList item a , FixedLengthList item b @@ -92,43 +93,43 @@ instance ( FixedLengthList item a (_, Right b) -> pure (Right b) (Left lengths1, Left lengths2) - -> Left $ nub $ sort (lengths1 ++ lengths2) + -> Left $ NonEmpty.nub $ NonEmpty.sort (lengths1 <> lengths2) instance FixedLengthList item () where checkLength [] = pure () checkLength _ - = Left [0] + = Left (0 :| []) instance a ~ item => FixedLengthList item (Identity a) where checkLength [x] = pure (Identity x) checkLength _ - = Left [1] + = Left (1 :| []) instance (a ~ item, b ~ item) => FixedLengthList item (a, b) where checkLength [x, y] = return (x, y) checkLength _ - = Left [2] + = Left (2 :| []) instance (a ~ item, b ~ item, c ~ item) => FixedLengthList item (a, b, c) where checkLength [x, y, z] = pure (x, y, z) checkLength _ - = Left [3] + = Left (3 :| []) instance (a ~ item, b ~ item, c ~ item, d ~ item) => FixedLengthList item (a, b, c, d) where checkLength [w, x, y, z] = pure (w, x, y, z) checkLength _ - = Left [4] + = Left (4 :| []) instance (a ~ item, b ~ item, c ~ item, d ~ item, e ~ item) => FixedLengthList item (a, b, c, d, e) where checkLength [v, w, x, y, z] = pure (v, w, x, y, z) checkLength _ - = Left [5] + = Left (5 :| []) class MustHaveShape a where From 7411b64fab6bc4eb4c5e1c657f53f83909393bea Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20G=C3=A9lineau?= Date: Mon, 20 May 2024 00:59:20 -0400 Subject: [PATCH 05/15] list all the Problems where the macro is valid --- src/Expander.hs | 17 ++++++++++------- src/Expander/Error.hs | 8 ++++---- 2 files changed, 14 insertions(+), 11 deletions(-) diff --git a/src/Expander.hs b/src/Expander.hs index ee0f9761..549e718b 100644 --- a/src/Expander.hs +++ b/src/Expander.hs @@ -51,6 +51,7 @@ import Control.Monad.Trans.State.Strict (StateT, execStateT, modify', runStateT) 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(..)) @@ -1171,19 +1172,19 @@ requireDeclarationCat :: Syntax -> MacroDest -> Expand (DeclTreePtr, DeclOutputS 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 _ (PatternDest scrutTy dest) = @@ -1192,7 +1193,9 @@ requirePatternCat _ (TypePatternDest dest) = return $ Right dest requirePatternCat stx other = throwError $ - WrongSyntacticCategory stx (tenon PatternCaseCat) (mortise $ problemCategory other) + WrongSyntacticCategory stx + (tenon PatternCaseCat :| tenon TypePatternCaseCat : []) + (mortise $ problemCategory other) expandOneForm :: MacroDest -> Syntax -> Expand () @@ -1241,14 +1244,14 @@ expandOneForm prob stx CtorPattern 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,7 +1263,7 @@ expandOneForm prob stx 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 impl dest stx diff --git a/src/Expander/Error.hs b/src/Expander/Error.hs index 9003d4d0..e574d31d 100644 --- a/src/Expander/Error.hs +++ b/src/Expander/Error.hs @@ -62,7 +62,7 @@ data ExpansionErr | NotExported Ident Phase | ReaderError Text | WrongSyntacticCategory Syntax - (Tenon SyntacticCategory) + (NonEmpty (Tenon SyntacticCategory)) (Mortise SyntacticCategory) | NotValidType Syntax | TypeCheckError TypeCheckError @@ -204,16 +204,16 @@ instance Pretty VarInfo ExpansionErr where text "Internal error during expansion! This is a bug in the implementation." <> line <> string str pp _env (ReaderError txt) = vsep (map text (T.lines txt)) - pp env (WrongSyntacticCategory stx is shouldBe) = + pp env (WrongSyntacticCategory stx tenons _mortise) = hang 2 $ group $ vsep [ pp env stx <> text ":" , group $ vsep [ group $ hang 2 $ vsep [ text "Used in a position expecting" - , pp env (unMortise shouldBe) + , pp env $ unMortise _mortise ] , group $ hang 2 $ vsep [ text "but is valid in a position expecting" - , pp env (unTenon is) + , alts $ fmap (pp env . unTenon) tenons ] ] ] From 083837eb8d12dd348223c13038d5f261985d79ff Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20G=C3=A9lineau?= Date: Mon, 20 May 2024 23:11:09 -0400 Subject: [PATCH 06/15] Pattern, TypePattern, vs PolyProblem prims previously, "else" was considered a "pattern primitive", even though it is valid in both the pattern and the type pattern Problems. And "with-unknown-macro" was considered a "universal primitive", because it works in any Problem. Now, a "pattern primitive" means a pattern which is _only_ valid in the pattern Problem, and a "type pattern primitive" (a new term!) means a pattern which is _only_ valid in the type pattern Problem. There are no such primitives yet, but I plan to add a type pattern primitive, this commit is in preparation for that. Finally, a "poly-problem primitive" now means a primitive which works in more than one Problem; all of them in the case of "with-unknown-type", and two of them in the case of "else". --- src/Expander.hs | 70 +++++++++++++++++++++++--------------- src/Expander/Error.hs | 18 +++++++--- src/Expander/Monad.hs | 5 +-- src/Expander/Primitives.hs | 49 +++++++++++++++++++------- 4 files changed, 95 insertions(+), 47 deletions(-) diff --git a/src/Expander.hs b/src/Expander.hs index 549e718b..3d5e28d3 100644 --- a/src/Expander.hs +++ b/src/Expander.hs @@ -388,9 +388,10 @@ initializeKernel outputChannel = do 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 @@ -616,10 +617,10 @@ initializeKernel outputChannel = do ) ] - 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) @@ -632,7 +633,7 @@ initializeKernel outputChannel = do , ("group", Prims.group expandDeclForms) ] - exprPrims :: [(Text, Ty -> SplitCorePtr -> Syntax -> Expand ())] + exprPrims :: [(Text, Prims.ExprPrim)] exprPrims = [ ("error", Prims.err) , ("the", Prims.the) @@ -664,8 +665,17 @@ initializeKernel outputChannel = do , ("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 @@ -723,13 +733,21 @@ initializeKernel outputChannel = do 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 @@ -762,9 +780,9 @@ initializeKernel outputChannel = do 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 @@ -1160,14 +1178,6 @@ addStringLiteral (Syntax (Stx scs loc _)) s = 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 = @@ -1186,16 +1196,19 @@ requireExpressionCat stx other = throwError $ 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 :| tenon TypePatternCaseCat : []) - (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 () @@ -1265,9 +1278,12 @@ expandOneForm prob stx throwError $ 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 diff --git a/src/Expander/Error.hs b/src/Expander/Error.hs index e574d31d..7e64d32a 100644 --- a/src/Expander/Error.hs +++ b/src/Expander/Error.hs @@ -6,7 +6,7 @@ {-# LANGUAGE UndecidableInstances #-} module Expander.Error ( ExpansionErr(..) - , SyntacticCategory(..) + , SyntacticCategory(..), problemCategory , TypeCheckError(..) , Tenon, tenon, Mortise, mortise , notRightLength @@ -106,10 +106,18 @@ data SyntacticCategory | DeclarationCat | TypeCat | ExpressionCat - | PatternCaseCat - | TypePatternCaseCat + | PatternCat + | TypePatternCat deriving Show +problemCategory :: MacroDest -> SyntacticCategory +problemCategory (ModuleDest {}) = ModuleCat +problemCategory (DeclTreeDest {}) = DeclarationCat +problemCategory (TypeDest {}) = TypeCat +problemCategory (ExprDest {}) = ExpressionCat +problemCategory (PatternDest {}) = PatternCat +problemCategory (TypePatternDest {}) = TypePatternCat + alts :: NonEmpty (Doc ann) -> Doc ann alts (x :| []) @@ -279,5 +287,5 @@ instance Pretty VarInfo SyntacticCategory where pp _env ModuleCat = text "a module" pp _env TypeCat = text "a type" pp _env DeclarationCat = text "a top-level declaration or example" - pp _env PatternCaseCat = text "a pattern" - pp _env TypePatternCaseCat = text "a typecase pattern" + pp _env PatternCat = text "a pattern" + pp _env TypePatternCat = text "a typecase pattern" diff --git a/src/Expander/Monad.hs b/src/Expander/Monad.hs index 330d8b53..5b16b0b2 100644 --- a/src/Expander/Monad.hs +++ b/src/Expander/Monad.hs @@ -238,8 +238,9 @@ data EValue -- ^ For type-level special forms - first as types, then as type patterns | EPrimModuleMacro (DeclTreePtr -> Syntax -> Expand ()) | EPrimDeclMacro (DeclTreePtr -> DeclOutputScopesPtr -> Syntax -> Expand ()) - | EPrimPatternMacro (Either (Ty, PatternPtr) TypePatternPtr -> Syntax -> Expand ()) - | EPrimUniversalMacro (MacroDest -> Syntax -> Expand ()) + | EPrimPatternMacro (Ty -> PatternPtr -> Syntax -> Expand ()) + | EPrimTypePatternMacro (TypePatternPtr -> Syntax -> Expand ()) + | EPrimPolyProblemMacro (MacroDest -> Syntax -> Expand ()) | EVarMacro !Var -- ^ For bound variables (the Unique is the binding site of the var) | ETypeVar !Kind !Natural -- ^ For bound type variables (user-written Skolem variables or in datatype definitions) diff --git a/src/Expander/Primitives.hs b/src/Expander/Primitives.hs index 41458eb2..bf25b48f 100644 --- a/src/Expander/Primitives.hs +++ b/src/Expander/Primitives.hs @@ -8,7 +8,8 @@ {-# OPTIONS -Wno-name-shadowing #-} module Expander.Primitives ( -- * Declaration primitives - define + DeclPrim + , define , datatype , defineMacros , example @@ -16,6 +17,7 @@ module Expander.Primitives , group , meta -- * Expression primitives + , ExprPrim , app , integerLiteral , stringLiteral @@ -44,11 +46,16 @@ module Expander.Primitives , the , typeCase -- * Pattern primitives - , elsePattern + , PatternPrim + -- * Type pattern primitives + , TypePatternPrim -- * Module primitives + , ModulePrim , makeModule -- * Poly-Problem primitives + , PolyProblemPrim , makeLocalType + , elsePattern -- * Primitive values , unaryIntegerPrim , binaryIntegerPrim @@ -65,6 +72,7 @@ import Control.Lens hiding (List) import Control.Monad.IO.Class import Control.Monad import Control.Monad.Except +import Data.List.NonEmpty (NonEmpty((:|))) import Data.Text (Text) import qualified Data.Text as T import Data.Traversable @@ -552,7 +560,9 @@ baseType ctor = typeConstructor ctor [] -- Modules -- ------------- -makeModule :: DeclExpander -> DeclTreePtr -> Syntax -> Expand () +type ModulePrim = DeclTreePtr -> Syntax -> Expand () + +makeModule :: DeclExpander -> ModulePrim makeModule expandDeclForms bodyPtr stx = view expanderModuleTop <$> getState >>= \case @@ -567,10 +577,24 @@ makeModule expandDeclForms bodyPtr stx = pure () +-------------- +-- Patterns -- +-------------- + +type PatternPrim = Ty -> PatternPtr -> Syntax -> Expand () + +------------------- +-- Type Patterns -- +------------------- + +type TypePatternPrim = TypePatternPtr -> Syntax -> Expand () + ------------------ -- Poly-Problem -- ------------------ +type PolyProblemPrim = MacroDest -> Syntax -> Expand () + -- | with-unknown-type binds a fresh unification variable. -- -- with-unknown-type works in any Problem. In a type, it acts like a named @@ -620,7 +644,7 @@ makeModule expandDeclForms bodyPtr stx = -- If there were pattern macros which took a type as an argument, -- with-unknown-type would be useful in those Problems as well, to bind a -- unification variable whose scope is limited to a portion of that pattern. -makeLocalType :: MacroDest -> Syntax -> Expand () +makeLocalType :: PolyProblemPrim makeLocalType dest stx = do Stx _ _ (_, binder, body) <- mustHaveEntries stx Stx _ _ (Identity theVar) <- mustHaveEntries binder @@ -642,27 +666,26 @@ makeLocalType dest stx = do forkExpandSyntax dest (addScope p sc body) --------------- --- Patterns -- --------------- - -type PatternPrim = Either (Ty, PatternPtr) TypePatternPtr -> Syntax -> Expand () - -elsePattern :: PatternPrim -elsePattern (Left (scrutTy, dest)) stx = do +elsePattern :: PolyProblemPrim +elsePattern (PatternDest scrutTy dest) stx = do Stx _ _ (_, var) <- mustHaveEntries stx ty <- trivialScheme scrutTy (sc, x, v) <- prepareVar var modifyState $ set (expanderPatternBinders . at dest) $ Just $ Right (sc, x, v, ty) linkPattern dest $ PatternVar x v -elsePattern (Right dest) stx = do +elsePattern (TypePatternDest dest) stx = do Stx _ _ (_, var) <- mustHaveEntries stx ty <- trivialScheme tType (sc, x, v) <- prepareVar var linkTypePattern dest (AnyType x v) [(sc, x, v, ty)] +elsePattern other stx = do + throwError $ + WrongSyntacticCategory stx + (tenon PatternCat :| tenon TypePatternCat : []) + (mortise $ problemCategory other) ------------- -- Helpers -- From 62c1a0e7afc91f7e5d9441c131771a2db66277ab Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20G=C3=A9lineau?= Date: Tue, 21 May 2024 00:14:31 -0400 Subject: [PATCH 07/15] rename TypePattern ctors to match ConstructorPatternF --- src/Core.hs | 26 +++++++++++++------------- src/Evaluator.hs | 6 +++--- src/Expander.hs | 2 +- src/Expander/Primitives.hs | 8 ++++---- src/Pretty.hs | 6 +++--- 5 files changed, 24 insertions(+), 24 deletions(-) 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 -> From e6e1d8193839e7afc356041c2c1479bce5274dbf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20G=C3=A9lineau?= Date: Wed, 22 May 2024 23:07:27 -0400 Subject: [PATCH 08/15] fork job at the phase of the output forkAwaitingTypeCase schedules a job which (eventually) executes the Macro actions which follow the type-case. shifting the phase before forking did cause that Macro action to be executed in a shifted phase, but also had the unintended effect of shifting the phase at which to interpret the Syntax returned by the macro. The solution: don't shift the fork call, but do shift the Macro action it eventually executes. --- src/Expander.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/src/Expander.hs b/src/Expander.hs index 2ae7ddf5..ce8b5729 100644 --- a/src/Expander.hs +++ b/src/Expander.hs @@ -934,6 +934,7 @@ runTask (tid, localData, task) = withLocal localData $ do 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 @@ -993,7 +994,7 @@ runTask (tid, localData, task) = withLocal localData $ do 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 @@ -1004,11 +1005,11 @@ runTask (tid, localData, task) = withLocal localData $ do 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 @@ -1328,7 +1329,7 @@ expandOneForm prob stx res <- inEarlierPhase $ interpretMacroAction prob act case res of StuckOnType loc ty env cases kont -> - inEarlierPhase $ forkAwaitingTypeCase loc prob ty env cases kont + forkAwaitingTypeCase loc prob ty env cases kont Done expanded -> case expanded of ValueSyntax expansionResult -> From 0d88fb6f923c487b8a0835c5a44479cc5538b3c0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20G=C3=A9lineau?= Date: Mon, 27 May 2024 14:12:51 -0400 Subject: [PATCH 09/15] WIP toy.kl --- toy.kl | 74 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 74 insertions(+) create mode 100644 toy.kl diff --git a/toy.kl b/toy.kl new file mode 100644 index 00000000..8c57b1be --- /dev/null +++ b/toy.kl @@ -0,0 +1,74 @@ +#lang "prelude.kl" +(import (shift "prelude.kl" 1)) +(import (shift "prelude.kl" 2)) + +(datatype (T) + (mkT)) + +--(meta +-- (define-macros +-- ([my-else +-- (lambda (_) +-- (pure '(else _)))]))) + +--(define-macros +-- ([my-macro +-- (lambda (stx) +-- (>>= (which-problem) +-- (lambda (problem) +-- (case problem +-- [(expression type) +-- (type-case type +-- --[(T) +-- -- (pure '(mkT))] +-- [(else x) +-- (type-case x +-- [(T) +-- (pure '(mkT))] +-- [(else _) +-- (pure '(mkT))])])]))))])) +--(example (the (T) (my-macro))) + +(define-macros + ([my-macro + (lambda (stx) + (>>= (which-problem) + (lambda (problem) + (case problem + [(expression type) + (type-case type + [(else _) + (pure '(mkT))])]))))])) +(example (the (T) (my-macro))) + + + +-- | e | ee | eee | run +-- (error _) p1 p1 p1 p1 (should be p1) +-- (which-problem) (error _) p0 p0 p1 p1 (should be p1) +-- '(mkT) p0 p0 p0 p0 (found in p0) +-- (which-problem) '(mkT) p0 p0 p1 p1 (found in p0) +-- (T) p1 p1 p1 p1 (found in p0) +-- (which-problem) (T) p1 p1 p1 p0 (found in p0) +-- (which-problem) (else _) p1 p1 p1 p0 (found in p0) + +-- therefore: +-- [x] eee is needed, we do want the code after (which-problem) to be evaluated and executed at p1. +-- [ ] eee is incomplete, it should return code from p0, not p1. +-- [ ] type-case should look at the types from p0, not p1. +-- [ ] but we can't, because else + +---- David thought of this counter-example: +--(example +-- (with-unknown-type (String) +-- (the (-> String String) (lambda (x) 5)))) +-- +--(define-macros +-- ([my-macro +-- (lambda (stx) +-- (>>= (which-problem) +-- (lambda (problem) +-- (case problem +-- [(expression tp) +-- (pure '(true))]))))])) +--(example (my-macro my-keyword)) From a73bac6ac9dcca8dcbc44ea8862edb64472d3a5d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20G=C3=A9lineau?= Date: Tue, 28 May 2024 22:20:44 -0400 Subject: [PATCH 10/15] WIP the-type --- toy.kl | 2 ++ 1 file changed, 2 insertions(+) diff --git a/toy.kl b/toy.kl index 8c57b1be..826d7b7a 100644 --- a/toy.kl +++ b/toy.kl @@ -37,6 +37,8 @@ (case problem [(expression type) (type-case type + [(the-type T) + (pure '(mkT))] [(else _) (pure '(mkT))])]))))])) (example (the (T) (my-macro))) From 6fd4d06e44aa2978d715d8360a0d41a45621063b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20G=C3=A9lineau?= Date: Tue, 28 May 2024 22:24:51 -0400 Subject: [PATCH 11/15] new Problem: type constructor I want to add a type pattern macro in phase 1 which matches on a type constructor in phase 0. The only way to lookup a type constructor is to expand the name of that type constructor (so that hygiene rules apply properly). That means we now need macros which return type constructors, not types nor type patterns. --- examples/primitives-documentation.golden | 1 + examples/primitives-documentation.kl | 1 + src/Expander.hs | 42 +++++++++++++++++++++++- src/Expander/Error.hs | 3 ++ src/Expander/Monad.hs | 1 + src/Expander/Primitives.hs | 8 +++++ src/Expander/Task.hs | 2 ++ src/SplitCore.hs | 15 +++++++++ stdlib/prelude.kl | 2 +- 9 files changed, 73 insertions(+), 2 deletions(-) diff --git a/examples/primitives-documentation.golden b/examples/primitives-documentation.golden index f92ed433..740067ae 100644 --- a/examples/primitives-documentation.golden +++ b/examples/primitives-documentation.golden @@ -39,6 +39,7 @@ (type) : Problem (pattern) : Problem (type-pattern) : Problem +(type-constructor) : Problem (nothing) : ∀(α : *). (Maybe α) (nil) : ∀(α : *). (List α) make-introducer : (Macro (ScopeAction → (Syntax → Syntax))) diff --git a/examples/primitives-documentation.kl b/examples/primitives-documentation.kl index e171033b..e9cf547f 100644 --- a/examples/primitives-documentation.kl +++ b/examples/primitives-documentation.kl @@ -125,6 +125,7 @@ -- expression : Type -> Problem (example (pattern)) (example (type-pattern)) +(example (type-constructor)) -- -- Maybe : Type -> Type (example nothing) diff --git a/src/Expander.hs b/src/Expander.hs index ce8b5729..ee7aeed3 100644 --- a/src/Expander.hs +++ b/src/Expander.hs @@ -13,6 +13,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +{-# OPTIONS -Wno-incomplete-uni-patterns #-} module Expander ( -- * Concrete expanders expandExpr @@ -389,6 +390,7 @@ initializeKernel outputChannel = do traverse_ (uncurry addTypePrimitive) typePrims traverse_ (uncurry addPatternPrimitive) patternPrims traverse_ (uncurry addTypePatternPrimitive) typePatternPrims + traverse_ (uncurry addTypeCtorPrimitive) typeCtorPrims traverse_ (uncurry addPolyProblemPrimitive) polyProblemPrims traverse_ addDatatypePrimitive datatypePrims traverse_ addFunPrimitive funPrims @@ -597,7 +599,15 @@ initializeKernel outputChannel = do [ ("ScopeAction", [], [("flip", []), ("add", []), ("remove", [])]) , ("Unit", [], [("unit", [])]) , ("Bool", [], [("true", []), ("false", [])]) - , ("Problem", [], [("module", []), ("declaration", []), ("type", []), ("expression", [tType]), ("pattern", []), ("type-pattern", [])]) + , ("Problem", [], + [ ("module", []) + , ("declaration", []) + , ("type", []) + , ("expression", [tType]) + , ("pattern", []) + , ("type-pattern", []) + , ("type-constructor", []) + ]) , ("Maybe", [KStar], [("nothing", []), ("just", [tSchemaVar 0 []])]) , ("List" , [KStar] @@ -671,6 +681,9 @@ initializeKernel outputChannel = do typePatternPrims :: [(Text, Prims.TypePatternPrim)] typePatternPrims = [] + typeCtorPrims :: [(Text, Prims.TypeCtorPrim)] + typeCtorPrims = [] + polyProblemPrims :: [(Text, Prims.PolyProblemPrim)] polyProblemPrims = [ ("else", Prims.elsePattern) @@ -748,6 +761,14 @@ initializeKernel outputChannel = do bind b val addToKernel name runtime b + addTypeCtorPrimitive :: + Text -> (TypeCtorPtr -> Syntax -> Expand ()) -> Expand () + addTypeCtorPrimitive name impl = do + let val = EPrimTypeCtorMacro impl + b <- freshBinding + bind b val + addToKernel name runtime b + addModulePrimitive :: Text -> (DeclTreePtr -> Syntax -> Expand ()) -> Expand () addModulePrimitive name impl = do let val = EPrimModuleMacro impl @@ -914,6 +935,8 @@ runTask (tid, localData, task) = withLocal localData $ do expandOnePattern scrutT d stx TypePatternDest d -> expandOneTypePattern d stx + TypeCtorDest d -> + expandOneTypeCtor d stx AwaitingType tdest after -> linkedType tdest >>= \case @@ -1151,6 +1174,10 @@ expandOneTypePattern :: TypePatternPtr -> Syntax -> Expand () expandOneTypePattern dest stx = expandOneForm (TypePatternDest dest) stx +expandOneTypeCtor :: TypeCtorPtr -> Syntax -> Expand () +expandOneTypeCtor dest stx = + expandOneForm (TypeCtorDest dest) stx + -- | Insert a function application marker with a lexical context from @@ -1211,6 +1238,13 @@ requireTypePatternCat stx other = throwError $ WrongSyntacticCategory stx (tenon TypePatternCat :| []) (mortise $ problemCategory other) +requireTypeCtorCat :: Syntax -> MacroDest -> Expand TypeCtorPtr +requireTypeCtorCat _ (TypeCtorDest dest) = + return dest +requireTypeCtorCat stx other = + throwError $ + WrongSyntacticCategory stx (tenon TypeCtorCat :| []) (mortise $ problemCategory other) + expandOneForm :: MacroDest -> Syntax -> Expand () expandOneForm prob stx @@ -1284,6 +1318,9 @@ expandOneForm prob stx EPrimTypePatternMacro impl -> do dest <- requireTypePatternCat stx prob impl dest stx + EPrimTypeCtorMacro impl -> do + dest <- requireTypeCtorCat stx prob + impl dest stx EPrimPolyProblemMacro impl -> impl prob stx EVarMacro var -> do @@ -1360,6 +1397,8 @@ expandOneForm prob stx throwError $ InternalError "All patterns should be identifier-headed" TypePatternDest {} -> throwError $ InternalError "All type patterns should be identifier-headed" + TypeCtorDest {} -> + throwError $ InternalError "All type constructors should be identifier-headed" expandModuleForm :: DeclTreePtr -> Syntax -> Expand () @@ -1482,5 +1521,6 @@ interpretMacroAction prob = ExprDest t _stx -> pure $ Done $ primitiveCtor "expression" [ValueType t] PatternDest {} -> pure $ Done $ primitiveCtor "pattern" [] TypePatternDest {} -> pure $ Done $ primitiveCtor "type-pattern" [] + TypeCtorDest {} -> pure $ Done $ primitiveCtor "type-constructor" [] MacroActionTypeCase env loc ty cases -> do pure $ StuckOnType loc ty env cases [] diff --git a/src/Expander/Error.hs b/src/Expander/Error.hs index 7e64d32a..a31acd96 100644 --- a/src/Expander/Error.hs +++ b/src/Expander/Error.hs @@ -108,6 +108,7 @@ data SyntacticCategory | ExpressionCat | PatternCat | TypePatternCat + | TypeCtorCat deriving Show problemCategory :: MacroDest -> SyntacticCategory @@ -117,6 +118,7 @@ problemCategory (TypeDest {}) = TypeCat problemCategory (ExprDest {}) = ExpressionCat problemCategory (PatternDest {}) = PatternCat problemCategory (TypePatternDest {}) = TypePatternCat +problemCategory (TypeCtorDest {}) = TypeCtorCat alts :: NonEmpty (Doc ann) -> Doc ann @@ -289,3 +291,4 @@ instance Pretty VarInfo SyntacticCategory where pp _env DeclarationCat = text "a top-level declaration or example" pp _env PatternCat = text "a pattern" pp _env TypePatternCat = text "a typecase pattern" + pp _env TypeCtorCat = text "a type constructor" diff --git a/src/Expander/Monad.hs b/src/Expander/Monad.hs index 5b16b0b2..9323a102 100644 --- a/src/Expander/Monad.hs +++ b/src/Expander/Monad.hs @@ -240,6 +240,7 @@ data EValue | EPrimDeclMacro (DeclTreePtr -> DeclOutputScopesPtr -> Syntax -> Expand ()) | EPrimPatternMacro (Ty -> PatternPtr -> Syntax -> Expand ()) | EPrimTypePatternMacro (TypePatternPtr -> Syntax -> Expand ()) + | EPrimTypeCtorMacro (TypeCtorPtr -> Syntax -> Expand ()) | EPrimPolyProblemMacro (MacroDest -> Syntax -> Expand ()) | EVarMacro !Var -- ^ For bound variables (the Unique is the binding site of the var) | ETypeVar !Kind !Natural diff --git a/src/Expander/Primitives.hs b/src/Expander/Primitives.hs index 14a31f74..4433f9c2 100644 --- a/src/Expander/Primitives.hs +++ b/src/Expander/Primitives.hs @@ -49,6 +49,8 @@ module Expander.Primitives , PatternPrim -- * Type pattern primitives , TypePatternPrim + -- * Type constructor primitives + , TypeCtorPrim -- * Module primitives , ModulePrim , makeModule @@ -589,6 +591,12 @@ type PatternPrim = Ty -> PatternPtr -> Syntax -> Expand () type TypePatternPrim = TypePatternPtr -> Syntax -> Expand () +----------------------- +-- Type Constructors -- +----------------------- + +type TypeCtorPrim = TypeCtorPtr -> Syntax -> Expand () + ------------------ -- Poly-Problem -- ------------------ diff --git a/src/Expander/Task.hs b/src/Expander/Task.hs index d4a3707b..49bda6fa 100644 --- a/src/Expander/Task.hs +++ b/src/Expander/Task.hs @@ -33,6 +33,8 @@ data MacroDest -- ^ scrutinee type, destination pointer | TypePatternDest TypePatternPtr -- ^ destination pointer + | TypeCtorDest TypeCtorPtr + -- ^ destination pointer deriving Show diff --git a/src/SplitCore.hs b/src/SplitCore.hs index d010355c..a66c94ad 100644 --- a/src/SplitCore.hs +++ b/src/SplitCore.hs @@ -80,6 +80,21 @@ instance Show TypePatternPtr where newTypePatternPtr :: IO TypePatternPtr newTypePatternPtr = TypePatternPtr <$> newUnique +newtype TypeCtorPtr = TypeCtorPtr Unique + deriving (Eq, Ord) + +instance HasKey TypeCtorPtr where + getKey (TypeCtorPtr u) = getKey u + fromKey i = TypeCtorPtr $! fromKey i + {-# INLINE getKey #-} + {-# INLINE fromKey #-} + +instance Show TypeCtorPtr where + show (TypeCtorPtr u) = "(TypeCtorPtr " ++ show (hashUnique u) ++ ")" + +newTypeCtorPtr :: IO TypeCtorPtr +newTypeCtorPtr = TypeCtorPtr <$> newUnique + data SplitCore = SplitCore { _splitCoreRoot :: SplitCorePtr , _splitCoreDescendants :: Store SplitCorePtr (CoreF TypePatternPtr PatternPtr SplitCorePtr) diff --git a/stdlib/prelude.kl b/stdlib/prelude.kl index 6de7f4af..16d4c39f 100644 --- a/stdlib/prelude.kl +++ b/stdlib/prelude.kl @@ -41,7 +41,7 @@ ScopeAction flip add remove Unit unit Bool true false - Problem module declaration type expression pattern type-pattern + Problem module declaration type expression pattern type-pattern type-constructor Maybe nothing just List nil :: Syntax-Contents list-contents integer-contents string-contents identifier-contents From d14128525a2808dcc748ffd2bd41f54539395542 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20G=C3=A9lineau?= Date: Tue, 28 May 2024 22:56:01 -0400 Subject: [PATCH 12/15] rename ConstructorPattern to match TypePattern --- src/Core.hs | 30 +++++++++++++++--------------- src/Evaluator.hs | 8 ++++---- src/Expander/Monad.hs | 4 ++-- src/Expander/Primitives.hs | 1 + src/PartialCore.hs | 8 ++++---- src/Pretty.hs | 6 +++--- src/SplitCore.hs | 8 ++++---- tests/Test.hs | 18 +++++++++--------- 8 files changed, 42 insertions(+), 41 deletions(-) diff --git a/src/Core.hs b/src/Core.hs index 92683bd8..16ae2298 100644 --- a/src/Core.hs +++ b/src/Core.hs @@ -77,22 +77,22 @@ data TypePattern | TypePatternVar Ident Var deriving (Data, Eq, Show) -data ConstructorPatternF pat +data DataPatternF pat = DataCtorPattern !Constructor [pat] | PatternVar Ident Var deriving (Data, Eq, Foldable, Functor, Show, Traversable) -makePrisms ''ConstructorPatternF +makePrisms ''DataPatternF -newtype ConstructorPattern = - ConstructorPattern { unConstructorPattern :: ConstructorPatternF ConstructorPattern } +newtype DataPattern = + DataPattern { unDataPattern :: DataPatternF DataPattern } deriving (Data, Eq, Show) -makePrisms ''ConstructorPattern +makePrisms ''DataPattern -instance Phased a => Phased (ConstructorPatternF a) where +instance Phased a => Phased (DataPatternF a) where shift i = fmap (shift i) -instance Phased ConstructorPattern where - shift i = over _ConstructorPattern (shift i) +instance Phased DataPattern where + shift i = over _DataPattern (shift i) instance Phased TypePattern where shift _ = id @@ -316,7 +316,7 @@ instance (Phased typePat, Phased pat, Phased core) => Phased (CoreF typePat pat -- | A fully-expanded expression, ready to be evaluated. newtype Core = Core - { unCore :: CoreF TypePattern ConstructorPattern Core } + { unCore :: CoreF TypePattern DataPattern Core } deriving (Data, Eq, Show) makePrisms ''Core @@ -386,11 +386,11 @@ instance (AlphaEq typePat, AlphaEq pat, AlphaEq core) => AlphaEq (CoreF typePat alphaCheck _ _ = notAlphaEquivalent -instance AlphaEq ConstructorPattern where +instance AlphaEq DataPattern where alphaCheck p1 p2 = - alphaCheck (unConstructorPattern p1) (unConstructorPattern p2) + alphaCheck (unDataPattern p1) (unDataPattern p2) -instance AlphaEq a => AlphaEq (ConstructorPatternF a) where +instance AlphaEq a => AlphaEq (DataPatternF a) where alphaCheck (DataCtorPattern c1 vars1) (DataCtorPattern c2 vars2) = do alphaCheck c1 c2 @@ -595,10 +595,10 @@ instance (ShortShow typePat, ShortShow pat, ShortShow core) => instance ShortShow Core where shortShow (Core x) = shortShow x -instance ShortShow ConstructorPattern where - shortShow = shortShow . unConstructorPattern +instance ShortShow DataPattern where + shortShow = shortShow . unDataPattern -instance ShortShow a => ShortShow (ConstructorPatternF a) where +instance ShortShow a => ShortShow (DataPatternF a) where shortShow (DataCtorPattern ctor vars) = "(" ++ shortShow ctor ++ " " ++ intercalate " " (map shortShow vars) ++ diff --git a/src/Evaluator.hs b/src/Evaluator.hs index 97a3225e..eccd6799 100644 --- a/src/Evaluator.hs +++ b/src/Evaluator.hs @@ -273,15 +273,15 @@ withScopeOf scope expr = do Syntax (Stx scopeSet loc _) -> pure $ ValueSyntax $ Syntax $ Stx scopeSet loc expr -doDataCase :: SrcLoc -> Value -> [(ConstructorPattern, Core)] -> Eval Value +doDataCase :: SrcLoc -> Value -> [(DataPattern, Core)] -> Eval Value doDataCase loc v0 [] = throwError (EvalErrorCase loc v0) doDataCase loc v0 ((pat, rhs) : ps) = - match (doDataCase loc v0 ps) (eval rhs) [(unConstructorPattern pat, v0)] + match (doDataCase loc v0 ps) (eval rhs) [(unDataPattern pat, v0)] where match :: Eval Value {- ^ Failure continuation -} -> Eval Value {- ^ Success continuation, to be used in an extended environment -} -> - [(ConstructorPatternF ConstructorPattern, Value)] {- ^ Subpatterns and their scrutinees -} -> + [(DataPatternF DataPattern, Value)] {- ^ Subpatterns and their scrutinees -} -> Eval Value match _fk sk [] = sk match fk sk ((DataCtorPattern ctor subPats, tgt) : more) = @@ -290,7 +290,7 @@ doDataCase loc v0 ((pat, rhs) : ps) = | c == ctor -> if length subPats /= length args then error $ "Type checker bug: wrong number of pattern vars for constructor " ++ show c - else match fk sk (zip (map unConstructorPattern subPats) args ++ more) + else match fk sk (zip (map unDataPattern subPats) args ++ more) _otherValue -> fk match fk sk ((PatternVar n x, tgt) : more) = match fk (withExtendedEnv n x tgt $ sk) more diff --git a/src/Expander/Monad.hs b/src/Expander/Monad.hs index 9323a102..f850b517 100644 --- a/src/Expander/Monad.hs +++ b/src/Expander/Monad.hs @@ -289,7 +289,7 @@ data ExpanderState = ExpanderState , _expanderTasks :: [(TaskID, ExpanderLocal, ExpanderTask)] , _expanderOriginLocations :: !(Store SplitCorePtr SrcLoc) , _expanderCompletedCore :: !(Store SplitCorePtr (CoreF TypePatternPtr PatternPtr SplitCorePtr)) - , _expanderCompletedPatterns :: !(Store PatternPtr (ConstructorPatternF PatternPtr)) + , _expanderCompletedPatterns :: !(Store PatternPtr (DataPatternF PatternPtr)) , _expanderCompletedTypePatterns :: !(Store TypePatternPtr TypePattern) , _expanderPatternBinders :: !(Store PatternPtr (Either [PatternPtr] (Scope, Ident, Var, SchemePtr))) , _expanderTypePatternBinders :: !(Store TypePatternPtr [(Scope, Ident, Var, SchemePtr)]) @@ -449,7 +449,7 @@ linkExpr :: SplitCorePtr -> CoreF TypePatternPtr PatternPtr SplitCorePtr -> Expa linkExpr dest layer = modifyState $ over expanderCompletedCore (<> S.singleton dest layer) -linkPattern :: PatternPtr -> ConstructorPatternF PatternPtr -> Expand () +linkPattern :: PatternPtr -> DataPatternF PatternPtr -> Expand () linkPattern dest pat = modifyState $ over expanderCompletedPatterns (<> S.singleton dest pat) diff --git a/src/Expander/Primitives.hs b/src/Expander/Primitives.hs index 4433f9c2..c059fdea 100644 --- a/src/Expander/Primitives.hs +++ b/src/Expander/Primitives.hs @@ -6,6 +6,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS -Wno-name-shadowing #-} +{-# OPTIONS -Wno-incomplete-uni-patterns #-} module Expander.Primitives ( -- * Declaration primitives DeclPrim diff --git a/src/PartialCore.hs b/src/PartialCore.hs index 4ae9a695..a84002b6 100644 --- a/src/PartialCore.hs +++ b/src/PartialCore.hs @@ -6,7 +6,7 @@ import Control.Lens import Core newtype PartialPattern = - PartialPattern { unPartialPattern :: Maybe (ConstructorPatternF PartialPattern) } + PartialPattern { unPartialPattern :: Maybe (DataPatternF PartialPattern) } deriving (Eq, Show) newtype PartialCore = PartialCore @@ -20,12 +20,12 @@ nonPartial :: Core -> PartialCore nonPartial = PartialCore . Just . mapCoreF Just nonPartialPattern nonPartial . unCore where - nonPartialPattern pat = PartialPattern $ Just $ nonPartialPattern <$> unConstructorPattern pat + nonPartialPattern pat = PartialPattern $ Just $ nonPartialPattern <$> unDataPattern pat runPartialCore :: PartialCore -> Maybe Core runPartialCore (PartialCore Nothing) = Nothing runPartialCore (PartialCore (Just c)) = Core <$> traverseCoreF id runPartialPattern runPartialCore c -runPartialPattern :: PartialPattern -> Maybe ConstructorPattern +runPartialPattern :: PartialPattern -> Maybe DataPattern runPartialPattern (PartialPattern Nothing) = Nothing -runPartialPattern (PartialPattern (Just p)) = ConstructorPattern <$> traverse runPartialPattern p +runPartialPattern (PartialPattern (Just p)) = DataPattern <$> traverse runPartialPattern p diff --git a/src/Pretty.hs b/src/Pretty.hs index 2f0016e7..465912f2 100644 --- a/src/Pretty.hs +++ b/src/Pretty.hs @@ -215,10 +215,10 @@ instance PrettyBinder VarInfo TypePattern where 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 DataPattern where + ppBind env pat = ppBind env (unDataPattern pat) -instance PrettyBinder VarInfo a => PrettyBinder VarInfo (ConstructorPatternF a) where +instance PrettyBinder VarInfo a => PrettyBinder VarInfo (DataPatternF a) where ppBind env (DataCtorPattern ctor subPats) = case subPats of [] -> (pp env ctor, Env.empty) diff --git a/src/SplitCore.hs b/src/SplitCore.hs index a66c94ad..5159807b 100644 --- a/src/SplitCore.hs +++ b/src/SplitCore.hs @@ -98,7 +98,7 @@ newTypeCtorPtr = TypeCtorPtr <$> newUnique data SplitCore = SplitCore { _splitCoreRoot :: SplitCorePtr , _splitCoreDescendants :: Store SplitCorePtr (CoreF TypePatternPtr PatternPtr SplitCorePtr) - , _splitCorePatterns :: Store PatternPtr (ConstructorPatternF PatternPtr) + , _splitCorePatterns :: Store PatternPtr (DataPatternF PatternPtr) , _splitCoreTypePatterns :: Store TypePatternPtr TypePattern } makeLenses ''SplitCore @@ -130,7 +130,7 @@ split partialCore = do SplitCorePtr -> Maybe (CoreF (Maybe TypePattern) PartialPattern PartialCore) -> WriterT (Store SplitCorePtr (CoreF TypePatternPtr PatternPtr SplitCorePtr), - Store PatternPtr (ConstructorPatternF PatternPtr), + Store PatternPtr (DataPatternF PatternPtr), Store TypePatternPtr TypePattern) IO () @@ -148,7 +148,7 @@ split partialCore = do PartialPattern -> WriterT (Store SplitCorePtr (CoreF TypePatternPtr PatternPtr SplitCorePtr), - Store PatternPtr (ConstructorPatternF PatternPtr), + Store PatternPtr (DataPatternF PatternPtr), Store TypePatternPtr TypePattern) IO PatternPtr @@ -163,7 +163,7 @@ split partialCore = do Maybe TypePattern -> WriterT (Store SplitCorePtr (CoreF TypePatternPtr PatternPtr SplitCorePtr), - Store PatternPtr (ConstructorPatternF PatternPtr), + Store PatternPtr (DataPatternF PatternPtr), Store TypePatternPtr TypePattern) IO TypePatternPtr diff --git a/tests/Test.hs b/tests/Test.hs index 29f12e90..56b78b37 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -608,8 +608,8 @@ genSyntaxError subgen = <*> subgen genLam :: - (CoreF TypePattern ConstructorPattern Bool -> GenT IO a) -> - GenT IO (CoreF TypePattern ConstructorPattern a) + (CoreF TypePattern DataPattern Bool -> GenT IO a) -> + GenT IO (CoreF TypePattern DataPattern a) genLam subgen = do ident <- Gen.generalize genIdent var <- genVar @@ -621,21 +621,21 @@ genLam subgen = do -- which subtree of 'CoreF' they're being asked to generate. genCoreF :: forall a. - (Maybe (GenT IO Var) -> CoreF TypePattern ConstructorPattern Bool -> + (Maybe (GenT IO Var) -> CoreF TypePattern DataPattern Bool -> GenT IO a) {- ^ Generic sub-generator -} -> Maybe (GenT IO Var) {- ^ Variable generator -} -> - GenT IO (CoreF TypePattern ConstructorPattern a) + GenT IO (CoreF TypePattern DataPattern a) genCoreF subgen varGen = let sameVars = subgen varGen -- A unary constructor with no binding unary :: - (forall b. b -> CoreF TypePattern ConstructorPattern b) -> - GenT IO (CoreF TypePattern ConstructorPattern a) + (forall b. b -> CoreF TypePattern DataPattern b) -> + GenT IO (CoreF TypePattern DataPattern a) unary constructor = constructor <$> sameVars (constructor True) -- A binary constructor with no binding binary :: - (forall b. b -> b -> CoreF TypePattern ConstructorPattern b) -> - GenT IO (CoreF TypePattern ConstructorPattern a) + (forall b. b -> b -> CoreF TypePattern DataPattern b) -> + GenT IO (CoreF TypePattern DataPattern a) binary constructor = constructor <$> sameVars (constructor True False) @@ -653,7 +653,7 @@ genCoreF subgen varGen = -- , CoreIdentEq _ <$> sameVars <*> sameVars -- , CoreSyntax Syntax -- , CoreCase sameVars [(Pattern, core)] - -- , CoreDataCase core [(ConstructorPattern, core)] + -- , CoreDataCase core [(DataPattern, core)] -- , CoreIdent (ScopedIdent core) -- , CoreEmpty (ScopedEmpty core) -- , CoreCons (ScopedCons core) From 5bcc813a7fd2ed80a4872727989770c69d8b2d29 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20G=C3=A9lineau?= Date: Fri, 31 May 2024 08:40:44 -0400 Subject: [PATCH 13/15] remove unused evalErrorText --- src/Evaluator.hs | 11 ----------- 1 file changed, 11 deletions(-) diff --git a/src/Evaluator.hs b/src/Evaluator.hs index eccd6799..5a1a3f8d 100644 --- a/src/Evaluator.hs +++ b/src/Evaluator.hs @@ -17,7 +17,6 @@ import qualified Data.Text as T import Core import Env -import ShortShow import Syntax import Syntax.SrcLoc import Type @@ -41,16 +40,6 @@ data EvalError deriving (Show) makePrisms ''EvalError -evalErrorText :: EvalError -> Text -evalErrorText (EvalErrorUnbound x) = "Unbound: " <> T.pack (show x) -evalErrorText (EvalErrorType (TypeError expected got)) = - "Wrong type. Expected a " <> expected <> " but got a " <> got -evalErrorText (EvalErrorCase loc val) = - "Didn't match any pattern at " <> T.pack (shortShow loc) <> ": " <> valueText val -evalErrorText (EvalErrorUser what) = - T.pack (shortShow (stxLoc what)) <> ":\n\t" <> - syntaxText what - newtype Eval a = Eval { runEval :: ReaderT VEnv (ExceptT EvalError IO) a } deriving (Functor, Applicative, Monad, From 0f2f598275b17dac186fcf132355389b28e8ca56 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20G=C3=A9lineau?= Date: Sat, 1 Jun 2024 13:36:49 -0400 Subject: [PATCH 14/15] [WIP] drop ShortShow --- src/Binding.hs | 4 - src/Binding/Info.hs | 7 -- src/Core.hs | 225 ------------------------------------- src/Datatype.hs | 3 - src/Expander.hs | 1 - src/Expander/Monad.hs | 1 - src/Expander/Primitives.hs | 1 - src/Expander/Task.hs | 32 ------ src/ModuleName.hs | 6 - src/Phase.hs | 5 - src/Pretty.hs | 70 ++++++++++++ src/ScopeSet.hs | 5 - src/ShortShow.hs | 38 ------- src/Syntax/SrcLoc.hs | 10 -- src/Syntax/Syntax.hs | 13 --- src/Type.hs | 4 - tests/Test.hs | 1 - 17 files changed, 70 insertions(+), 356 deletions(-) diff --git a/src/Binding.hs b/src/Binding.hs index 25bf4104..b283d2aa 100644 --- a/src/Binding.hs +++ b/src/Binding.hs @@ -16,7 +16,6 @@ import Data.Sequence (Seq) import Binding.Info import Phase -import ShortShow import Syntax.SrcLoc import Unique @@ -35,9 +34,6 @@ instance HasKey Binding where instance Show Binding where show (Binding b) = "(Binding " ++ show (hashUnique b) ++ ")" -instance ShortShow Binding where - shortShow (Binding b) = "b" ++ show (hashUnique b) - newtype BindingTable = BindingTable { _bindings :: HashMap Text (Seq (ScopeSet, Binding, BindingInfo SrcLoc)) } deriving (Data, Show) makeLenses ''BindingTable diff --git a/src/Binding/Info.hs b/src/Binding/Info.hs index bcd5fc8d..bfee3176 100644 --- a/src/Binding/Info.hs +++ b/src/Binding/Info.hs @@ -4,8 +4,6 @@ module Binding.Info where import Data.Data (Data) -import ShortShow - data BindingInfo loc = BoundLocally loc | Defined loc @@ -13,8 +11,3 @@ data BindingInfo loc -- enable go to definition | Imported loc deriving (Data, Eq, Functor, Show) - -instance ShortShow loc => ShortShow (BindingInfo loc) where - shortShow (BoundLocally l) = "BoundLocally " ++ shortShow l - shortShow (Defined l) = "Defined " ++ shortShow l - shortShow (Imported l) = "Imported " ++ shortShow l diff --git a/src/Core.hs b/src/Core.hs index 16ae2298..37ef8fd0 100644 --- a/src/Core.hs +++ b/src/Core.hs @@ -31,7 +31,6 @@ import Alpha import Datatype import ModuleName import Phase -import ShortShow import Syntax import Syntax.SrcLoc import Type @@ -453,227 +452,3 @@ instance AlphaEq core => AlphaEq (ScopedList core) where (ScopedList elements2 scope2) = do alphaCheck elements1 elements2 alphaCheck scope1 scope2 - - -instance ShortShow a => ShortShow (SyntaxError a) where - shortShow (SyntaxError locations message) - = "(SyntaxError " - ++ shortShow locations - ++ " " - ++ shortShow message - ++ ")" - -instance ShortShow Var where - shortShow (Var x) = shortShow x - -instance (ShortShow typePat, ShortShow pat, ShortShow core) => - ShortShow (CoreF typePat pat core) where - shortShow (CoreVar var) - = "(Var " - ++ shortShow var - ++ ")" - shortShow (CoreLet _ x def body) - = "(Let " - ++ shortShow x - ++ " " - ++ shortShow def - ++ " " - ++ shortShow body - ++ ")" - shortShow (CoreLetFun _ f _ x def body) - = "(LetFun " - ++ shortShow f - ++ " " - ++ shortShow x - ++ " " - ++ shortShow def - ++ " " - ++ shortShow body - ++ ")" - shortShow (CoreLam _ x body) - = "(Lam " - ++ shortShow x - ++ " " - ++ shortShow body - ++ ")" - shortShow (CoreApp fun arg) - = "(App " - ++ shortShow fun - ++ " " - ++ shortShow arg - ++ ")" - shortShow (CoreCtor ctor args) - = "(Ctor " - ++ shortShow ctor - ++ " " - ++ shortShow args - ++ ")" - shortShow (CoreDataCase _ scrut cases) - = "(DataCase " - ++ shortShow scrut - ++ " " - ++ intercalate ", " (map shortShow cases) - ++ ")" - shortShow (CoreInteger i) - = show i - shortShow (CoreString str) - = "(String " ++ show str ++ ")" - shortShow (CoreError what) - = "(Error " - ++ shortShow what - ++ ")" - shortShow (CorePureMacro x) - = "(PureMacro " - ++ shortShow x - ++ ")" - shortShow (CoreBindMacro hd tl) - = "(BindMacro " - ++ shortShow hd - ++ " " - ++ shortShow tl - ++ ")" - shortShow (CoreSyntaxError syntaxError) - = "(SyntaxError " - ++ shortShow syntaxError - ++ ")" - shortShow (CoreIdentEq how e1 e2) - = "(CoreIdentEq " ++ show how - ++ " " ++ shortShow e1 - ++ " " ++ shortShow e2 ++ ")" - shortShow (CoreLog msg) - = "(CoreLog " ++ shortShow msg ++ ")" - shortShow CoreMakeIntroducer - = "(CoreMakeIntroducer)" - shortShow CoreWhichProblem - = "(CoreWhichProblem)" - shortShow (CoreSyntax syntax) - = "(Syntax " - ++ shortShow syntax - ++ ")" - shortShow (CoreCase _ scrutinee cases) - = "(Case " - ++ shortShow scrutinee - ++ " " - ++ shortShow cases - ++ ")" - shortShow (CoreIdent scopedIdent) - = "(Ident " - ++ shortShow scopedIdent - ++ ")" - shortShow (CoreEmpty scopedEmpty) - = "(Empty " - ++ shortShow scopedEmpty - ++ ")" - shortShow (CoreCons scopedCons) - = "(Cons " - ++ shortShow scopedCons - ++ ")" - shortShow (CoreList scopedVec) - = "(List " - ++ shortShow scopedVec - ++ ")" - shortShow (CoreIntegerSyntax scopedStr) - = "(IntegerSyntax " - ++ shortShow scopedStr - ++ ")" - shortShow (CoreStringSyntax scopedStr) - = "(StringSyntax " - ++ shortShow scopedStr - ++ ")" - shortShow (CoreReplaceLoc loc stx) - = "(ReplaceLoc " - ++ shortShow loc ++ " " - ++ shortShow stx ++ ")" - shortShow (CoreTypeCase _ scrut pats) - = "(TypeCase " - ++ shortShow scrut - ++ " " - ++ intercalate ", " (map shortShow pats) - ++ ")" - - -instance ShortShow Core where - shortShow (Core x) = shortShow x - -instance ShortShow DataPattern where - shortShow = shortShow . unDataPattern - -instance ShortShow a => ShortShow (DataPatternF a) where - shortShow (DataCtorPattern ctor vars) = - "(" ++ shortShow ctor ++ - " " ++ intercalate " " (map shortShow vars) ++ - ")" - shortShow (PatternVar ident _var) = - "(PatternVar " ++ shortShow ident ++ " )" - -instance ShortShow TypePattern where - shortShow (TypeCtorPattern t) = - "(" ++ shortShow (fmap fst t) ++ ")" - shortShow (TypePatternVar ident _var) = - "(TypePatternVar " ++ shortShow ident ++ " )" - - -instance ShortShow SyntaxPattern where - shortShow (SyntaxPatternIdentifier _ x) = shortShow x - shortShow (SyntaxPatternInteger _ x) = "(Integer " ++ shortShow x ++ ")" - shortShow (SyntaxPatternString _ x) = "(String " ++ shortShow x ++ ")" - shortShow SyntaxPatternEmpty = "Empty" - shortShow (SyntaxPatternCons _ x _ xs) - = "(Cons " - ++ shortShow x - ++ " " - ++ shortShow xs - ++ ")" - shortShow (SyntaxPatternList xs) - = "(List " - ++ shortShow (map snd xs) - ++ ")" - shortShow SyntaxPatternAny = "_" - -instance ShortShow core => ShortShow (ScopedIdent core) where - shortShow (ScopedIdent ident scope) - = "(ScopedIdent " - ++ shortShow ident - ++ " " - ++ shortShow scope - ++ ")" - -instance ShortShow core => ShortShow (ScopedEmpty core) where - shortShow (ScopedEmpty scope) - = "(ScopedEmpty " - ++ shortShow scope - ++ ")" - -instance ShortShow core => ShortShow (ScopedCons core) where - shortShow (ScopedCons hd tl scope) - = "(ScopedCons " - ++ shortShow hd - ++ " " - ++ shortShow tl - ++ " " - ++ shortShow scope - ++ ")" - -instance ShortShow core => ShortShow (ScopedList core) where - shortShow (ScopedList elements scope) - = "(ScopedList " - ++ shortShow elements - ++ " " - ++ shortShow scope - ++ ")" - -instance ShortShow core => ShortShow (ScopedInteger core) where - shortShow (ScopedInteger str scope) - = "(ScopedInteger " - ++ shortShow str - ++ " " - ++ shortShow scope - ++ ")" - -instance ShortShow core => ShortShow (ScopedString core) where - shortShow (ScopedString str scope) - = "(ScopedString " - ++ shortShow str - ++ " " - ++ shortShow scope - ++ ")" diff --git a/src/Datatype.hs b/src/Datatype.hs index a54d1c0e..4cf110aa 100644 --- a/src/Datatype.hs +++ b/src/Datatype.hs @@ -14,7 +14,6 @@ import Data.Hashable import Alpha import Kind import ModuleName -import ShortShow import GHC.Generics (Generic) newtype DatatypeName = DatatypeName { _datatypeNameText :: Text } @@ -46,8 +45,6 @@ data Constructor makeLenses ''Constructor instance Hashable Constructor -instance ShortShow Constructor where - shortShow = show instance AlphaEq Constructor where alphaCheck c1 c2 diff --git a/src/Expander.hs b/src/Expander.hs index ee7aeed3..4862a931 100644 --- a/src/Expander.hs +++ b/src/Expander.hs @@ -81,7 +81,6 @@ import Parser import Phase import Pretty import ScopeSet (ScopeSet) -import ShortShow import SplitCore import SplitType import Syntax diff --git a/src/Expander/Monad.hs b/src/Expander/Monad.hs index f850b517..3a56599f 100644 --- a/src/Expander/Monad.hs +++ b/src/Expander/Monad.hs @@ -188,7 +188,6 @@ import KlisterPath import PartialCore import PartialType import Phase -import ShortShow import SplitCore import SplitType import Scope diff --git a/src/Expander/Primitives.hs b/src/Expander/Primitives.hs index c059fdea..1f1d0cb7 100644 --- a/src/Expander/Primitives.hs +++ b/src/Expander/Primitives.hs @@ -96,7 +96,6 @@ import Phase import Scope import ScopeSet (ScopeSet) import qualified ScopeSet -import ShortShow import SplitCore import SplitType import Syntax diff --git a/src/Expander/Task.hs b/src/Expander/Task.hs index 49bda6fa..eb60183e 100644 --- a/src/Expander/Task.hs +++ b/src/Expander/Task.hs @@ -2,8 +2,6 @@ {-# LANGUAGE OverloadedStrings #-} module Expander.Task where -import qualified Data.Text as T - import Binding import Core import Datatype @@ -11,9 +9,7 @@ import Expander.DeclScope import Kind import Module import Phase -import Pretty import ScopeSet -import ShortShow import SplitCore import SplitType import Syntax @@ -85,31 +81,3 @@ data TaskAwaitMacroType = TaskAwaitMacroType , awaitMacroTypeSyntax :: Syntax -- the syntax object to be expanded once the macro is available } deriving (Show) - - -instance ShortShow TaskAwaitMacro where - shortShow (TaskAwaitMacro _ _ x deps _ stx) = - "(TaskAwaitMacro " ++ show x ++ " " ++ show deps ++ " " ++ T.unpack (pretty stx) ++ ")" - -instance ShortShow TaskAwaitMacroType where - shortShow = show - -instance ShortShow ExpanderTask where - shortShow (ExpandSyntax _dest stx) = "(ExpandSyntax " ++ T.unpack (pretty stx) ++ ")" - shortShow (AwaitingTypeCase loc _ _ _ _ _) = "(AwaitingTypeCase " ++ shortShow loc ++ "_)" - shortShow (AwaitingDefn _x n _b _defn _t _dest stx) = - "(AwaitingDefn " ++ shortShow n ++ " " ++ shortShow stx ++ ")" - shortShow (AwaitingMacro dest t) = "(AwaitingMacro " ++ show dest ++ " " ++ shortShow t ++ ")" - shortShow (AwaitingType tdest tasks) = "(AwaitingType " ++ show tdest ++ " " ++ show tasks ++ ")" - shortShow (ExpandDeclForms _dest _scs waitingOn outScopesDest stx) = "(ExpandDeclForms _ " ++ show waitingOn ++ " " ++ show outScopesDest ++ " " ++ T.unpack (syntaxText stx) ++ ")" - shortShow (InterpretMacroAction _dest act kont) = "(InterpretMacroAction " ++ show act ++ " " ++ show kont ++ ")" - shortShow (ContinueMacroAction _dest value kont) = "(ContinueMacroAction " ++ show value ++ " " ++ show kont ++ ")" - shortShow (EvalDefnAction var name phase _expr) = "(EvalDefnAction " ++ show var ++ " " ++ shortShow name ++ " " ++ show phase ++ ")" - shortShow (GeneralizeType e _ _) = "(GeneralizeType " ++ show e ++ " _ _)" - shortShow (ExpandVar t d x v) = "(ExpandVar " ++ show t ++ " " ++ show d ++ " " ++ show x ++ " " ++ show v ++ ")" - shortShow (EstablishConstructors _ _ dt _) = "(EstablishConstructors " ++ show dt ++ ")" - shortShow (AwaitingPattern _ _ _ _) = "(AwaitingPattern _ _ _ _)" - shortShow (AwaitingTypePattern _ _ _ _) = "(AwaitingTypePattern _ _ _ _)" - -instance Pretty VarInfo ExpanderTask where - pp _ task = string (shortShow task) diff --git a/src/ModuleName.hs b/src/ModuleName.hs index 16bbc9a4..6eb409f1 100644 --- a/src/ModuleName.hs +++ b/src/ModuleName.hs @@ -20,8 +20,6 @@ import System.FilePath import Data.Hashable import GHC.Generics (Generic) -import ShortShow - newtype KernelName = Kernel () deriving (Data, Eq, Ord, Show, Generic) @@ -35,10 +33,6 @@ data ModuleName = ModuleName FilePath | KernelName KernelName instance Hashable ModuleName -instance ShortShow ModuleName where - shortShow (ModuleName x) = x - shortShow (KernelName _k) = "kernel" - moduleNameFromPath :: FilePath -> IO ModuleName moduleNameFromPath file = ModuleName <$> canonicalizePath file diff --git a/src/Phase.hs b/src/Phase.hs index c6f3a894..abe038b4 100644 --- a/src/Phase.hs +++ b/src/Phase.hs @@ -10,8 +10,6 @@ import Data.Data (Data) import Data.Sequence (Seq) import Numeric.Natural -import ShortShow - import Util.Key newtype Phase = Phase { phaseNum :: Natural } @@ -25,9 +23,6 @@ instance HasKey Phase where {-# INLINE getKey #-} {-# INLINE fromKey #-} -instance ShortShow Phase where - shortShow (Phase i) = "p" ++ show i - runtime :: Phase runtime = Phase 0 diff --git a/src/Pretty.hs b/src/Pretty.hs index 465912f2..547e0a3e 100644 --- a/src/Pretty.hs +++ b/src/Pretty.hs @@ -26,6 +26,7 @@ import Binding.Info import Core import Datatype import Env +import Expander.Task import Evaluator (EvalResult(..), EvalError(..), TypeError(..)) import Kind import Module @@ -34,6 +35,7 @@ import KlisterPath import Phase import Scope import ScopeSet +import SplitCore import Syntax import Syntax.SrcLoc import Type @@ -674,3 +676,71 @@ instance Pretty VarInfo ScopeSet where instance Pretty VarInfo KlisterPathError where pp _ = ppKlisterPathError + + +instance Pretty VarInfo TaskAwaitMacro where + pp env (TaskAwaitMacro _ _ x deps _ stx) = + "(TaskAwaitMacro" <+> + pp env x <+> + vec (hsep $ map (pp env) deps) <+> + pp env stx <> + ")" + +instance Pretty VarInfo TaskAwaitMacroType where + pp env (TaskAwaitMacroType _ _ x _ stx) = + "(TaskAwaitMacroType" <+> pp env x <+> pp env stx <> ")" + +instance Pretty VarInfo ExpanderTask where + pp env (ExpandSyntax _dest stx) = + "(ExpandSyntax" <+> pp env stx <> ")" + pp env (AwaitingTypeCase loc _ _ _ _ _) = + "(AwaitingTypeCase" <+> pp env loc <+> "_)" + pp env (AwaitingDefn _x n _b _defn _t _dest stx) = + "(AwaitingDefn" <+> pp env n <+> pp env stx <> ")" + pp env (AwaitingMacro dest t) = + "(AwaitingMacro" <+> pp env dest <+> pp env t <> ")" + pp env (AwaitingType tdest tasks) = + "(AwaitingType" <+> pp env tdest <+> + vec (hsep $ map (pp env) tasks) <> + ")" + pp env (ExpandDeclForms _dest _scs waitingOn outScopesDest stx) = + "(ExpandDeclForms _" <+> pp env waitingOn <+> pp env outScopesDest <+> pp env stx <> ")" + pp env (InterpretMacroAction _dest act konts) = + "(InterpretMacroAction" <+> + pp env act <+> + vec (hsep $ map (pp env) konts) <> + ")" + pp env (ContinueMacroAction _dest value konts) = + "(ContinueMacroAction" <+> + pp env value <+> + vec (hsep $ map (pp env) konts) <> + ")" + pp env (EvalDefnAction var name phase _expr) = + "(EvalDefnAction" <+> pp env var <+> pp env name <+> pp env phase <> ")" + pp env (GeneralizeType e _ _) = + "(GeneralizeType" <+> pp env e <+> "_ _)" + pp env (ExpandVar t d x v) = + "(ExpandVar" <+> pp env t <+> pp env d <+> pp env x <+> pp env v <> ")" + pp env (EstablishConstructors _ _ dt _) = + "(EstablishConstructors" <+> pp env dt <> ")" + pp env (AwaitingPattern _ _ _ _) = + "(AwaitingPattern _)" + pp env (AwaitingTypePattern _ _ _ _) = + "(AwaitingTypePattern _)" + +-- SplitCorePtr +-- PatternPtr +-- TypePatternPtr +-- TypeCtorPtr + +instance Pretty VarInfo SplitCorePtr where + pp _ = viaShow + +instance Pretty VarInfo PatternPtr where + pp _ = viaShow + +instance Pretty VarInfo TypePatternPtr where + pp _ = viaShow + +instance Pretty VarInfo TypeCtorPtr where + pp _ = viaShow diff --git a/src/ScopeSet.hs b/src/ScopeSet.hs index c63f4d12..ddf4b53c 100644 --- a/src/ScopeSet.hs +++ b/src/ScopeSet.hs @@ -38,7 +38,6 @@ import Data.Typeable import Alpha import Phase import Scope -import ShortShow import Util.Store (Store) import qualified Util.Store as St @@ -53,10 +52,6 @@ data ScopeSet = ScopeSet deriving (Data, Eq, Ord, Show) makeLenses ''ScopeSet -instance ShortShow ScopeSet where - shortShow (ScopeSet always phased) = - "{" ++ show (Set.toList always) ++ " | " ++ show (St.toList phased) ++ "}" - instance Semigroup ScopeSet where scs1 <> scs2 = ScopeSet diff --git a/src/ShortShow.hs b/src/ShortShow.hs index 07a5419d..927edcab 100644 --- a/src/ShortShow.hs +++ b/src/ShortShow.hs @@ -1,39 +1 @@ module ShortShow where - -import Data.Text -import qualified Data.List as List - -import Unique - - -class ShortShow a where - shortShow :: a -> String - -instance ShortShow Text where - shortShow = show - -instance ShortShow Unique where - shortShow = show . hashUnique - -instance (ShortShow a, ShortShow b) => ShortShow (a, b) where - shortShow (x, y) - = "(" - ++ shortShow x - ++ ", " - ++ shortShow y - ++ ")" -instance (ShortShow a, ShortShow b, ShortShow c) => ShortShow (a, b, c) where - shortShow (x, y, z) - = "(" - ++ shortShow x - ++ ", " - ++ shortShow y - ++ ", " - ++ shortShow z - ++ ")" - -instance ShortShow a => ShortShow [a] where - shortShow xs - = "[" - ++ List.intercalate ", " (fmap shortShow xs) - ++ "]" diff --git a/src/Syntax/SrcLoc.hs b/src/Syntax/SrcLoc.hs index 9b7ea309..73168372 100644 --- a/src/Syntax/SrcLoc.hs +++ b/src/Syntax/SrcLoc.hs @@ -7,7 +7,6 @@ import Control.Lens import Data.Data (Data) import Alpha -import ShortShow data SrcPos = SrcPos { _srcPosLine :: !Int @@ -16,9 +15,6 @@ data SrcPos = SrcPos deriving (Data, Eq, Show) makeLenses ''SrcPos -instance ShortShow SrcPos where - shortShow (SrcPos l c) = show l ++ "." ++ show c - data SrcLoc = SrcLoc { _srcLocFilePath :: !FilePath , _srcLocStart :: !SrcPos @@ -29,9 +25,3 @@ makeLenses ''SrcLoc instance AlphaEq SrcLoc where alphaCheck x y = guard (x == y) - -instance ShortShow SrcLoc where - shortShow (SrcLoc fn beg end) = - reverse (take 10 (reverse fn)) ++ ":" ++ - shortShow beg ++ "-" ++ - shortShow end diff --git a/src/Syntax/Syntax.hs b/src/Syntax/Syntax.hs index b447e613..5bc193ba 100644 --- a/src/Syntax/Syntax.hs +++ b/src/Syntax/Syntax.hs @@ -20,7 +20,6 @@ import ModuleName import Phase import Scope import ScopeSet -import ShortShow import Syntax.SrcLoc import qualified Util.Set as Set @@ -109,18 +108,6 @@ instance AlphaEq Syntax where alphaCheck x1 x2 -instance ShortShow a => ShortShow (Stx a) where - shortShow (Stx _ _ x) = shortShow x - -instance ShortShow a => ShortShow (ExprF a) where - shortShow (Id x) = shortShow x - shortShow (String s) = show s - shortShow (List xs) = shortShow xs - shortShow (Integer s) = show s - -instance ShortShow Syntax where - shortShow (Syntax x) = shortShow x - addScopes' :: HasScopes p => ScopeSet -> p -> p #ifndef KDEBUG addScopes' scopeSet = mapScopes (over phaseScopes newSpecificScopes diff --git a/src/Type.hs b/src/Type.hs index cc5d377f..0ffb4e00 100644 --- a/src/Type.hs +++ b/src/Type.hs @@ -20,7 +20,6 @@ import Numeric.Natural import Alpha import Datatype import Kind -import ShortShow import Unique import Util.Key @@ -101,9 +100,6 @@ instance AlphaEq a => AlphaEq (TyF a) where guard (length args1 == length args2) for_ (zip args1 args2) (uncurry alphaCheck) -instance ShortShow a => ShortShow (TyF a) where - shortShow t = show (fmap shortShow t) - class TyLike a arg | a -> arg where tSyntax :: a diff --git a/tests/Test.hs b/tests/Test.hs index 56b78b37..b6ba8d13 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -46,7 +46,6 @@ import Pretty import Scope import qualified ScopeSet import ScopeSet (ScopeSet) -import ShortShow import SplitCore import Syntax.SrcLoc import Syntax From f21e77782ccbff7ce3d0f9c046a8c68fd9bcfc13 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20G=C3=A9lineau?= Date: Sat, 1 Jun 2024 15:44:58 -0400 Subject: [PATCH 15/15] [WIP] test command: ghcid --test=':set -XOverloadedStrings' --test='ShortShow.shortShow $ Core.Core $ Core.CoreDataCase (Syntax.SrcLoc.SrcLoc "" (Syntax.SrcLoc.SrcPos 0 0) (Syntax.SrcLoc.SrcPos 0 0)) (Core.Core $ Core.CoreInteger 42) [(Core.DataPattern $ Core.DataCtorPattern (Datatype.Constructor (ModuleName.KernelName ModuleName.kernelName) "just") [], Core.Core $ Core.CoreInteger 42)]'