From 999c03b53aff0c491979a14a4873217d890e259d Mon Sep 17 00:00:00 2001 From: doyougnu Date: Sun, 7 Apr 2024 11:35:01 -0400 Subject: [PATCH 01/23] wrk: simplify --- repl/Main.hs | 14 +++++++------- src/Evaluator.hs | 3 ++- 2 files changed, 9 insertions(+), 8 deletions(-) diff --git a/repl/Main.hs b/repl/Main.hs index 319a0309..c2557856 100644 --- a/repl/Main.hs +++ b/repl/Main.hs @@ -33,12 +33,12 @@ import Syntax import Value import World -data Options = Options { optCommand :: CLICommand } -data RunOptions = RunOptions { runOptFile :: FilePath - , runOptWorld :: Bool +newtype Options = Options { optCommand :: CLICommand } +data RunOptions = RunOptions { runOptFile :: FilePath + , runOptWorld :: Bool , runOptBindingInfo :: Bool } -data ReplOptions = ReplOptions { replOptFile :: Maybe FilePath } +newtype ReplOptions = ReplOptions { replOptFile :: Maybe FilePath } data CLICommand = Run RunOptions @@ -63,8 +63,8 @@ main = do replOptions = Repl . ReplOptions <$> optional fileArg parser = Options <$> subparser - ( (command "run" (info runOptions (progDesc "Run a file"))) - <> (command "repl" (info replOptions (progDesc "Use the REPL"))) + ( command "run" (info runOptions (progDesc "Run a file")) + <> command "repl" (info replOptions (progDesc "Use the REPL")) ) opts = info parser mempty @@ -147,5 +147,5 @@ repl ctx startWorld = do putStrLn "" currentWorld <- readIORef theWorld case evaluateIn (phaseEnv runtime currentWorld) expr of - Left evalErr -> print $ erroneousValue $ projectError evalErr + Left evalErr -> print evalErr Right val -> prettyPrintLn val diff --git a/src/Evaluator.hs b/src/Evaluator.hs index 0766190d..fe29d509 100644 --- a/src/Evaluator.hs +++ b/src/Evaluator.hs @@ -164,9 +164,9 @@ data Kont where InLog :: !VEnv -> !Kont -> Kont InError :: !VEnv -> !Kont -> Kont - InSyntaxErrorMessage :: ![Core] -> !VEnv -> !Kont -> Kont InSyntaxErrorLocations :: !Syntax -> ![Core] -> ![Syntax] -> !VEnv -> !Kont -> Kont + deriving Show -- | The state of the evaluator data EState where @@ -178,6 +178,7 @@ data EState where -- returning a value up the stack Er :: !EvalError -> !VEnv -> !Kont -> EState -- ^ 'Er', meaning that we are in an error state and running the debugger + deriving Show -- ----------------------------------------------------------------------------- From ec34f78085a55a6ca78450f4c99342358e3d1366 Mon Sep 17 00:00:00 2001 From: doyougnu Date: Sun, 2 Jun 2024 09:36:45 -0400 Subject: [PATCH 02/23] wrk: need to design --- klister.cabal | 2 ++ src/Debugger.hs | 38 ++++++++++++++++++++++++++++++++++++ src/Evaluator.hs | 45 ++++++++++++++++++++++++++++++++++--------- src/Expander/Monad.hs | 8 ++++---- src/Pretty.hs | 34 ++++++++++++++++++++++++++++++-- src/StackTraces.hs | 40 ++++++++++++++++++++++++++++++++++++++ 6 files changed, 152 insertions(+), 15 deletions(-) create mode 100644 src/Debugger.hs create mode 100644 src/StackTraces.hs diff --git a/klister.cabal b/klister.cabal index 323f6de6..1cb0ff5d 100644 --- a/klister.cabal +++ b/klister.cabal @@ -42,6 +42,7 @@ common deps megaparsec >= 7.0.5 && < 9.7, mtl >= 2.2.2 && < 2.4, prettyprinter >= 1.2 && < 1.8, + prettyprinter >= 1.2 && < 1.8, text >= 1.2, transformers ^>= 0.6 @@ -60,6 +61,7 @@ library Core Core.Builder Datatype + Debugger Env Evaluator Expander diff --git a/src/Debugger.hs b/src/Debugger.hs new file mode 100644 index 00000000..e98a50ad --- /dev/null +++ b/src/Debugger.hs @@ -0,0 +1,38 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Debugger +-- Copyright : (c) Jeffrey M. Young +-- Samuel Gélineau +-- David Thrane Christiansen +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young +-- Samuel Gélineau +-- David Christiansen +-- Stability : experimental +-- +-- A Common Lisp style Debugger for klister. +----------------------------------------------------------------------------- + + +module Debugger + ( enterDebugger + ) where + + +-- ----------------------------------------------------------------------------- +-- Types + +newtype Debug a = Debug + { runDebug :: ReaderT DebugContext (ExceptT ExpansionErr IO) a + } + deriving ( Functor, Applicative, Monad + , MonadError ExpansionErr + , MonadIO, MonadReader DebugContext + ) + +-- ----------------------------------------------------------------------------- +-- Top level API + +enterDebugger :: ExpansionErr -> EState -> Debug Value +enterDebugger exp_err st = undefined diff --git a/src/Evaluator.hs b/src/Evaluator.hs index fe29d509..324858f3 100644 --- a/src/Evaluator.hs +++ b/src/Evaluator.hs @@ -8,10 +8,27 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} +----------------------------------------------------------------------------- +-- | +-- Module : CEK Machine +-- Copyright : (c) Jeffrey M. Young +-- Samuel Gélineau +-- David Thrane Christiansen +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young +-- Samuel Gélineau +-- David Christiansen +-- Stability : experimental +-- +-- Converting state from the CEK machine to stack trace +----------------------------------------------------------------------------- + + {- Note [The CEK interpreter]: -The Klister interpreter is a straightforward implementation of a CEK -interpreter. The interpreter keeps three kinds of state: +The Klister interpreter is a straightforward implementation of a CEK machine. +The interpreter keeps three kinds of state: -- C: Control ::= The thing that is being evaluated -- E: Environment ::= The interpreter environment @@ -29,7 +46,7 @@ https://felleisen.org/matthias/4400-s20/lecture23.html The bird's eye view: -The evaluator crawl's the input AST and progresses in three modes: +The evaluator crawls the input AST and progresses in three modes: -- 'Down': meaning that the evaluator is searching for a redex to evaluate and -- therefore moving "down" the AST. @@ -50,18 +67,22 @@ allows the evaluator to know exactly what needs to happen in order to continue. module Evaluator ( EvalError (..) , EvalResult (..) + , EState (..) + , Kont (..) + , VEnv , TypeError (..) , evaluate , evaluateIn , evaluateWithExtendedEnv , evalErrorType , evalErrorText - , projectError , erroneousValue , applyInEnv , apply , doTypeCase , try + , projectError + , projectKont ) where import Control.Lens hiding (List, elements) @@ -80,6 +101,8 @@ import Syntax.SrcLoc import Type import Value +import Debug.Trace + -- ----------------------------------------------------------------------------- -- Interpreter Data Types @@ -659,11 +682,6 @@ evaluateWithExtendedEnv env exts = evaluateIn (inserter exts) where inserter = foldl' (\acc (n,x,v) -> Env.insert x n v acc) env --- TODO DYG: Move to separate module -projectError :: EState -> EvalError -projectError (Er err _env _k) = err -projectError _ = error "debugger: impossible" - erroneousValue :: EvalError -> Value erroneousValue (EvalErrorCase _loc v) = v erroneousValue (EvalErrorIdent v) = v @@ -671,3 +689,12 @@ erroneousValue _ = error $ mconcat [ "erroneousValue: " , "Evaluator concluded in an error that did not return a value" ] + +projectError :: EState -> EvalError +projectError (Er err _env _kont) = err +projectError _ = error "projectError not used on an error!" + +projectKont :: EState -> Kont +projectKont (Er _ _ k) = k +projectKont (Up _ _ k) = k +projectKont (Down _ _ k) = k diff --git a/src/Expander/Monad.hs b/src/Expander/Monad.hs index 62f7ce3c..511cfe19 100644 --- a/src/Expander/Monad.hs +++ b/src/Expander/Monad.hs @@ -864,11 +864,11 @@ clearTasks = modifyState $ set expanderTasks [] evalInCurrentPhase :: Core -> Expand Value evalInCurrentPhase evalAction = do env <- currentEnv - let out = evaluateIn env evalAction - case out of - Left err -> do + case evaluateIn env evalAction of + Left e_state -> do p <- currentPhase - throwError $ MacroEvaluationError p $ projectError err + throwError $ MacroEvaluationError p $ projectError e_state + liftIO $ putStrLn $ pretty e_state Right val -> return val currentTransformerEnv :: Expand TEnv diff --git a/src/Pretty.hs b/src/Pretty.hs index 86b409bd..d53adbae 100644 --- a/src/Pretty.hs +++ b/src/Pretty.hs @@ -6,7 +6,16 @@ {-# LANGUAGE ParallelListComp #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} -module Pretty (Doc, Pretty(..), string, text, viaShow, (<+>), (<>), align, hang, line, group, vsep, hsep, VarInfo(..), pretty, prettyPrint, prettyPrintLn, prettyEnv, prettyPrintEnv) where +module Pretty + ( Doc + , Pretty(..) + , string + , text + , viaShow + , (<+>), (<>), align, hang, line, group, vsep, hsep + , VarInfo(..) + , pretty, prettyPrint, prettyPrintLn, prettyEnv, prettyPrintEnv + ) where import Control.Lens hiding (List) import Control.Monad.State @@ -26,7 +35,7 @@ import Binding.Info import Core import Datatype import Env -import Evaluator (EvalResult(..), EvalError(..), TypeError(..)) +import Evaluator (EvalResult(..), EvalError(..), TypeError(..), Kont(..), EState(..)) import Kind import Module import ModuleName @@ -626,6 +635,7 @@ instance Pretty VarInfo EvalError where group $ hang 2 $ vsep [pp env loc <> ":", pp env msg] pp env (EvalErrorIdent v) = text "Attempt to bind identifier to non-value: " <+> pp env v + instance Pretty VarInfo EvalResult where pp env (ExampleResult loc valEnv coreExpr sch val) = let varEnv = fmap (const ()) valEnv @@ -675,3 +685,23 @@ instance Pretty VarInfo ScopeSet where instance Pretty VarInfo KlisterPathError where pp _ = ppKlisterPathError + +-- ----------------------------------------------------------------------------- +-- StackTraces + +newtype StackTrace = StackTrace { unStackTrace :: EState } + +instance Pretty VarInfo StackTrace where + pp env st = printStack env (unStackTrace st) + +printStack :: Env Var () -> EState -> Doc VarInfo +printStack e (Er err env k) = hang 2 $ pp e err + +-- printKont :: Kont -> Doc ann +-- printKont = align . vsep + +-- printErr :: EvalError -> Doc ann +-- printErr = pretty + +-- printEnv :: VEnv -> Doc ann +-- printEnv = pretty diff --git a/src/StackTraces.hs b/src/StackTraces.hs new file mode 100644 index 00000000..c646c2bd --- /dev/null +++ b/src/StackTraces.hs @@ -0,0 +1,40 @@ +----------------------------------------------------------------------------- +-- | +-- Module : StackTraces +-- Copyright : (c) David Thrane Christiansen +-- Samuel Gélineau +-- Jeffrey M. Young +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Jeffrey Young +-- Samuel Gélineau +-- David Christiansen +-- Stability : experimental +-- +-- Converting state from the CEK machine to stack trace +----------------------------------------------------------------------------- + + +module StackTraces where + +import Evaluator +import Pretty + + +-- ----------------------------------------------------------------------------- +-- Top level API + +type StackTrace = EState + +printStack :: StackTrace -> Doc ann +printStack (Er err env k) = hang 2 $ + printErr err + +printKont :: Kont -> Doc ann +printKont = align . vsep + +printErr :: EvalError -> Doc ann +printErr = pretty + +printEnv :: VEnv -> Doc ann +printEnv = pretty From be37a99d73724c1fe913e0c9ff66e6e5fe8a62a4 Mon Sep 17 00:00:00 2001 From: doyougnu Date: Sun, 18 Aug 2024 11:25:21 -0400 Subject: [PATCH 03/23] wrk: add debugger class and monad --- klister.cabal | 2 +- src/Debugger.hs | 85 +++++++++++++++++++++++++++++++++++++++++++------ 2 files changed, 76 insertions(+), 11 deletions(-) diff --git a/klister.cabal b/klister.cabal index 1cb0ff5d..27ed14f7 100644 --- a/klister.cabal +++ b/klister.cabal @@ -60,8 +60,8 @@ library Control.Lens.IORef Core Core.Builder - Datatype Debugger + Datatype Env Evaluator Expander diff --git a/src/Debugger.hs b/src/Debugger.hs index e98a50ad..ea481f56 100644 --- a/src/Debugger.hs +++ b/src/Debugger.hs @@ -1,3 +1,8 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ScopedTypeVariables #-} + ----------------------------------------------------------------------------- -- | -- Module : Debugger @@ -16,23 +21,83 @@ module Debugger - ( enterDebugger + ( -- enterDebugger ) where +import Evaluator + +import Data.Bifunctor +import Control.Monad.Reader (ReaderT, MonadReader) +import Control.Monad.IO.Class +import Control.Monad.Error.Class +import qualified Control.Monad.Reader as R + + -- ----------------------------------------------------------------------------- -- Types -newtype Debug a = Debug - { runDebug :: ReaderT DebugContext (ExceptT ExpansionErr IO) a - } - deriving ( Functor, Applicative, Monad - , MonadError ExpansionErr - , MonadIO, MonadReader DebugContext - ) +-- conceptually this is a ReaderT (DebugContext e) (ExceptT e) IO a but I've +-- just fused the transformers and to have more control over the monad instance +newtype Debug r e a = Debug { runDebugT :: r -> IO (Either e a) + } + +runDebug :: Debug r e a -> r -> IO (Either e a) +runDebug = runDebugT + +debugRunT :: r -> Debug r e a -> IO (Either e a) +debugRunT = flip runDebugT + +mapDebugT :: (a -> b) -> Debug r e a -> Debug r e b +mapDebugT f = Debug . fmap (fmap (second f)) . runDebugT + +instance Functor (Debug r e) where + fmap = mapDebugT + +instance Applicative (Debug r e) where + pure a = Debug $ const (return (Right a)) + Debug f <*> Debug v = Debug $ \rr -> do + mf <- f rr + case mf of + (Left fer) -> return (Left fer) + (Right k) -> do + mv <- v rr + case mv of + (Left ver) -> return (Left ver) + Right x -> return (Right (k x)) + +instance Monad (Debug r e) where + Debug m >>= f = Debug $ \r -> do + ma <- m r + case ma of + Left err -> return (Left err) + Right val -> fmap (debugRunT r) f val + +instance MonadIO (Debug r e) where + liftIO = Debug . const . fmap Right + +class (Monad io, MonadIO io) => MonadDebugger e io | io -> e where + -- conceptually this is throw + enter :: e -> m a + -- conceptually this is catch with a handler + catch :: m a -> (e -> m b) -> m b + + +data DebugContext e = DebugContext { _currentError :: Maybe e + , _stackTrace :: [EState] + } + deriving (Semigroup, Monoid) + +initialContext :: DebugContext e +initialContext = mempty + + +-- checkError :: Debug e (Maybe e) +-- checkError = R.asks _currentError + -- ----------------------------------------------------------------------------- -- Top level API -enterDebugger :: ExpansionErr -> EState -> Debug Value -enterDebugger exp_err st = undefined +-- enterDebugger :: ExpansionErr -> EState -> Debug Value +-- enterDebugger exp_err st = From 7a02cd83e7224b7c09514dc7dce5faddcbfad6d2 Mon Sep 17 00:00:00 2001 From: doyougnu Date: Sun, 18 Aug 2024 16:12:48 -0400 Subject: [PATCH 04/23] wrk: add instances to debugger class --- src/Debugger.hs | 57 +++++++++++++++++++++++++++---------------------- 1 file changed, 32 insertions(+), 25 deletions(-) diff --git a/src/Debugger.hs b/src/Debugger.hs index ea481f56..47b7e010 100644 --- a/src/Debugger.hs +++ b/src/Debugger.hs @@ -1,7 +1,8 @@ -{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | @@ -20,36 +21,33 @@ ----------------------------------------------------------------------------- -module Debugger - ( -- enterDebugger - ) where +module Debugger where + -- DYG explicit export list import Evaluator import Data.Bifunctor -import Control.Monad.Reader (ReaderT, MonadReader) import Control.Monad.IO.Class -import Control.Monad.Error.Class -import qualified Control.Monad.Reader as R - - - +import Control.Monad.Trans.Class +import Control.Monad.Trans.Reader (ReaderT) +import qualified Control.Monad.Trans.Reader as Reader -- ----------------------------------------------------------------------------- -- Types + -- conceptually this is a ReaderT (DebugContext e) (ExceptT e) IO a but I've -- just fused the transformers and to have more control over the monad instance -newtype Debug r e a = Debug { runDebugT :: r -> IO (Either e a) - } - -runDebug :: Debug r e a -> r -> IO (Either e a) -runDebug = runDebugT +newtype Debug r e a = Debug { runDebug :: r -> IO (Either e a) + } debugRunT :: r -> Debug r e a -> IO (Either e a) -debugRunT = flip runDebugT +debugRunT = flip runDebug mapDebugT :: (a -> b) -> Debug r e a -> Debug r e b -mapDebugT f = Debug . fmap (fmap (second f)) . runDebugT +mapDebugT f = Debug . fmap (fmap (second f)) . runDebug + +withDebug :: (r' -> r) -> Debug r e a -> Debug r' e a +withDebug f m = Debug $ runDebug m . f instance Functor (Debug r e) where fmap = mapDebugT @@ -76,20 +74,29 @@ instance Monad (Debug r e) where instance MonadIO (Debug r e) where liftIO = Debug . const . fmap Right +instance MonadDebugger e m => MonadDebugger e (ReaderT r m) where + debug = lift . debug + catch = Reader.liftCatch catch + class (Monad io, MonadIO io) => MonadDebugger e io | io -> e where -- conceptually this is throw - enter :: e -> m a + debug :: e -> io a -- conceptually this is catch with a handler - catch :: m a -> (e -> m b) -> m b + catch :: io a -> (e -> io a) -> io a +instance MonadDebugger e (Debug r e) where + debug e = Debug $ const (return (Left e)) + catch (Debug m) hndl = Debug $ \r -> do + a <- m r + case a of + Left e -> runDebug (hndl e) r + v@Right{} -> return v -data DebugContext e = DebugContext { _currentError :: Maybe e - , _stackTrace :: [EState] - } - deriving (Semigroup, Monoid) +data DebugContext = DebugContext { _stackTrace :: [EState] + } -initialContext :: DebugContext e -initialContext = mempty +initialContext :: DebugContext +initialContext = DebugContext mempty -- checkError :: Debug e (Maybe e) From 32ef01d01d2cd6672e33fcb9e225ac5140281e74 Mon Sep 17 00:00:00 2001 From: doyougnu Date: Sun, 18 Aug 2024 16:22:42 -0400 Subject: [PATCH 05/23] wrk: project compiles with debugger --- src/Debugger.hs | 10 ++++ src/Expander.hs | 101 +++++++++++++++++++------------------ src/Expander/Monad.hs | 42 +++++++-------- src/Expander/Primitives.hs | 9 ++-- src/Expander/Syntax.hs | 35 ++++++------- src/Expander/TC.hs | 20 ++++---- 6 files changed, 115 insertions(+), 102 deletions(-) diff --git a/src/Debugger.hs b/src/Debugger.hs index 47b7e010..db5b9f45 100644 --- a/src/Debugger.hs +++ b/src/Debugger.hs @@ -30,6 +30,8 @@ import Data.Bifunctor import Control.Monad.IO.Class import Control.Monad.Trans.Class import Control.Monad.Trans.Reader (ReaderT) +import qualified Control.Monad.Trans.State.Lazy as LazyState +import qualified Control.Monad.Trans.State.Strict as StrictState import qualified Control.Monad.Trans.Reader as Reader -- ----------------------------------------------------------------------------- -- Types @@ -78,6 +80,14 @@ instance MonadDebugger e m => MonadDebugger e (ReaderT r m) where debug = lift . debug catch = Reader.liftCatch catch +instance MonadDebugger e m => MonadDebugger e (LazyState.StateT s m) where + debug = lift . debug + catch = LazyState.liftCatch catch + +instance MonadDebugger e m => MonadDebugger e (StrictState.StateT s m) where + debug = lift . debug + catch = StrictState.liftCatch catch + class (Monad io, MonadIO io) => MonadDebugger e io | io -> e where -- conceptually this is throw debug :: e -> io a diff --git a/src/Expander.hs b/src/Expander.hs index 6854f5b8..7815d570 100644 --- a/src/Expander.hs +++ b/src/Expander.hs @@ -38,7 +38,6 @@ import Control.Applicative import Control.Lens hiding (List, children) import Control.Monad import Control.Monad.IO.Class (MonadIO(liftIO)) -import Control.Monad.Except (MonadError(catchError, throwError)) import Control.Monad.Reader (MonadReader(local)) import Control.Monad.Trans.Class (MonadTrans(lift)) import Control.Monad.Trans.State.Strict (StateT, execStateT, modify', runStateT) @@ -59,6 +58,7 @@ import System.IO (Handle) import Binding import Core import Datatype +import Debugger import qualified Env import Evaluator import qualified Expander.Primitives as Prims @@ -150,10 +150,10 @@ loadModuleFile modName = return (KernelModule p, es) Left file -> do existsp <- liftIO $ doesFileExist file - when (not existsp) $ throwError $ NoSuchFile $ show file + when (not existsp) $ debug $ NoSuchFile $ show file stx <- liftIO (readModule file) >>= \case - Left err -> throwError $ ReaderError err + Left err -> debug $ ReaderError err Right stx -> return stx startExports <- view expanderModuleExports <$> getState modifyState $ set expanderModuleExports noExports @@ -196,7 +196,7 @@ getImports (ImportOnly spec idents) = do -- Check that all the identifiers are actually exported for_ idents $ \x -> case getExport p (view stxValue x) imports of - Nothing -> throwError $ NotExported x p + Nothing -> debug $ NotExported x p Just _ -> pure () return $ filterExports (\_ x -> x `elem` (map (view stxValue) idents)) imports getImports (ShiftImports spec i) = do @@ -306,7 +306,7 @@ evalMod (Expanded em _) = execStateT (traverseOf_ (moduleBody . each) evalDecl e \case (ValueIOAction act) -> modify' (:|> (IOResult . void $ act)) - _ -> throwError $ InternalError $ + _ -> debug $ InternalError $ "While running an action at " ++ T.unpack (pretty loc) ++ " an unexpected non-IO value was encountered." @@ -331,7 +331,7 @@ getEValue b = do ExpansionEnv env <- view expanderExpansionEnv <$> getState case S.lookup b env of Just v -> return v - Nothing -> throwError (InternalError ("No such binding: " ++ show b)) + Nothing -> debug (InternalError ("No such binding: " ++ show b)) visibleBindings :: Expand BindingTable @@ -357,7 +357,7 @@ checkUnambiguous best candidates blame = let bestSize = ScopeSet.size p best let candidateSizes = map (ScopeSet.size p) (nub $ toList candidates) if length (filter (== bestSize) candidateSizes) > 1 - then throwError (Ambiguous p blame candidates) + then debug (Ambiguous p blame candidates) else return () resolve :: Ident -> Expand Binding @@ -366,7 +366,8 @@ resolve stx@(Stx scs srcLoc x) = do bs <- allMatchingBindings x scs case bs of Seq.Empty -> - throwError (Unknown (Stx scs srcLoc x)) + do + debug (Unknown (Stx scs srcLoc x)) candidates -> let check = ScopeSet.size p . fst @@ -789,7 +790,7 @@ primImportModule dest outScopesDest importStx = do subSpec <- importSpec spec Stx _ _ p <- mustBeIdent prefix return $ PrefixImports subSpec p - | otherwise = throwError $ NotImportSpec stx + | otherwise = debug $ NotImportSpec stx importSpec modStx = ImportModule <$> mustBeModName modStx getRename s = do Stx _ _ (old', new') <- mustHaveEntries s @@ -816,24 +817,24 @@ primExport dest outScopesDest stx = do pairs <- getRenames blame rens spec <- exportSpec blame more return $ ExportRenamed spec pairs - _ -> throwError $ NotExportSpec blame + _ -> debug $ NotExportSpec blame "prefix" -> case args of ((syntaxE -> String pref) : more) -> do spec <- exportSpec blame more return $ ExportPrefixed spec pref - _ -> throwError $ NotExportSpec blame + _ -> debug $ NotExportSpec blame "shift" -> case args of (Syntax (Stx _ _ (Integer i)) : more) -> do spec <- exportSpec (Syntax (Stx scs' srcloc' (List more))) more if i >= 0 then return $ ExportShifted spec (fromIntegral i) - else throwError $ NotExportSpec blame - _ -> throwError $ NotExportSpec blame - _ -> throwError $ NotExportSpec blame + else debug $ NotExportSpec blame + _ -> debug $ NotExportSpec blame + _ -> debug $ NotExportSpec blame | Just xs <- traverse getIdent elts = return (ExportIdents xs) - | otherwise = throwError $ NotExportSpec blame + | otherwise = debug $ NotExportSpec blame getIdent (Syntax (Stx scs loc (Id x))) = pure (Stx scs loc x) @@ -845,7 +846,7 @@ primExport dest outScopesDest stx = do Stx _ _ x' <- mustBeIdent x Stx _ _ y' <- mustBeIdent y pure (x', y') - getRenames blame _ = throwError $ NotExportSpec blame + getRenames blame _ = debug $ NotExportSpec blame identifierHeaded :: Syntax -> Maybe Ident identifierHeaded (Syntax (Stx scs srcloc (Id x))) = Just (Stx scs srcloc x) @@ -911,11 +912,11 @@ runTask (tid, localData, task) = withLocal localData $ do forkInterpretMacroAction dest nextStep kont otherVal -> do p <- currentPhase - throwError $ MacroEvaluationError p $ evalErrorType "macro action" otherVal + debug $ MacroEvaluationError p $ evalErrorType "macro action" otherVal Left err -> do -- an error occurred in the evaluator, so just report it p <- currentPhase - throwError + debug $ MacroEvaluationError p $ projectError err AwaitingMacro dest (TaskAwaitMacro b v x deps mdest stx) -> do @@ -982,12 +983,12 @@ runTask (tid, localData, task) = withLocal localData $ do forkExpandSyntax dest syntax other -> do p <- currentPhase - throwError $ MacroEvaluationError p $ evalErrorType "syntax" other + debug $ MacroEvaluationError p $ evalErrorType "syntax" other ContinueMacroAction dest value (closure:kont) -> do case apply closure value of Left err -> do p <- currentPhase - throwError + debug $ MacroEvaluationError p $ evalErrorType "macro action" $ erroneousValue @@ -998,7 +999,7 @@ runTask (tid, localData, task) = withLocal localData $ do forkInterpretMacroAction dest macroAction kont other -> do p <- currentPhase - throwError $ MacroEvaluationError p $ evalErrorType "macro action" other + debug $ MacroEvaluationError p $ evalErrorType "macro action" other EvalDefnAction x n p expr -> linkedCore expr >>= \case @@ -1016,7 +1017,7 @@ runTask (tid, localData, task) = withLocal localData $ do then do st <- getState case view (expanderExpressionTypes . at edest) st of - Nothing -> throwError $ InternalError "Type not found during generalization" + Nothing -> debug $ InternalError "Type not found during generalization" Just _ -> do sch <- generalizeType ty linkScheme schdest sch @@ -1056,7 +1057,7 @@ runTask (tid, localData, task) = withLocal localData $ do (view (expanderPatternBinders . at ptr) <$> getState) >>= \case Nothing -> - throwError $ InternalError "Pattern info not added" + debug $ InternalError "Pattern info not added" Just (Right found) -> pure [found] Just (Left ptrs) -> @@ -1079,7 +1080,7 @@ runTask (tid, localData, task) = withLocal localData $ do else do varInfo <- view (expanderTypePatternBinders . at patPtr) <$> getState case varInfo of - Nothing -> throwError $ InternalError "Type pattern info not added" + Nothing -> debug $ InternalError "Type pattern info not added" Just vars -> do p <- currentPhase let rhs' = foldr (addScope p) stx @@ -1179,19 +1180,19 @@ problemCategory (TypePatternDest {}) = TypePatternCaseCat requireDeclarationCat :: Syntax -> MacroDest -> Expand (DeclTreePtr, DeclOutputScopesPtr) requireDeclarationCat _ (DeclTreeDest dest outScopesDest) = return (dest, outScopesDest) requireDeclarationCat stx other = - throwError $ + debug $ WrongSyntacticCategory stx (tenon DeclarationCat) (mortise $ problemCategory other) requireTypeCat :: Syntax -> MacroDest -> Expand (Kind, SplitTypePtr) requireTypeCat _ (TypeDest kind dest) = return (kind, dest) requireTypeCat stx other = - throwError $ + debug $ WrongSyntacticCategory stx (tenon TypeCat) (mortise $ problemCategory other) requireExpressionCat :: Syntax -> MacroDest -> Expand (Ty, SplitCorePtr) requireExpressionCat _ (ExprDest ty dest) = return (ty, dest) requireExpressionCat stx other = - throwError $ + debug $ WrongSyntacticCategory stx (tenon ExpressionCat) (mortise $ problemCategory other) requirePatternCat :: Syntax -> MacroDest -> Expand (Either (Ty, PatternPtr) TypePatternPtr) @@ -1200,7 +1201,7 @@ requirePatternCat _ (PatternDest scrutTy dest) = requirePatternCat _ (TypePatternDest dest) = return $ Right dest requirePatternCat stx other = - throwError $ + debug $ WrongSyntacticCategory stx (tenon PatternCaseCat) (mortise $ problemCategory other) @@ -1226,7 +1227,7 @@ expandOneForm prob stx _ <- mustBeIdent foundName argDests <- if length foundArgs /= length args' - then throwError $ + then debug $ WrongArgCount stx ctor (length args') (length foundArgs) else for (zip args' foundArgs) (uncurry schedule) linkExpr dest (CoreCtor ctor argDests) @@ -1238,7 +1239,7 @@ expandOneForm prob stx inst loc (Scheme argKinds a) tyArgs unify loc (tDatatype dt tyArgs) patTy if length subPats /= length argTypes - then throwError $ WrongArgCount stx ctor (length argTypes) (length subPats) + then debug $ WrongArgCount stx ctor (length argTypes) (length subPats) else do subPtrs <- for (zip subPats argTypes) \(sp, t) -> do ptr <- liftIO newPatternPtr @@ -1249,14 +1250,14 @@ expandOneForm prob stx linkPattern dest $ CtorPattern ctor subPtrs other -> - throwError $ + debug $ WrongSyntacticCategory stx (tenon ExpressionCat) (mortise $ problemCategory other) EPrimModuleMacro impl -> case prob of ModuleDest dest -> do impl dest stx other -> - throwError $ + debug $ WrongSyntacticCategory stx (tenon ModuleCat) (mortise $ problemCategory other) EPrimDeclMacro impl -> do (dest, outScopesDest) <- requireDeclarationCat stx prob @@ -1268,7 +1269,7 @@ expandOneForm prob stx TypePatternDest dest -> implP dest stx otherDest -> - throwError $ + debug $ WrongSyntacticCategory stx (tenon TypeCat) (mortise $ problemCategory otherDest) EPrimPatternMacro impl -> do dest <- requirePatternCat stx prob @@ -1297,7 +1298,7 @@ expandOneForm prob stx Id _ -> do equateKinds stx k k' linkType dest $ tSchemaVar i [] - _ -> throwError $ NotValidType stx + _ -> debug $ NotValidType stx EIncompleteDefn x n d -> do (t, dest) <- requireExpressionCat stx prob @@ -1316,7 +1317,7 @@ expandOneForm prob stx $ ValueSyntax $ addScope p stepScope stx case macroVal of - Left err -> throwError + Left err -> debug $ ValueNotMacro $ erroneousValue $ projectError err @@ -1329,22 +1330,22 @@ expandOneForm prob stx case expanded of ValueSyntax expansionResult -> forkExpandSyntax prob (flipScope p stepScope expansionResult) - other -> throwError $ ValueNotSyntax other + other -> debug $ ValueNotSyntax other other -> - throwError $ ValueNotMacro other + debug $ ValueNotMacro other Nothing -> - throwError $ InternalError $ + debug $ InternalError $ "No transformer yet created for " ++ shortShow ident ++ " (" ++ show transformerName ++ ") at phase " ++ shortShow p - Just other -> throwError $ ValueNotMacro other + Just other -> debug $ ValueNotMacro other | otherwise = case prob of ModuleDest {} -> - throwError $ InternalError "All modules should be identifier-headed" + debug $ InternalError "All modules should be identifier-headed" DeclTreeDest {} -> - throwError $ InternalError "All declarations should be identifier-headed" + debug $ InternalError "All declarations should be identifier-headed" TypeDest {} -> - throwError $ NotValidType stx + debug $ NotValidType stx ExprDest t dest -> case syntaxE stx of List xs -> expandOneExpression t dest (addApp stx xs) @@ -1352,9 +1353,9 @@ expandOneForm prob stx String s -> expandOneExpression t dest (addStringLiteral stx s) Id _ -> error "Impossible happened - identifiers are identifier-headed!" PatternDest {} -> - throwError $ InternalError "All patterns should be identifier-headed" + debug $ InternalError "All patterns should be identifier-headed" TypePatternDest {} -> - throwError $ InternalError "All type patterns should be identifier-headed" + debug $ InternalError "All type patterns should be identifier-headed" expandModuleForm :: DeclTreePtr -> Syntax -> Expand () @@ -1418,23 +1419,23 @@ interpretMacroAction prob = view (expanderWorld . worldEnvironments . at phase) $ s case applyInEnv env closure boundResult of -- FIXME DYG: what error to throw here - Left err -> throwError + Left err -> debug $ ValueNotMacro $ erroneousValue $ projectError err Right v -> case v of ValueMacroAction act -> interpretMacroAction prob act - other -> throwError $ ValueNotMacro other + other -> debug $ ValueNotMacro other MacroActionSyntaxError syntaxError -> - throwError $ MacroRaisedSyntaxError syntaxError + debug $ MacroRaisedSyntaxError syntaxError MacroActionIdentEq how v1 v2 -> do id1 <- getIdent v1 id2 <- getIdent v2 case how of Free -> compareFree id1 id2 - `catchError` + `catch` \case -- Ambiguous bindings should not crash the comparison - -- they're just not free-identifier=?. @@ -1442,7 +1443,7 @@ interpretMacroAction prob = -- Similarly, things that are not yet bound are just not -- free-identifier=? Unknown _ -> return $ Done $ primitiveCtor "false" [] - e -> throwError e + e -> debug e Bound -> return $ Done $ flip primitiveCtor [] $ if view stxValue id1 == view stxValue id2 && @@ -1450,7 +1451,7 @@ interpretMacroAction prob = then "true" else "false" where getIdent (ValueSyntax stx) = mustBeIdent stx - getIdent _other = throwError $ InternalError $ "Not a syntax object in " ++ opName + getIdent _other = debug $ InternalError $ "Not a syntax object in " ++ opName compareFree id1 id2 = do b1 <- resolve id1 b2 <- resolve id2 diff --git a/src/Expander/Monad.hs b/src/Expander/Monad.hs index 511cfe19..88dd8f2d 100644 --- a/src/Expander/Monad.hs +++ b/src/Expander/Monad.hs @@ -155,9 +155,7 @@ import Control.Arrow import Control.Lens import Control.Monad import Control.Monad.IO.Class (MonadIO(liftIO)) -import Control.Monad.Except (MonadError(throwError)) import Control.Monad.Reader (MonadReader(ask, local), asks) -import Control.Monad.Trans.Except (ExceptT, runExceptT) import Control.Monad.Trans.Reader (ReaderT, runReaderT) import Data.Foldable import Data.IORef @@ -176,6 +174,7 @@ import Binding.Info import Control.Lens.IORef import Core import Datatype +import Debugger import Env import Evaluator import Expander.DeclScope @@ -206,13 +205,14 @@ import qualified Util.Store as S import Util.Key newtype Expand a = Expand - { runExpand :: ReaderT ExpanderContext (ExceptT ExpansionErr IO) a + { runExpand :: ReaderT ExpanderContext (Debug DebugContext ExpansionErr) a } - deriving (Functor, Applicative, Monad, MonadError ExpansionErr, MonadIO, MonadReader ExpanderContext) + deriving (Functor, Applicative, Monad, MonadIO + , MonadDebugger ExpansionErr, MonadReader ExpanderContext + ) execExpand :: ExpanderContext -> Expand a -> IO (Either ExpansionErr a) -execExpand ctx act = runExceptT $ runReaderT (runExpand act) ctx - +execExpand ctx act = runDebug (runReaderT (runExpand act) ctx) initialContext newtype TaskID = TaskID Unique deriving newtype (Eq, Ord, HasKey) @@ -596,7 +596,7 @@ getDeclGroup :: DeclTreePtr -> Expand (Seq CompleteDecl) getDeclGroup ptr = (view (expanderCompletedDeclTrees . at ptr) <$> getState) >>= \case - Nothing -> throwError $ InternalError "Incomplete module after expansion" + Nothing -> debug $ InternalError "Incomplete module after expansion" Just DeclTreeLeaf -> pure mempty Just (DeclTreeAtom decl) -> pure <$> getDecl decl @@ -607,7 +607,7 @@ getDecl :: DeclPtr -> Expand CompleteDecl getDecl ptr = (view (expanderCompletedDecls . at ptr) <$> getState) >>= \case - Nothing -> throwError $ InternalError "Missing decl after expansion" + Nothing -> debug $ InternalError "Missing decl after expansion" Just decl -> zonkDecl decl where zonkDecl :: @@ -616,11 +616,11 @@ getDecl ptr = zonkDecl (Define x v schPtr e) = linkedCore e >>= \case - Nothing -> throwError $ InternalError "Missing expr after expansion" + Nothing -> debug $ InternalError "Missing expr after expansion" Just e' -> linkedScheme schPtr >>= \case - Nothing -> throwError $ InternalError "Missing scheme after expansion" + Nothing -> debug $ InternalError "Missing scheme after expansion" Just (Scheme ks t) -> do ks' <- traverse zonkKindDefault ks pure $ CompleteDecl $ Define x v (Scheme ks' t) e' @@ -629,7 +629,7 @@ getDecl ptr = for macros \(x, v, e) -> linkedCore e >>= \case - Nothing -> throwError $ InternalError "Missing expr after expansion" + Nothing -> debug $ InternalError "Missing expr after expansion" Just e' -> pure $ (x, v, e') zonkDecl (Data x dn argKinds ctors) = do argKinds' <- traverse zonkKindDefault argKinds @@ -645,7 +645,7 @@ getDecl ptr = linkedType ptr' >>= \case Nothing -> - throwError $ InternalError "Missing type after expansion" + debug $ InternalError "Missing type after expansion" Just argTy -> pure argTy pure (ident, cn, args') @@ -654,18 +654,18 @@ getDecl ptr = zonkDecl (Example loc schPtr e) = linkedCore e >>= \case - Nothing -> throwError $ InternalError "Missing expr after expansion" + Nothing -> debug $ InternalError "Missing expr after expansion" Just e' -> linkedScheme schPtr >>= \case - Nothing -> throwError $ InternalError "Missing example scheme after expansion" + Nothing -> debug $ InternalError "Missing example scheme after expansion" Just (Scheme ks t) -> do ks' <- traverse zonkKindDefault ks pure $ CompleteDecl $ Example loc (Scheme ks' t) e' zonkDecl (Run loc e) = linkedCore e >>= \case - Nothing -> throwError $ InternalError "Missing action after expansion" + Nothing -> debug $ InternalError "Missing action after expansion" Just e' -> pure $ CompleteDecl $ Run loc e' zonkDecl (Import spec) = return $ CompleteDecl $ Import spec zonkDecl (Export x) = return $ CompleteDecl $ Export x @@ -772,7 +772,7 @@ constructorInfo ctor = do fromModule <- view (expanderCurrentConstructors . at p . non mempty . at ctor) <$> getState case fromWorld <|> fromModule of Nothing -> - throwError $ InternalError $ "Unknown constructor " ++ show ctor + debug $ InternalError $ "Unknown constructor " ++ show ctor Just info -> pure info datatypeInfo :: Datatype -> Expand DatatypeInfo @@ -782,7 +782,7 @@ datatypeInfo datatype = do fromModule <- view (expanderCurrentDatatypes . at p . non mempty . at datatype) <$> getState case fromWorld <|> fromModule of Nothing -> - throwError $ InternalError $ "Unknown datatype " ++ show datatype + debug $ InternalError $ "Unknown datatype " ++ show datatype Just info -> pure info bind :: Binding -> EValue -> Expand () @@ -848,7 +848,7 @@ completely body = do a <- body remainingTasks <- getTasks unless (null remainingTasks) $ do - throwError (NoProgress (map (view _3) remainingTasks)) + debug (NoProgress (map (view _3) remainingTasks)) setTasks oldTasks pure a @@ -867,8 +867,8 @@ evalInCurrentPhase evalAction = do case evaluateIn env evalAction of Left e_state -> do p <- currentPhase - throwError $ MacroEvaluationError p $ projectError e_state - liftIO $ putStrLn $ pretty e_state + liftIO $ putStrLn "here!" + debug $ MacroEvaluationError p $ projectError e_state Right val -> return val currentTransformerEnv :: Expand TEnv @@ -927,7 +927,7 @@ importing mn act = do if mn `elem` inProgress then do here <- view (expanderWorld . worldLocation) <$> getState - throwError $ + debug $ CircularImports (relativizeModuleName here mn) $ fmap (relativizeModuleName here) inProgress else Expand $ local (over (expanderLocal . expanderImportStack) (mn:)) (runExpand act) diff --git a/src/Expander/Primitives.hs b/src/Expander/Primitives.hs index b8c5b8f8..65821cd4 100644 --- a/src/Expander/Primitives.hs +++ b/src/Expander/Primitives.hs @@ -73,6 +73,7 @@ import Numeric.Natural import Binding import Core import Datatype +import Debugger import qualified Env import Expander.DeclScope import Expander.Monad @@ -518,7 +519,7 @@ typeConstructor ctor argKinds = (implT, implP) implT k dest stx = do Stx _ _ (_, args) <- mustBeCons stx if length args > length argKinds - then throwError $ WrongTypeArity stx ctor + then debug $ WrongTypeArity stx ctor (fromIntegral $ length argKinds) (length args) else do @@ -530,7 +531,7 @@ typeConstructor ctor argKinds = (implT, implP) implP dest stx = do Stx _ _ (_, args) <- mustBeCons stx if length args > length argKinds - then throwError $ WrongTypeArity stx ctor + then debug $ WrongTypeArity stx ctor (fromIntegral $ length argKinds) (length args) else do @@ -588,7 +589,7 @@ makeLocalType dest stx = do _ <- mustBeIdent tstx linkType tdest $ TyF t [] let patImpl _ tstx = - throwError $ NotValidType tstx + debug $ NotValidType tstx p <- currentPhase addLocalBinding n b @@ -687,7 +688,7 @@ expandPatternCase t (Stx _ _ (lhs, rhs)) = do rhsDest <- schedule t rhs return (SyntaxPatternAny, rhsDest) other -> - throwError $ UnknownPattern other + debug $ UnknownPattern other scheduleDataPattern :: Ty -> Ty -> diff --git a/src/Expander/Syntax.hs b/src/Expander/Syntax.hs index 2a3202b5..95e7911d 100644 --- a/src/Expander/Syntax.hs +++ b/src/Expander/Syntax.hs @@ -3,11 +3,11 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} -- | Utilities for analyzing the form of syntax in the expander monad module Expander.Syntax where -import Control.Monad.Except import Control.Monad.IO.Class import Data.Functor.Identity (Identity(Identity)) import Data.List (nub, sort) @@ -15,6 +15,7 @@ import Data.Text (Text) import qualified Data.Text as T import Numeric.Natural +import Debugger import Expander.Error import Expander.Monad import KlisterPath @@ -24,44 +25,44 @@ import Syntax mustBeIdent :: Syntax -> Expand (Stx Text) mustBeIdent (Syntax (Stx scs srcloc (Id x))) = return (Stx scs srcloc x) -mustBeIdent other = throwError (NotIdentifier other) +mustBeIdent other = debug (NotIdentifier other) mustBeEmpty :: Syntax -> Expand (Stx ()) mustBeEmpty (Syntax (Stx scs srcloc (List []))) = return (Stx scs srcloc ()) -mustBeEmpty other = throwError (NotEmpty other) +mustBeEmpty other = debug (NotEmpty other) mustBeCons :: Syntax -> Expand (Stx (Syntax, [Syntax])) mustBeCons (Syntax (Stx scs srcloc (List (x:xs)))) = return (Stx scs srcloc (x, xs)) -mustBeCons other = throwError (NotCons other) +mustBeCons other = debug (NotCons other) mustBeConsCons :: Syntax -> Expand (Stx (Syntax, Syntax, [Syntax])) mustBeConsCons (Syntax (Stx scs srcloc (List (x:y:xs)))) = return (Stx scs srcloc (x, y, xs)) -mustBeConsCons other = throwError (NotConsCons other) +mustBeConsCons other = debug (NotConsCons other) mustBeList :: Syntax -> Expand (Stx [Syntax]) mustBeList (Syntax (Stx scs srcloc (List xs))) = return (Stx scs srcloc xs) -mustBeList other = throwError (NotList other) +mustBeList other = debug (NotList other) mustBeInteger :: Syntax -> Expand (Stx Integer) mustBeInteger (Syntax (Stx scs srcloc (Integer n))) = return (Stx scs srcloc n) -mustBeInteger other = throwError (NotInteger other) +mustBeInteger other = debug (NotInteger other) mustBeString :: Syntax -> Expand (Stx Text) mustBeString (Syntax (Stx scs srcloc (String s))) = return (Stx scs srcloc s) -mustBeString other = throwError (NotString other) +mustBeString other = debug (NotString other) mustBeModName :: Syntax -> Expand (Stx ModuleName) mustBeModName (Syntax (Stx scs srcloc (String s))) = do kPath <- klisterPath liftIO (findModule kPath srcloc (T.unpack s)) >>= \case - Left err -> throwError (ImportError err) + Left err -> debug (ImportError err) Right path -> pure $ Stx scs srcloc path -- TODO use hygiene here instead mustBeModName (Syntax (Stx scs srcloc (Id "kernel"))) = return (Stx scs srcloc (KernelName kernelName)) -mustBeModName other = throwError (NotModName other) +mustBeModName other = debug (NotModName other) mustHaveEntries @@ -74,9 +75,9 @@ mustHaveEntries stx@(Syntax (Stx scs srcloc (List xs))) = do Right r -> do pure (Stx scs srcloc r) Left lengths -> do - throwError (NotRightLength lengths stx) + debug (NotRightLength lengths stx) mustHaveEntries other = do - throwError (NotList other) + debug (NotList other) class FixedLengthList item r where checkLength :: [item] -> Either [Natural] r @@ -141,8 +142,8 @@ instance MustHaveShape () where mustHaveShape (Syntax (Stx _ _ (List []))) = do pure () mustHaveShape other@(Syntax (Stx _ _ (List (_:_)))) = do - throwError (NotEmpty other) - mustHaveShape other = throwError (NotList other) + debug (NotEmpty other) + mustHaveShape other = debug (NotList other) instance ( MustHaveShape car , MustHaveShape cdr @@ -153,8 +154,8 @@ instance ( MustHaveShape car cdr <- mustHaveShape (Syntax (Stx scs srcloc (List xs))) pure (car, cdr) mustHaveShape other@(Syntax (Stx _ _ (List []))) = do - throwError (NotCons other) - mustHaveShape other = throwError (NotList other) + debug (NotCons other) + mustHaveShape other = debug (NotList other) instance MustHaveShape a => MustHaveShape [a] where mustHaveShape (Syntax (Stx _ _ (List []))) = do @@ -163,4 +164,4 @@ instance MustHaveShape a => MustHaveShape [a] where car <- mustHaveShape x cdr <- mustHaveShape (Syntax (Stx scs srcloc (List xs))) pure (car : cdr) - mustHaveShape other = throwError (NotList other) + mustHaveShape other = debug (NotList other) diff --git a/src/Expander/TC.hs b/src/Expander/TC.hs index f6fdf1b7..b9e5eb7a 100644 --- a/src/Expander/TC.hs +++ b/src/Expander/TC.hs @@ -11,13 +11,13 @@ module Expander.TC ( import Control.Lens hiding (indices) import Control.Monad -import Control.Monad.Except import Control.Monad.State import Data.Foldable import Numeric.Natural import Expander.Monad import Core +import Debugger import Datatype import Kind import SplitCore @@ -33,7 +33,7 @@ derefType :: MetaPtr -> Expand (TVar Ty) derefType ptr = (view (expanderTypeStore . at ptr) <$> getState) >>= \case - Nothing -> throwError $ InternalError "Dangling type metavar" + Nothing -> debug $ InternalError "Dangling type metavar" Just var -> pure var @@ -79,7 +79,7 @@ occursCheck ptr t = do if ptr `elem` free then do t' <- normAll t - throwError $ TypeCheckError $ OccursCheckFailed ptr t' + debug $ TypeCheckError $ OccursCheckFailed ptr t' else pure () pruneLevel :: Traversable f => BindingLevel -> f MetaPtr -> Expand () @@ -110,7 +110,7 @@ freshMeta kind = do inst :: UnificationErrorBlame blame => blame -> Scheme Ty -> [Ty] -> Expand Ty inst blame (Scheme argKinds ty) ts | length ts /= length argKinds = - throwError $ InternalError "Mismatch in number of type vars" + debug $ InternalError "Mismatch in number of type vars" | otherwise = do traverse_ (uncurry $ checkKind blame) (zip argKinds ts) instTy ty @@ -195,7 +195,7 @@ generalizeType ty = do Just j -> pure $ TSchemaVar j | otherwise = pure $ TMetaVar v genVarsCtor _ (TSchemaVar _) = - throwError $ InternalError "Can't generalize in scheme" + debug $ InternalError "Can't generalize in scheme" genVarsCtor _ ctor = pure ctor @@ -289,11 +289,11 @@ unifyWithBlame blame depth t1 t2 = do e' <- normAll $ Ty shouldBe r' <- normAll $ Ty received if depth == 0 - then throwError $ TypeCheckError $ TypeMismatch loc e' r' Nothing + then debug $ TypeCheckError $ TypeMismatch loc e' r' Nothing else do outerE' <- normAll outerExpected outerR' <- normAll outerReceived - throwError $ TypeCheckError $ TypeMismatch loc outerE' outerR' (Just (e', r')) + debug $ TypeCheckError $ TypeMismatch loc outerE' outerR' (Just (e', r')) linkVar ptr t = linkToType (view _1 blame) ptr t @@ -302,7 +302,7 @@ typeVarKind :: MetaPtr -> Expand Kind typeVarKind ptr = (view (expanderTypeStore . at ptr) <$> getState) >>= \case - Nothing -> throwError $ InternalError "Type variable not found!" + Nothing -> debug $ InternalError "Type variable not found!" Just v -> pure $ view varKind v @@ -324,7 +324,7 @@ equateKinds blame kind1 kind2 = k1' <- zonkKind kind1 k2' <- zonkKind kind2 loc <- getBlameLoc blame - throwError $ KindMismatch loc k1' k2' + debug $ KindMismatch loc k1' k2' where -- Rigid-rigid cases equateKinds' KStar KStar = pure True @@ -378,7 +378,7 @@ inferKind blame (Ty (TyF ctor args)) = do ctorKind (TDatatype dt) = do DatatypeInfo argKinds _ <- datatypeInfo dt pure $ kFun argKinds KStar - ctorKind (TSchemaVar _) = throwError $ InternalError "Tried to find kind in open context" + ctorKind (TSchemaVar _) = debug $ InternalError "Tried to find kind in open context" ctorKind (TMetaVar mv) = typeVarKind mv appKind k [] = pure k From 9b38a387a2abf2562a019ea47ac418d2bcd3b846 Mon Sep 17 00:00:00 2001 From: doyougnu Date: Sun, 18 Aug 2024 16:32:10 -0400 Subject: [PATCH 06/23] wrk: comments for next time --- src/Debugger.hs | 9 ++++++++- src/Expander/Monad.hs | 1 - 2 files changed, 8 insertions(+), 2 deletions(-) diff --git a/src/Debugger.hs b/src/Debugger.hs index db5b9f45..01df3a34 100644 --- a/src/Debugger.hs +++ b/src/Debugger.hs @@ -87,7 +87,7 @@ instance MonadDebugger e m => MonadDebugger e (LazyState.StateT s m) where instance MonadDebugger e m => MonadDebugger e (StrictState.StateT s m) where debug = lift . debug catch = StrictState.liftCatch catch - + class (Monad io, MonadIO io) => MonadDebugger e io | io -> e where -- conceptually this is throw debug :: e -> io a @@ -112,6 +112,13 @@ initialContext = DebugContext mempty -- checkError :: Debug e (Maybe e) -- checkError = R.asks _currentError +-- DYG next: +-- - instead of projecting the error in debug invocations (see line 870 in Expander.Monad) +-- - we record the stack trace +-- - also merge catch and debug. In the debugger as envisioned these are the same things +-- - can we write a combinator that wraps a computation with a standard handler? +-- - I definitely believe we can, there are likely classes of handlers, with the simplest +-- - one being throwError that just reports the error. -- ----------------------------------------------------------------------------- -- Top level API diff --git a/src/Expander/Monad.hs b/src/Expander/Monad.hs index 88dd8f2d..aea60de3 100644 --- a/src/Expander/Monad.hs +++ b/src/Expander/Monad.hs @@ -867,7 +867,6 @@ evalInCurrentPhase evalAction = do case evaluateIn env evalAction of Left e_state -> do p <- currentPhase - liftIO $ putStrLn "here!" debug $ MacroEvaluationError p $ projectError e_state Right val -> return val From 9f55d30cacf50cbe0a7c07a711607c51ef445c02 Mon Sep 17 00:00:00 2001 From: doyougnu Date: Sun, 3 Nov 2024 06:41:12 -0500 Subject: [PATCH 07/23] wrk: drop: flake.nix klisterpath fixup --- flake.nix | 3 +++ 1 file changed, 3 insertions(+) diff --git a/flake.nix b/flake.nix index d14f0e09..7cd9ab33 100644 --- a/flake.nix +++ b/flake.nix @@ -52,6 +52,9 @@ # pkgs.haskell.lib.buildStackProject does # https://github.com/NixOS/nixpkgs/blob/d64780ea0e22b5f61cd6012a456869c702a72f20/pkgs/development/haskell-modules/generic-stack-builder.nix#L38 LD_LIBRARY_PATH = pkgs.lib.makeLibraryPath myDevTools; + shellHook = '' + export KLISTERPATH="$(pwd)"/examples/ + ''; }; }); } From 7ff632f7da590bbd863eef4e2c2f6c20f6cedbf7 Mon Sep 17 00:00:00 2001 From: doyougnu Date: Mon, 25 Nov 2024 11:14:06 -0500 Subject: [PATCH 08/23] wrk: misc progress --- flake.nix | 2 +- src/Debugger.hs | 13 +++++++++++-- src/Evaluator.hs | 1 - src/Expander.hs | 45 ++++++++++++++++++------------------------- src/Expander/Monad.hs | 2 +- src/Pretty.hs | 1 + 6 files changed, 33 insertions(+), 31 deletions(-) diff --git a/flake.nix b/flake.nix index 7cd9ab33..4e90c211 100644 --- a/flake.nix +++ b/flake.nix @@ -21,7 +21,7 @@ hPkgs.haskell-language-server # LSP server for editor hPkgs.implicit-hie # auto generate LSP hie.yaml file from cabal hPkgs.retrie # Haskell refactoring tool - # hPkgs.cabal-install + hPkgs.cabal-install stack-wrapped pkgs.zlib # External C library needed by some Haskell packages ]; diff --git a/src/Debugger.hs b/src/Debugger.hs index 01df3a34..8b70f489 100644 --- a/src/Debugger.hs +++ b/src/Debugger.hs @@ -38,19 +38,23 @@ import qualified Control.Monad.Trans.Reader as Reader -- conceptually this is a ReaderT (DebugContext e) (ExceptT e) IO a but I've --- just fused the transformers and to have more control over the monad instance +-- just fused the transformers to have more control over the monad instance newtype Debug r e a = Debug { runDebug :: r -> IO (Either e a) } debugRunT :: r -> Debug r e a -> IO (Either e a) debugRunT = flip runDebug +{-# INLINE mapDebugT #-} mapDebugT :: (a -> b) -> Debug r e a -> Debug r e b mapDebugT f = Debug . fmap (fmap (second f)) . runDebug withDebug :: (r' -> r) -> Debug r e a -> Debug r' e a withDebug f m = Debug $ runDebug m . f +ask' :: Debug r e r +ask' = Debug $ \r -> return $ Right r + instance Functor (Debug r e) where fmap = mapDebugT @@ -88,13 +92,17 @@ instance MonadDebugger e m => MonadDebugger e (StrictState.StateT s m) where debug = lift . debug catch = StrictState.liftCatch catch +-- | Type class that defines the interface for any debugger. Each instance is a +-- debugger in their own right class (Monad io, MonadIO io) => MonadDebugger e io | io -> e where -- conceptually this is throw debug :: e -> io a -- conceptually this is catch with a handler catch :: io a -> (e -> io a) -> io a -instance MonadDebugger e (Debug r e) where +-- | This debugger is the simplest debugger. It accepts no user inputs, instead +-- it only reports whatever stack trace its recorded. +instance MonadDebugger e (Debug DebugContext e) where debug e = Debug $ const (return (Left e)) catch (Debug m) hndl = Debug $ \r -> do a <- m r @@ -104,6 +112,7 @@ instance MonadDebugger e (Debug r e) where data DebugContext = DebugContext { _stackTrace :: [EState] } + deriving Show initialContext :: DebugContext initialContext = DebugContext mempty diff --git a/src/Evaluator.hs b/src/Evaluator.hs index 324858f3..924e21f6 100644 --- a/src/Evaluator.hs +++ b/src/Evaluator.hs @@ -203,7 +203,6 @@ data EState where -- ^ 'Er', meaning that we are in an error state and running the debugger deriving Show - -- ----------------------------------------------------------------------------- -- The evaluator. The CEK machine is a state machine, the @step@ function moves -- the state machine a single step of evaluation. This is the heart of the diff --git a/src/Expander.hs b/src/Expander.hs index 7815d570..937ac3b3 100644 --- a/src/Expander.hs +++ b/src/Expander.hs @@ -561,7 +561,7 @@ initializeKernel outputChannel = do ident = view closureIdent clos body = view closureBody clos case (evaluateWithExtendedEnv env [(ident, var, vx)] body) of - Left err -> error (T.unpack (pretty $ projectError err)) + Left err -> error (T.unpack (pretty err)) Right vioy -> pure vioy let ValueIOAction my = vioy my @@ -912,13 +912,12 @@ runTask (tid, localData, task) = withLocal localData $ do forkInterpretMacroAction dest nextStep kont otherVal -> do p <- currentPhase - debug $ MacroEvaluationError p $ evalErrorType "macro action" otherVal + -- debug $ MacroEvaluationError p $ evalErrorType "macro action" otherVal + error "MacroEvaluationError p $ evalErrorType \"macro action\" otherVal" Left err -> do -- an error occurred in the evaluator, so just report it p <- currentPhase - debug - $ MacroEvaluationError p - $ projectError err + debug $ MacroEvaluationError p err AwaitingMacro dest (TaskAwaitMacro b v x deps mdest stx) -> do newDeps <- concat <$> traverse dependencies deps case newDeps of @@ -983,23 +982,21 @@ runTask (tid, localData, task) = withLocal localData $ do forkExpandSyntax dest syntax other -> do p <- currentPhase - debug $ MacroEvaluationError p $ evalErrorType "syntax" other + -- debug $ MacroEvaluationError p $ evalErrorType "syntax" other + error "MacroEvaluationError p $ evalErrorType \"syntax\" other" ContinueMacroAction dest value (closure:kont) -> do case apply closure value of Left err -> do p <- currentPhase - debug - $ MacroEvaluationError p - $ evalErrorType "macro action" - $ erroneousValue - $ projectError err + debug $ MacroEvaluationError p err Right v -> case v of ValueMacroAction macroAction -> do forkInterpretMacroAction dest macroAction kont other -> do p <- currentPhase - debug $ MacroEvaluationError p $ evalErrorType "macro action" other + -- debug $ MacroEvaluationError p $ evalErrorType "macro action" other + error "MacroEvaluationError p $ evalErrorType \"macro action\" other" EvalDefnAction x n p expr -> linkedCore expr >>= \case @@ -1317,10 +1314,7 @@ expandOneForm prob stx $ ValueSyntax $ addScope p stepScope stx case macroVal of - Left err -> debug - $ ValueNotMacro - $ erroneousValue - $ projectError err + Left err -> debug $ ValueNotMacro err Right mv -> case mv of ValueMacroAction act -> interpretMacroAction prob act >>= \case @@ -1331,13 +1325,15 @@ expandOneForm prob stx ValueSyntax expansionResult -> forkExpandSyntax prob (flipScope p stepScope expansionResult) other -> debug $ ValueNotSyntax other - other -> - debug $ ValueNotMacro other - Nothing -> - debug $ InternalError $ + other -> error "ValueNotMacro other" + -- debug $ ValueNotMacro other + Nothing -> error $ show $ InternalError $ "No transformer yet created for " ++ shortShow ident ++ " (" ++ show transformerName ++ ") at phase " ++ shortShow p - Just other -> debug $ ValueNotMacro other + -- debug $ InternalError $ + -- "No transformer yet created for " ++ shortShow ident ++ + -- " (" ++ show transformerName ++ ") at phase " ++ shortShow p + Just other -> error "debug $ ValueNotMacro other" | otherwise = case prob of ModuleDest {} -> @@ -1419,14 +1415,11 @@ interpretMacroAction prob = view (expanderWorld . worldEnvironments . at phase) $ s case applyInEnv env closure boundResult of -- FIXME DYG: what error to throw here - Left err -> debug - $ ValueNotMacro - $ erroneousValue - $ projectError err + Left err -> debug $ ValueNotMacro err Right v -> case v of ValueMacroAction act -> interpretMacroAction prob act - other -> debug $ ValueNotMacro other + other -> debug $ ValueNotMacro (Up other mempty Halt) MacroActionSyntaxError syntaxError -> debug $ MacroRaisedSyntaxError syntaxError MacroActionIdentEq how v1 v2 -> do diff --git a/src/Expander/Monad.hs b/src/Expander/Monad.hs index aea60de3..303e5047 100644 --- a/src/Expander/Monad.hs +++ b/src/Expander/Monad.hs @@ -867,7 +867,7 @@ evalInCurrentPhase evalAction = do case evaluateIn env evalAction of Left e_state -> do p <- currentPhase - debug $ MacroEvaluationError p $ projectError e_state + debug $ MacroEvaluationError p e_state Right val -> return val currentTransformerEnv :: Expand TEnv diff --git a/src/Pretty.hs b/src/Pretty.hs index d53adbae..4d453b5f 100644 --- a/src/Pretty.hs +++ b/src/Pretty.hs @@ -146,6 +146,7 @@ instance (PrettyBinder VarInfo typePat, PrettyBinder VarInfo pat, Pretty VarInfo ] pp _env (CoreString str) = text (T.pack (show str)) pp env (CoreError what) = + -- set error to bold and red text "error" <+> pp env what pp env (CorePureMacro arg) = text "pure" <+> pp env arg From 7b7eb4a2d36b581f98b11b0deeb191444e11fa23 Mon Sep 17 00:00:00 2001 From: doyougnu Date: Tue, 26 Nov 2024 14:26:35 -0500 Subject: [PATCH 09/23] wrk: implement inarg printer --- examples/non-examples/bad-lexical-env.golden | 1 + examples/non-examples/bad-lexical-env.kl | 6 +++ .../stack-traces/error-in-arg.golden | 3 ++ .../non-examples/stack-traces/error-in-arg.kl | 5 +++ .../stack-traces/in-arg-error.golden | 6 +++ .../non-examples/stack-traces/in-arg-error.kl | 5 +++ src/Expander/Error.hs | 37 +++++++++++++++++++ src/Pretty.hs | 24 +----------- 8 files changed, 65 insertions(+), 22 deletions(-) create mode 100644 examples/non-examples/bad-lexical-env.golden create mode 100644 examples/non-examples/bad-lexical-env.kl create mode 100644 examples/non-examples/stack-traces/error-in-arg.golden create mode 100644 examples/non-examples/stack-traces/error-in-arg.kl create mode 100644 examples/non-examples/stack-traces/in-arg-error.golden create mode 100644 examples/non-examples/stack-traces/in-arg-error.kl diff --git a/examples/non-examples/bad-lexical-env.golden b/examples/non-examples/bad-lexical-env.golden new file mode 100644 index 00000000..dd828932 --- /dev/null +++ b/examples/non-examples/bad-lexical-env.golden @@ -0,0 +1 @@ +Unknown: #[bad-lexical-env.kl:3.24-3.25] diff --git a/examples/non-examples/bad-lexical-env.kl b/examples/non-examples/bad-lexical-env.kl new file mode 100644 index 00000000..20ec281c --- /dev/null +++ b/examples/non-examples/bad-lexical-env.kl @@ -0,0 +1,6 @@ +#lang kernel + +(define f (lambda (ff) y)) +(define g (lambda (y) (f))) + +(example (g 2)) diff --git a/examples/non-examples/stack-traces/error-in-arg.golden b/examples/non-examples/stack-traces/error-in-arg.golden new file mode 100644 index 00000000..ca20a0bb --- /dev/null +++ b/examples/non-examples/stack-traces/error-in-arg.golden @@ -0,0 +1,3 @@ +Expected 3 entries between parentheses, but got + #[error-in-arg.kl:3.28-3.45] + <(#%app + (error msg) 1)> diff --git a/examples/non-examples/stack-traces/error-in-arg.kl b/examples/non-examples/stack-traces/error-in-arg.kl new file mode 100644 index 00000000..c0df6821 --- /dev/null +++ b/examples/non-examples/stack-traces/error-in-arg.kl @@ -0,0 +1,5 @@ +#lang "prelude.kl" + +(define fail (lambda (thing) (+ thing 1))) + +(example (fail (error 'bad))) diff --git a/examples/non-examples/stack-traces/in-arg-error.golden b/examples/non-examples/stack-traces/in-arg-error.golden new file mode 100644 index 00000000..5e4a06b8 --- /dev/null +++ b/examples/non-examples/stack-traces/in-arg-error.golden @@ -0,0 +1,6 @@ +Type mismatch at + in-arg-error.kl:5.23-5.38. +Expected + Syntax +but got + String diff --git a/examples/non-examples/stack-traces/in-arg-error.kl b/examples/non-examples/stack-traces/in-arg-error.kl new file mode 100644 index 00000000..2494e15a --- /dev/null +++ b/examples/non-examples/stack-traces/in-arg-error.kl @@ -0,0 +1,5 @@ +#lang "prelude.kl" + +(define fail (lambda (something) (+ something 1))) + +(example (fail (error "in-arg-error!"))) diff --git a/src/Expander/Error.hs b/src/Expander/Error.hs index c4134733..4fbef4e7 100644 --- a/src/Expander/Error.hs +++ b/src/Expander/Error.hs @@ -277,3 +277,40 @@ instance Pretty VarInfo SyntacticCategory where pp _env DeclarationCat = text "a top-level declaration or example" pp _env PatternCaseCat = text "a pattern" pp _env TypePatternCaseCat = text "a typecase pattern" + + +-- ----------------------------------------------------------------------------- +-- StackTraces + +newtype StackTrace = StackTrace { unStackTrace :: EState } + +instance Pretty VarInfo StackTrace where + pp env st = pp env (unStackTrace st) + +instance Pretty VarInfo EState where + pp env st = printStack env st + +instance Pretty VarInfo Kont where + pp env k = hardline <> text "----" <+> printKont env k + +-- printStack :: p -> EState -> Doc ann +printStack e (Er err env k) = + vsep [ pp e err + , text "stack trace:" + ] <> pp e k + +printStack e (Up val env k) = hang 2 $ text "up" +printStack e (Down thing env k) = hang 2 $ text "down" + +printKont _ Halt = text "Halt" +printKont e (InArg fun env k) = text "with function" <+> pp e fun <> pp e k +printKont e (InFun arg env k) = text "with arg" <+> pp e arg <> pp e k + +-- printErr :: EvalError -> Doc ann +-- printErr = pretty + +-- printEnv :: VEnv -> Doc ann +-- printEnv = pretty + +-- START: implement printer for the rest of kont indentation was clobbered by +-- the 'group' operation diff --git a/src/Pretty.hs b/src/Pretty.hs index 4d453b5f..47cd7108 100644 --- a/src/Pretty.hs +++ b/src/Pretty.hs @@ -12,7 +12,7 @@ module Pretty , string , text , viaShow - , (<+>), (<>), align, hang, line, group, vsep, hsep + , (<+>), (<>), align, hang, line, group, vsep, hsep, hardline , VarInfo(..) , pretty, prettyPrint, prettyPrintLn, prettyEnv, prettyPrintEnv ) where @@ -211,7 +211,7 @@ class PrettyBinder ann a | a -> ann where instance PrettyBinder VarInfo a => PrettyBinder VarInfo (TyF a) where ppBind env t = let subs = ppBind env <$> t - in (pp env (fst <$> subs), foldMap snd subs) + in (pp env (fst <$> subs), foldMap snd subs) newtype BinderPair = BinderPair (Ident, Var) @@ -686,23 +686,3 @@ instance Pretty VarInfo ScopeSet where instance Pretty VarInfo KlisterPathError where pp _ = ppKlisterPathError - --- ----------------------------------------------------------------------------- --- StackTraces - -newtype StackTrace = StackTrace { unStackTrace :: EState } - -instance Pretty VarInfo StackTrace where - pp env st = printStack env (unStackTrace st) - -printStack :: Env Var () -> EState -> Doc VarInfo -printStack e (Er err env k) = hang 2 $ pp e err - --- printKont :: Kont -> Doc ann --- printKont = align . vsep - --- printErr :: EvalError -> Doc ann --- printErr = pretty - --- printEnv :: VEnv -> Doc ann --- printEnv = pretty From 7c6e14f0fd9abf1ba9f7626b45913917720e1c0f Mon Sep 17 00:00:00 2001 From: Jeffrey Young Date: Sat, 7 Dec 2024 10:10:21 -0500 Subject: [PATCH 10/23] wrk: let def --- examples/non-examples/stack-traces/error-in-let.golden | 8 ++++++++ examples/non-examples/stack-traces/error-in-let.kl | 7 +++++++ src/Expander/Error.hs | 4 +++- 3 files changed, 18 insertions(+), 1 deletion(-) create mode 100644 examples/non-examples/stack-traces/error-in-let.golden create mode 100644 examples/non-examples/stack-traces/error-in-let.kl diff --git a/examples/non-examples/stack-traces/error-in-let.golden b/examples/non-examples/stack-traces/error-in-let.golden new file mode 100644 index 00000000..e01aa4bf --- /dev/null +++ b/examples/non-examples/stack-traces/error-in-let.golden @@ -0,0 +1,8 @@ +Error at phase p0: + error-in-let.kl:4.42-4.53: + Im-an-error + stack trace: + ---- with function # + ---- in let #[error-in-let.kl:4.22-4.24] + !!(Var 2125)!! + ---- Halt diff --git a/examples/non-examples/stack-traces/error-in-let.kl b/examples/non-examples/stack-traces/error-in-let.kl new file mode 100644 index 00000000..86d27bbc --- /dev/null +++ b/examples/non-examples/stack-traces/error-in-let.kl @@ -0,0 +1,7 @@ +#lang "prelude.kl" + +(define fail (lambda (thing) + (let (go (+ thing (error 'Im-an-error))) + go))) + +(example (fail 23)) diff --git a/src/Expander/Error.hs b/src/Expander/Error.hs index 4fbef4e7..96fc56c7 100644 --- a/src/Expander/Error.hs +++ b/src/Expander/Error.hs @@ -303,8 +303,10 @@ printStack e (Up val env k) = hang 2 $ text "up" printStack e (Down thing env k) = hang 2 $ text "down" printKont _ Halt = text "Halt" -printKont e (InArg fun env k) = text "with function" <+> pp e fun <> pp e k printKont e (InFun arg env k) = text "with arg" <+> pp e arg <> pp e k +printKont e (InArg fun env k) = text "with function" <+> pp e fun <> pp e k +printKont e (InLetDef name var body env k) = text "in let" <+> pp e name + <> pp e body <> pp e k -- printErr :: EvalError -> Doc ann -- printErr = pretty From c88fa0065c6da1a57beb40b3e7fec753762daa96 Mon Sep 17 00:00:00 2001 From: Jeffrey Young Date: Sat, 21 Dec 2024 11:21:36 -0500 Subject: [PATCH 11/23] wrk: in constructor --- .../stack-traces/error-in-constructor.golden | 9 +++++++++ .../stack-traces/error-in-constructor.kl | 20 +++++++++++++++++++ src/Expander/Error.hs | 4 ++++ 3 files changed, 33 insertions(+) create mode 100644 examples/non-examples/stack-traces/error-in-constructor.golden create mode 100644 examples/non-examples/stack-traces/error-in-constructor.kl diff --git a/examples/non-examples/stack-traces/error-in-constructor.golden b/examples/non-examples/stack-traces/error-in-constructor.golden new file mode 100644 index 00000000..62f56346 --- /dev/null +++ b/examples/non-examples/stack-traces/error-in-constructor.golden @@ -0,0 +1,9 @@ +Error at phase p0: + error-in-constructor.kl:17.45-17.56: + Im-an-error + stack trace: + ---- in constructor pair + in position 2 + ---- in let #[error-in-constructor.kl:17.22-17.24] + !!(Var 5594)!! + ---- Halt diff --git a/examples/non-examples/stack-traces/error-in-constructor.kl b/examples/non-examples/stack-traces/error-in-constructor.kl new file mode 100644 index 00000000..588e4615 --- /dev/null +++ b/examples/non-examples/stack-traces/error-in-constructor.kl @@ -0,0 +1,20 @@ +#lang "prelude.kl" + +(import "lambda-case.kl") + +(datatype (Pair A B) + (pair A B)) + +(define fst + (lambda-case + [(pair x _) x])) + +(define snd + (lambda-case + [(pair _ y) y])) + +(define fail (lambda (thing) + (let (go (pair thing (error 'Im-an-error))) + go))) + +(example (fail 23)) diff --git a/src/Expander/Error.hs b/src/Expander/Error.hs index 96fc56c7..f7e8c170 100644 --- a/src/Expander/Error.hs +++ b/src/Expander/Error.hs @@ -307,6 +307,10 @@ printKont e (InFun arg env k) = text "with arg" <+> pp e arg <> pp e k printKont e (InArg fun env k) = text "with function" <+> pp e fun <> pp e k printKont e (InLetDef name var body env k) = text "in let" <+> pp e name <> pp e body <> pp e k +printKont e (InCtor f_vals cons f_to_go env k) = + let position = length f_vals + 1 + in text "in constructor" <+> + align (vsep [pp e cons, text "in position" <+> viaShow position]) <> pp e k -- printErr :: EvalError -> Doc ann -- printErr = pretty From 695b50e90fa1821c5e0727698ab17de98bf38a62 Mon Sep 17 00:00:00 2001 From: Jeffrey Young Date: Wed, 25 Dec 2024 11:46:38 -0500 Subject: [PATCH 12/23] wrk: cases --- .../error-in-case-constructor.golden | 5 +++ .../stack-traces/error-in-case-constructor.kl | 15 +++++++ src/Evaluator.hs | 37 +++++++++++------ src/Expander/Error.hs | 41 ++++++++++++++----- src/Pretty.hs | 3 +- 5 files changed, 77 insertions(+), 24 deletions(-) create mode 100644 examples/non-examples/stack-traces/error-in-case-constructor.golden create mode 100644 examples/non-examples/stack-traces/error-in-case-constructor.kl diff --git a/examples/non-examples/stack-traces/error-in-case-constructor.golden b/examples/non-examples/stack-traces/error-in-case-constructor.golden new file mode 100644 index 00000000..21301b50 --- /dev/null +++ b/examples/non-examples/stack-traces/error-in-case-constructor.golden @@ -0,0 +1,5 @@ +Error at phase p0: + error-in-case-constructor.kl:12.20-12.31: + Im-an-errer + stack trace: + ---- Halt diff --git a/examples/non-examples/stack-traces/error-in-case-constructor.kl b/examples/non-examples/stack-traces/error-in-case-constructor.kl new file mode 100644 index 00000000..8af01be9 --- /dev/null +++ b/examples/non-examples/stack-traces/error-in-case-constructor.kl @@ -0,0 +1,15 @@ +#lang "prelude.kl" + +(import "lambda-case.kl") + +(datatype (Alphabet) + (a) (b) (c) (d) (e) (f) (g) (h) (i) (j) (k) (l) (m) (n) + (o) (p) (q) (r) (s) (t) (u) (v) (x) (y) (z) (æ) (ø) (å)) + +(define fail + (lambda (thing) + (case thing + [(l) (error 'Im-an-error)] + [(else the-other) the-other]))) + +(example (fail (l))) diff --git a/src/Evaluator.hs b/src/Evaluator.hs index 924e21f6..5b8f0c8e 100644 --- a/src/Evaluator.hs +++ b/src/Evaluator.hs @@ -159,6 +159,14 @@ data Kont where InDataCaseScrut :: ![(ConstructorPattern, Core)] -> !SrcLoc -> !VEnv -> !Kont -> Kont InTypeCaseScrut :: ![(TypePattern, Core)] -> !SrcLoc -> !VEnv -> !Kont -> Kont + {- Note [InCasePattern + In case pattern is strictly not necessary, we could do this evalaution in + the host's runtime instead of in the evaluator but doing so would mean that + the debugger would not be able to capture the pattern that was matched. + -} + InCasePattern :: !SyntaxPattern -> !Kont -> Kont + InDataCasePattern :: !ConstructorPattern -> !Kont -> Kont + -- lists InConsHd :: !Core -> !(CoreF TypePattern ConstructorPattern Core) -> !VEnv -> !Kont -> Kont InConsTl :: !Core -> !Syntax -> !VEnv -> !Kont -> Kont @@ -245,6 +253,9 @@ step (Up v e k) = (\good -> Up (ValueMacroAction $ MacroActionTypeCase e loc good cs) env kont) (\err -> Er err env kont) + -- Case passthroughs, see the Note [InCasePattern] + (InCasePattern _ kont) -> Up v e kont + (InDataCasePattern _ kont) -> Up v e kont -- Idents (InIdent scope env kont) -> case v of @@ -605,34 +616,34 @@ doCase :: SrcLoc -> Value -> [(SyntaxPattern, Core)] -> VEnv -> Kont -> EState doCase blameLoc v0 [] e kont = Er (EvalErrorCase blameLoc v0) e kont doCase blameLoc v0 ((p, rhs0) : ps) e kont = match (doCase blameLoc v0 ps e kont) p rhs0 v0 e kont where - match next (SyntaxPatternIdentifier n x) rhs scrutinee env k = + match next pat@(SyntaxPatternIdentifier n x) rhs scrutinee env k = case scrutinee of v@(ValueSyntax (Syntax (Stx _ _ (Id _)))) -> - step $ Down (unCore rhs) (extend n x v env) k + step $ Down (unCore rhs) (extend n x v env) (InCasePattern pat k) _ -> next - match next (SyntaxPatternInteger n x) rhs scrutinee env k = + match next pat@(SyntaxPatternInteger n x) rhs scrutinee env k = case scrutinee of ValueSyntax (Syntax (Stx _ _ (Integer int))) -> - step $ Down (unCore rhs) (extend n x (ValueInteger int) env) k + step $ Down (unCore rhs) (extend n x (ValueInteger int) env) (InCasePattern pat k) _ -> next - match next (SyntaxPatternString n x) rhs scrutinee env k = + match next pat@(SyntaxPatternString n x) rhs scrutinee env k = case scrutinee of ValueSyntax (Syntax (Stx _ _ (String str))) -> - step $ Down (unCore rhs) (extend n x (ValueString str) env) k + step $ Down (unCore rhs) (extend n x (ValueString str) env) (InCasePattern pat k) _ -> next match next SyntaxPatternEmpty rhs scrutinee env k = case scrutinee of (ValueSyntax (Syntax (Stx _ _ (List [])))) -> - step $ Down (unCore rhs) env k + step $ Down (unCore rhs) env (InCasePattern SyntaxPatternEmpty k) _ -> next - match next (SyntaxPatternCons nx x nxs xs) rhs scrutinee env k = + match next pat@(SyntaxPatternCons nx x nxs xs) rhs scrutinee env k = case scrutinee of (ValueSyntax (Syntax (Stx scs loc (List (v:vs))))) -> let mkEnv = extend nx x (ValueSyntax v) . extend nxs xs (ValueSyntax (Syntax (Stx scs loc (List vs)))) - in step $ Down (unCore rhs) (mkEnv env) k + in step $ Down (unCore rhs) (mkEnv env) (InCasePattern pat k) _ -> next - match next (SyntaxPatternList xs) rhs scrutinee env k = + match next pat@(SyntaxPatternList xs) rhs scrutinee env k = case scrutinee of (ValueSyntax (Syntax (Stx _ _ (List vs)))) | length vs == length xs -> @@ -640,15 +651,15 @@ doCase blameLoc v0 ((p, rhs0) : ps) e kont = match (doCase blameLoc v0 ps e kon | (n,x) <- xs | v <- vs ] - in step $ Down (unCore rhs) (vals `extends` env) k + in step $ Down (unCore rhs) (vals `extends` env) (InCasePattern pat k) _ -> next match _next SyntaxPatternAny rhs _scrutinee env k = - step $ Down (unCore rhs) env k + step $ Down (unCore rhs) env (InCasePattern SyntaxPatternAny k) doDataCase :: SrcLoc -> Value -> [(ConstructorPattern, Core)] -> VEnv -> Kont -> EState doDataCase loc v0 [] env kont = Er (EvalErrorCase loc v0) env kont doDataCase loc v0 ((pat, rhs) : ps) env kont = - match (doDataCase loc v0 ps env kont) (\newEnv -> step $ Down (unCore rhs) newEnv kont) [(unConstructorPattern pat, v0)] + match (doDataCase loc v0 ps env kont) (\newEnv -> step $ Down (unCore rhs) newEnv (InDataCasePattern pat kont)) [(unConstructorPattern pat, v0)] where match :: EState {- ^ Failure continuation -} diff --git a/src/Expander/Error.hs b/src/Expander/Error.hs index f7e8c170..ba033d3e 100644 --- a/src/Expander/Error.hs +++ b/src/Expander/Error.hs @@ -1,5 +1,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} module Expander.Error @@ -294,23 +295,43 @@ instance Pretty VarInfo Kont where pp env k = hardline <> text "----" <+> printKont env k -- printStack :: p -> EState -> Doc ann -printStack e (Er err env k) = +printStack e (Er err _env k) = vsep [ pp e err , text "stack trace:" ] <> pp e k -printStack e (Up val env k) = hang 2 $ text "up" -printStack e (Down thing env k) = hang 2 $ text "down" +printStack _ Up{} = hang 2 $ text "up" +printStack _ Down{} = hang 2 $ text "down" -printKont _ Halt = text "Halt" -printKont e (InFun arg env k) = text "with arg" <+> pp e arg <> pp e k -printKont e (InArg fun env k) = text "with function" <+> pp e fun <> pp e k -printKont e (InLetDef name var body env k) = text "in let" <+> pp e name +printKont _ Halt = text "Halt" +printKont e (InFun arg _env k) = text "with arg" <+> pp e arg <> pp e k +printKont e (InArg fun _env k) = text "with function" <+> pp e fun <> pp e k +printKont e (InLetDef name var body _env k) = text "in let" <+> pp e name <> pp e body <> pp e k -printKont e (InCtor f_vals cons f_to_go env k) = - let position = length f_vals + 1 +printKont e (InCtor field_vals con _f_to_process _env k) = + let position = length field_vals + 1 in text "in constructor" <+> - align (vsep [pp e cons, text "in position" <+> viaShow position]) <> pp e k + align (vsep [pp e con, text "in field" <+> viaShow position]) <> pp e k +printKont e (InCaseScrut cases loc _env k) = + let do_case c = (fst $ ppBind e (fst c)) <> pp e (snd c) + in text "in case" <> pp e loc <> foldMap do_case cases <> pp e k +printKont e (InCasePattern p k) = + let ppPattern = \case + SyntaxPatternIdentifier i _ -> pp e i + SyntaxPatternInteger i _ -> pp e i + SyntaxPatternString i _ -> pp e i + SyntaxPatternCons il _iv rl _rv -> pp e il <> pp e rl + SyntaxPatternList ls -> foldMap (\(i, _) -> pp e i) ls + SyntaxPatternAny -> text "_" + SyntaxPatternEmpty -> text "()" + in text "in case pattern" <> ppPattern p <> pp e k +printKont e (InDataCasePattern p k) = + let ppPattern = \case + CtorPattern c _ps -> pp e c + PatternVar i _v -> pp e i + in text "in data case pattern: " + <> ppPattern (unConstructorPattern p) + <> pp e k -- printErr :: EvalError -> Doc ann -- printErr = pretty diff --git a/src/Pretty.hs b/src/Pretty.hs index 47cd7108..0ea26173 100644 --- a/src/Pretty.hs +++ b/src/Pretty.hs @@ -9,10 +9,11 @@ module Pretty ( Doc , Pretty(..) + , ppBind , string , text , viaShow - , (<+>), (<>), align, hang, line, group, vsep, hsep, hardline + , (<+>), (<>), align, hang, line, group, vsep, hsep, hardline, nest , VarInfo(..) , pretty, prettyPrint, prettyPrintLn, prettyEnv, prettyPrintEnv ) where From dae9ffeba44ec7a80d382a6b76ca99d64d027263 Mon Sep 17 00:00:00 2001 From: Jeffrey Young Date: Wed, 1 Jan 2025 17:43:51 -0500 Subject: [PATCH 13/23] wrk: up to macros --- .../stack-traces/.#error-in-cons-head.golden | 1 + .../stack-traces/error-in-cons-head.golden | 6 ++ .../stack-traces/error-in-cons-head.kl | 10 +++ .../stack-traces/error-in-list.golden | 2 + .../stack-traces/error-in-list.kl | 13 +++ src/Evaluator.hs | 4 +- src/Expander/Error.hs | 81 +++++++++++++++++-- 7 files changed, 108 insertions(+), 9 deletions(-) create mode 100644 examples/non-examples/stack-traces/.#error-in-cons-head.golden create mode 100644 examples/non-examples/stack-traces/error-in-cons-head.golden create mode 100644 examples/non-examples/stack-traces/error-in-cons-head.kl create mode 100644 examples/non-examples/stack-traces/error-in-list.golden create mode 100644 examples/non-examples/stack-traces/error-in-list.kl diff --git a/examples/non-examples/stack-traces/.#error-in-cons-head.golden b/examples/non-examples/stack-traces/.#error-in-cons-head.golden new file mode 100644 index 00000000..eecce1f1 --- /dev/null +++ b/examples/non-examples/stack-traces/.#error-in-cons-head.golden @@ -0,0 +1 @@ +User error; no such file: "/home/doyougnu/programming/klister/examples/non-examples/stack-traces/doyougnu@7thChamber.38408:1735135986" diff --git a/examples/non-examples/stack-traces/error-in-cons-head.golden b/examples/non-examples/stack-traces/error-in-cons-head.golden new file mode 100644 index 00000000..a02bbfe5 --- /dev/null +++ b/examples/non-examples/stack-traces/error-in-cons-head.golden @@ -0,0 +1,6 @@ +/home/doyougnu/programming/klister/examples/non-examples/stack-traces/error-in-cons-head.kl:12:11: + | +12 | [(l . j) (error 'Im-an-error)] + | ^ +unexpected '.' +expecting "#%app", "#%integer-literal", "#%module", "#%string-literal", ",@", "...", '"', ''', '(', ')', '+', ',', '-', '[', '`', identifier-initial character, or integer (digits) diff --git a/examples/non-examples/stack-traces/error-in-cons-head.kl b/examples/non-examples/stack-traces/error-in-cons-head.kl new file mode 100644 index 00000000..0c8336ae --- /dev/null +++ b/examples/non-examples/stack-traces/error-in-cons-head.kl @@ -0,0 +1,10 @@ +#lang "prelude.kl" + +(import "lambda-case.kl") + +-- TODO: DYG: how to test the pairs? +(define fail + (lambda (thing) + (car '(1 2 'something-else)))) + +(example (fail 3)) \ No newline at end of file diff --git a/examples/non-examples/stack-traces/error-in-list.golden b/examples/non-examples/stack-traces/error-in-list.golden new file mode 100644 index 00000000..a40e07c7 --- /dev/null +++ b/examples/non-examples/stack-traces/error-in-list.golden @@ -0,0 +1,2 @@ +Internal error during expansion! This is a bug in the implementation. +All patterns should be identifier-headed diff --git a/examples/non-examples/stack-traces/error-in-list.kl b/examples/non-examples/stack-traces/error-in-list.kl new file mode 100644 index 00000000..e21db5e8 --- /dev/null +++ b/examples/non-examples/stack-traces/error-in-list.kl @@ -0,0 +1,13 @@ +#lang "prelude.kl" + +(import "defun.kl") +(import "list.kl") + +(define thing 'nothing) +(define the-error (error 'Im-an-error)) + +(defun fail (thing) (+ 1 thing)) + +-- TODO: DYG: how to test +-- (example `(list-syntax (,thing (fail the-error) ()) thing)) +(example `('a 'b ,the-error)) \ No newline at end of file diff --git a/src/Evaluator.hs b/src/Evaluator.hs index 5b8f0c8e..631dcbd2 100644 --- a/src/Evaluator.hs +++ b/src/Evaluator.hs @@ -159,8 +159,8 @@ data Kont where InDataCaseScrut :: ![(ConstructorPattern, Core)] -> !SrcLoc -> !VEnv -> !Kont -> Kont InTypeCaseScrut :: ![(TypePattern, Core)] -> !SrcLoc -> !VEnv -> !Kont -> Kont - {- Note [InCasePattern - In case pattern is strictly not necessary, we could do this evalaution in + {- Note [InCasePattern] + In case pattern is strictly not necessary, we could do this evaluation in the host's runtime instead of in the evaluator but doing so would mean that the debugger would not be able to capture the pattern that was matched. -} diff --git a/src/Expander/Error.hs b/src/Expander/Error.hs index ba033d3e..d30ae3e7 100644 --- a/src/Expander/Error.hs +++ b/src/Expander/Error.hs @@ -303,18 +303,30 @@ printStack e (Er err _env k) = printStack _ Up{} = hang 2 $ text "up" printStack _ Down{} = hang 2 $ text "down" +-- the basics printKont _ Halt = text "Halt" printKont e (InFun arg _env k) = text "with arg" <+> pp e arg <> pp e k printKont e (InArg fun _env k) = text "with function" <+> pp e fun <> pp e k -printKont e (InLetDef name var body _env k) = text "in let" <+> pp e name +printKont e (InLetDef name _var body _env k) = text "in let" <+> pp e name <> pp e body <> pp e k + +-- constructors printKont e (InCtor field_vals con _f_to_process _env k) = let position = length field_vals + 1 in text "in constructor" <+> align (vsep [pp e con, text "in field" <+> viaShow position]) <> pp e k + +-- cases printKont e (InCaseScrut cases loc _env k) = let do_case c = (fst $ ppBind e (fst c)) <> pp e (snd c) in text "in case" <> pp e loc <> foldMap do_case cases <> pp e k +-- TODO: DYG: is data|type case different than case in the concrete syntax? +printKont e (InDataCaseScrut cases loc _env k) = + let do_case c = (fst $ ppBind e (fst c)) <> pp e (snd c) + in text "in data case" <> pp e loc <> foldMap do_case cases <> pp e k +printKont e (InTypeCaseScrut cases loc _env k) = + let do_case c = (fst $ ppBind e (fst c)) <> pp e (snd c) + in text "in type case" <> pp e loc <> foldMap do_case cases <> pp e k printKont e (InCasePattern p k) = let ppPattern = \case SyntaxPatternIdentifier i _ -> pp e i @@ -333,11 +345,66 @@ printKont e (InDataCasePattern p k) = <> ppPattern (unConstructorPattern p) <> pp e k --- printErr :: EvalError -> Doc ann --- printErr = pretty +-- pairs +-- TODO: DYG: how to test the cons? +printKont e (InConsHd scope hd _env k) = + vsep [ text "in head of pair" + , nest 2 $ pp e hd + , text "in scope" + , nest 2 $ pp e scope + ] + <> pp e k +printKont e (InConsTl scope hd _env k) = + vsep [ text "in tail of pair" + , nest 2 $ pp e hd + , text "in scope" + , nest 2 $ pp e scope + ] + <> pp e k + +-- lists +printKont e (InList scope _todos dones _env k) = + vsep [ text "in list" + , nest 2 $ foldMap (pp e) dones + , text "in scope" + , nest 2 $ pp e scope + ] + <> pp e k + +-- idents +-- TODO: DYG: how to report? +printKont e (InIdent scope _env k) = + vsep [ text "in ident" + , text "in scope" + , nest 2 $ pp e scope + ] + <> pp e k +printKont e (InIdentEqL _how scope _env k) = + vsep [ text "in ident eq left" + , text "in scope" + , nest 2 $ pp e scope + ] + <> pp e k +printKont e (InIdentEqR other _how _env k) = + vsep [ text "in ident eq right, comparing: " <> pp e other + ] + <> pp e k + +-- macros +printKont e (InPureMacro env k) = + vsep [ text "in pure macro" -- TODO: needs a passthrough? + ] + <> pp e k +printKont e (InBindMacroHd tl env k) = + vsep [ text "in bind macro head" -- TODO: needs a passthrough? + , pp e tl + ] + <> pp e k +printKont e (InBindMacroTl action env k) = + vsep [ text "in bind macro tail" -- TODO: needs a passthrough? + , pp e action + ] + <> pp e k --- printEnv :: VEnv -> Doc ann --- printEnv = pretty --- START: implement printer for the rest of kont indentation was clobbered by --- the 'group' operation +-- START: figure out how to test the cons cases From 416912c9d1d228c7b43b8a54a6aefc617fda81e4 Mon Sep 17 00:00:00 2001 From: Jeffrey Young Date: Thu, 2 Jan 2025 21:54:37 -0500 Subject: [PATCH 14/23] wrk: in pure macro --- examples/non-examples/stack-traces/error-in-pure-macro.golden | 2 ++ examples/non-examples/stack-traces/error-in-pure-macro.kl | 3 +++ 2 files changed, 5 insertions(+) create mode 100644 examples/non-examples/stack-traces/error-in-pure-macro.golden create mode 100644 examples/non-examples/stack-traces/error-in-pure-macro.kl diff --git a/examples/non-examples/stack-traces/error-in-pure-macro.golden b/examples/non-examples/stack-traces/error-in-pure-macro.golden new file mode 100644 index 00000000..003f2af0 --- /dev/null +++ b/examples/non-examples/stack-traces/error-in-pure-macro.golden @@ -0,0 +1,2 @@ +Unknown: #[error-in-pure-macro.kl:26.10-26.11] + diff --git a/examples/non-examples/stack-traces/error-in-pure-macro.kl b/examples/non-examples/stack-traces/error-in-pure-macro.kl new file mode 100644 index 00000000..80eee47a --- /dev/null +++ b/examples/non-examples/stack-traces/error-in-pure-macro.kl @@ -0,0 +1,3 @@ +#lang "prelude.kl" + +(example (pure (error 'surprise-error))) \ No newline at end of file From 53381ce4b36e314d768e0396460250ab6619bc3a Mon Sep 17 00:00:00 2001 From: Jeffrey Young Date: Sat, 4 Jan 2025 11:06:54 -0500 Subject: [PATCH 15/23] wrk: simple stack traces done --- .../stack-traces/error-in-bind-head.golden | 2 + .../stack-traces/error-in-bind-head.kl | 3 + .../stack-traces/error-in-bind-tail.golden | 5 + .../stack-traces/error-in-bind-tail.kl | 8 + src/Expander/Error.hs | 130 ---------------- src/Pretty.hs | 143 ++++++++++++++++++ 6 files changed, 161 insertions(+), 130 deletions(-) create mode 100644 examples/non-examples/stack-traces/error-in-bind-head.golden create mode 100644 examples/non-examples/stack-traces/error-in-bind-head.kl create mode 100644 examples/non-examples/stack-traces/error-in-bind-tail.golden create mode 100644 examples/non-examples/stack-traces/error-in-bind-tail.kl diff --git a/examples/non-examples/stack-traces/error-in-bind-head.golden b/examples/non-examples/stack-traces/error-in-bind-head.golden new file mode 100644 index 00000000..abf41d97 --- /dev/null +++ b/examples/non-examples/stack-traces/error-in-bind-head.golden @@ -0,0 +1,2 @@ +# : Output-Port +# : (IO Integer) diff --git a/examples/non-examples/stack-traces/error-in-bind-head.kl b/examples/non-examples/stack-traces/error-in-bind-head.kl new file mode 100644 index 00000000..ddb84ede --- /dev/null +++ b/examples/non-examples/stack-traces/error-in-bind-head.kl @@ -0,0 +1,3 @@ +#lang "prelude.kl" + +(example (>>= (pure (error 'e)) (lambda (x) (pure x)))) \ No newline at end of file diff --git a/examples/non-examples/stack-traces/error-in-bind-tail.golden b/examples/non-examples/stack-traces/error-in-bind-tail.golden new file mode 100644 index 00000000..14146461 --- /dev/null +++ b/examples/non-examples/stack-traces/error-in-bind-tail.golden @@ -0,0 +1,5 @@ +pure #[error-in-bind-tail.kl:3.22-3.35] + +>>= +# : ∀(α : *). + (Macro α) diff --git a/examples/non-examples/stack-traces/error-in-bind-tail.kl b/examples/non-examples/stack-traces/error-in-bind-tail.kl new file mode 100644 index 00000000..419c489f --- /dev/null +++ b/examples/non-examples/stack-traces/error-in-bind-tail.kl @@ -0,0 +1,8 @@ +#lang "prelude.kl" + +(example + (>>= (pure 'hello-go-boom) + (lambda (x) + (>>= (syntax-error x) + -- TODO: why doesn't this work? + (lambda (y) (pure y)))))) \ No newline at end of file diff --git a/src/Expander/Error.hs b/src/Expander/Error.hs index d30ae3e7..154498c3 100644 --- a/src/Expander/Error.hs +++ b/src/Expander/Error.hs @@ -278,133 +278,3 @@ instance Pretty VarInfo SyntacticCategory where pp _env DeclarationCat = text "a top-level declaration or example" pp _env PatternCaseCat = text "a pattern" pp _env TypePatternCaseCat = text "a typecase pattern" - - --- ----------------------------------------------------------------------------- --- StackTraces - -newtype StackTrace = StackTrace { unStackTrace :: EState } - -instance Pretty VarInfo StackTrace where - pp env st = pp env (unStackTrace st) - -instance Pretty VarInfo EState where - pp env st = printStack env st - -instance Pretty VarInfo Kont where - pp env k = hardline <> text "----" <+> printKont env k - --- printStack :: p -> EState -> Doc ann -printStack e (Er err _env k) = - vsep [ pp e err - , text "stack trace:" - ] <> pp e k - -printStack _ Up{} = hang 2 $ text "up" -printStack _ Down{} = hang 2 $ text "down" - --- the basics -printKont _ Halt = text "Halt" -printKont e (InFun arg _env k) = text "with arg" <+> pp e arg <> pp e k -printKont e (InArg fun _env k) = text "with function" <+> pp e fun <> pp e k -printKont e (InLetDef name _var body _env k) = text "in let" <+> pp e name - <> pp e body <> pp e k - --- constructors -printKont e (InCtor field_vals con _f_to_process _env k) = - let position = length field_vals + 1 - in text "in constructor" <+> - align (vsep [pp e con, text "in field" <+> viaShow position]) <> pp e k - --- cases -printKont e (InCaseScrut cases loc _env k) = - let do_case c = (fst $ ppBind e (fst c)) <> pp e (snd c) - in text "in case" <> pp e loc <> foldMap do_case cases <> pp e k --- TODO: DYG: is data|type case different than case in the concrete syntax? -printKont e (InDataCaseScrut cases loc _env k) = - let do_case c = (fst $ ppBind e (fst c)) <> pp e (snd c) - in text "in data case" <> pp e loc <> foldMap do_case cases <> pp e k -printKont e (InTypeCaseScrut cases loc _env k) = - let do_case c = (fst $ ppBind e (fst c)) <> pp e (snd c) - in text "in type case" <> pp e loc <> foldMap do_case cases <> pp e k -printKont e (InCasePattern p k) = - let ppPattern = \case - SyntaxPatternIdentifier i _ -> pp e i - SyntaxPatternInteger i _ -> pp e i - SyntaxPatternString i _ -> pp e i - SyntaxPatternCons il _iv rl _rv -> pp e il <> pp e rl - SyntaxPatternList ls -> foldMap (\(i, _) -> pp e i) ls - SyntaxPatternAny -> text "_" - SyntaxPatternEmpty -> text "()" - in text "in case pattern" <> ppPattern p <> pp e k -printKont e (InDataCasePattern p k) = - let ppPattern = \case - CtorPattern c _ps -> pp e c - PatternVar i _v -> pp e i - in text "in data case pattern: " - <> ppPattern (unConstructorPattern p) - <> pp e k - --- pairs --- TODO: DYG: how to test the cons? -printKont e (InConsHd scope hd _env k) = - vsep [ text "in head of pair" - , nest 2 $ pp e hd - , text "in scope" - , nest 2 $ pp e scope - ] - <> pp e k -printKont e (InConsTl scope hd _env k) = - vsep [ text "in tail of pair" - , nest 2 $ pp e hd - , text "in scope" - , nest 2 $ pp e scope - ] - <> pp e k - --- lists -printKont e (InList scope _todos dones _env k) = - vsep [ text "in list" - , nest 2 $ foldMap (pp e) dones - , text "in scope" - , nest 2 $ pp e scope - ] - <> pp e k - --- idents --- TODO: DYG: how to report? -printKont e (InIdent scope _env k) = - vsep [ text "in ident" - , text "in scope" - , nest 2 $ pp e scope - ] - <> pp e k -printKont e (InIdentEqL _how scope _env k) = - vsep [ text "in ident eq left" - , text "in scope" - , nest 2 $ pp e scope - ] - <> pp e k -printKont e (InIdentEqR other _how _env k) = - vsep [ text "in ident eq right, comparing: " <> pp e other - ] - <> pp e k - --- macros -printKont e (InPureMacro env k) = - vsep [ text "in pure macro" -- TODO: needs a passthrough? - ] - <> pp e k -printKont e (InBindMacroHd tl env k) = - vsep [ text "in bind macro head" -- TODO: needs a passthrough? - , pp e tl - ] - <> pp e k -printKont e (InBindMacroTl action env k) = - vsep [ text "in bind macro tail" -- TODO: needs a passthrough? - , pp e action - ] - <> pp e k - - --- START: figure out how to test the cons cases diff --git a/src/Pretty.hs b/src/Pretty.hs index 0ea26173..b452de73 100644 --- a/src/Pretty.hs +++ b/src/Pretty.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ParallelListComp #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -687,3 +688,145 @@ instance Pretty VarInfo ScopeSet where instance Pretty VarInfo KlisterPathError where pp _ = ppKlisterPathError + +-- ----------------------------------------------------------------------------- +-- StackTraces + +instance Pretty VarInfo EState where + pp env st = printStack env st + +instance Pretty VarInfo Kont where + pp env k = hardline <> text "----" <+> printKont env k + +printStack :: Env Var () -> EState -> Doc VarInfo +printStack e (Er err _env k) = + vsep [ pp e err + , text "stack trace:" + ] <> pp e k +printStack _ Up{} = hang 2 $ text "up" +printStack _ Down{} = hang 2 $ text "down" + +printKont :: Env Var () -> Kont -> Doc VarInfo +-- the basics +printKont _ Halt = text "Halt" +printKont e (InFun arg _env k) = text "with arg" <+> pp e arg <> pp e k +printKont e (InArg fun _env k) = text "with function" <+> pp e fun <> pp e k +printKont e (InLetDef name _var body _env k) = text "in let" <+> pp e name + <> pp e body <> pp e k + +-- constructors +printKont e (InCtor field_vals con _f_to_process _env k) = + let position = length field_vals + 1 + in text "in constructor" <+> + align (vsep [pp e con, text "in field" <+> viaShow position]) <> pp e k + +-- cases +printKont e (InCaseScrut cases loc _env k) = + let do_case c = (fst $ ppBind e (fst c)) <> pp e (snd c) + in text "in case" <> pp e loc <> foldMap do_case cases <> pp e k +-- TODO: DYG: is data|type case different than case in the concrete syntax? +printKont e (InDataCaseScrut cases loc _env k) = + let do_case c = (fst $ ppBind e (fst c)) <> pp e (snd c) + in text "in data case" <> pp e loc <> foldMap do_case cases <> pp e k +printKont e (InTypeCaseScrut cases loc _env k) = + let do_case c = (fst $ ppBind e (fst c)) <> pp e (snd c) + in text "in type case" <> pp e loc <> foldMap do_case cases <> pp e k +printKont e (InCasePattern p k) = + let ppPattern = \case + SyntaxPatternIdentifier i _ -> pp e i + SyntaxPatternInteger i _ -> pp e i + SyntaxPatternString i _ -> pp e i + SyntaxPatternCons il _iv rl _rv -> pp e il <> pp e rl + SyntaxPatternList ls -> foldMap (\(i, _) -> pp e i) ls + SyntaxPatternAny -> text "_" + SyntaxPatternEmpty -> text "()" + in text "in case pattern" <> ppPattern p <> pp e k +printKont e (InDataCasePattern p k) = + let ppPattern = \case + CtorPattern c _ps -> pp e c + PatternVar i _v -> pp e i + in text "in data case pattern: " + <> ppPattern (unConstructorPattern p) + <> pp e k + +-- pairs +-- TODO: DYG: how to test the cons? +printKont e (InConsHd scope hd _env k) = + vsep [ text "in head of pair" + , nest 2 $ pp e hd + , text "in scope" + , nest 2 $ pp e scope + ] + <> pp e k +printKont e (InConsTl scope hd _env k) = + vsep [ text "in tail of pair" + , nest 2 $ pp e hd + , text "in scope" + , nest 2 $ pp e scope + ] + <> pp e k + +-- lists +printKont e (InList scope _todos dones _env k) = + vsep [ text "in list" + , nest 2 $ foldMap (pp e) dones + , text "in scope" + , nest 2 $ pp e scope + ] + <> pp e k + +-- idents +-- TODO: DYG: how to report and test these? +printKont e (InIdent scope _env k) = + vsep [ text "in ident" + , text "in scope" + , nest 2 $ pp e scope + ] + <> pp e k +printKont e (InIdentEqL _how scope _env k) = + vsep [ text "in ident eq left" + , text "in scope" + , nest 2 $ pp e scope + ] + <> pp e k +printKont e (InIdentEqR other _how _env k) = + vsep [ text "in ident eq right, comparing: " <> pp e other + ] + <> pp e k + +-- macros +printKont e (InPureMacro _env k) = + vsep [ text "in pure macro" -- TODO: needs a passthrough? + ] + <> pp e k +printKont e (InBindMacroHd tl _env k) = + vsep [ text "in bind macro head" -- TODO: needs a passthrough? + , pp e tl + ] + <> pp e k +printKont e (InBindMacroTl action _env k) = + vsep [ text "in bind macro tail" -- TODO: needs a passthrough? + , pp e action + ] + <> pp e k + +-- atomics +printKont e (InInteger _ _ k) = pp e k +printKont e (InString _ _ k) = pp e k +printKont e (InReplaceLocL _ _ k) = pp e k +printKont e (InReplaceLocR _ _ k) = pp e k + +-- scope +printKont e (InScope scope _env k) = + vsep [ text "in scope" + , pp e scope + ] + <> pp e k + +-- others +printKont e (InLog _ k) = pp e k -- would require a passthrough +printKont e (InError _ k) = pp e k +printKont e (InSyntaxErrorMessage _ _ k) = pp e k +printKont e (InSyntaxErrorLocations _ _ _ _ k) = pp e k + +-- START: figure out how to test the cons cases From b733155256d9e29f57def5304174cf21b5e6754b Mon Sep 17 00:00:00 2001 From: Jeffrey Young Date: Sat, 4 Jan 2025 11:08:09 -0500 Subject: [PATCH 16/23] wrk: update golden test output --- examples/non-examples/bad-lexical-env.golden | 3 ++- examples/non-examples/circular-1.golden | 3 ++- examples/non-examples/circular-2.golden | 3 ++- examples/non-examples/missing-import.golden | 3 ++- .../non-examples/stack-traces/error-in-arg.golden | 9 ++++++--- .../stack-traces/error-in-bind-head.golden | 11 +++++++++-- .../stack-traces/error-in-bind-tail.golden | 2 +- .../stack-traces/error-in-case-constructor.golden | 3 ++- .../stack-traces/error-in-cons-head.golden | 8 ++------ .../stack-traces/error-in-constructor.golden | 4 ++-- .../non-examples/stack-traces/error-in-let.golden | 2 +- .../non-examples/stack-traces/error-in-list.golden | 7 +++++-- .../stack-traces/error-in-pure-macro.golden | 8 ++++++-- examples/non-examples/type-errors.golden | 7 ++++++- 14 files changed, 48 insertions(+), 25 deletions(-) diff --git a/examples/non-examples/bad-lexical-env.golden b/examples/non-examples/bad-lexical-env.golden index dd828932..91dd5014 100644 --- a/examples/non-examples/bad-lexical-env.golden +++ b/examples/non-examples/bad-lexical-env.golden @@ -1 +1,2 @@ -Unknown: #[bad-lexical-env.kl:3.24-3.25] +Unknown: #[bad-lexical-env.kl:3.24-3.25] + diff --git a/examples/non-examples/circular-1.golden b/examples/non-examples/circular-1.golden index 9286ba32..175f27f5 100644 --- a/examples/non-examples/circular-1.golden +++ b/examples/non-examples/circular-1.golden @@ -1,4 +1,5 @@ -Circular imports while importing "examples/non-examples/circular-1.kl" +Circular imports while importing + "examples/non-examples/circular-1.kl" Context: "examples/non-examples/circular-2.kl" "examples/non-examples/circular-1.kl" diff --git a/examples/non-examples/circular-2.golden b/examples/non-examples/circular-2.golden index e1877098..c1497afb 100644 --- a/examples/non-examples/circular-2.golden +++ b/examples/non-examples/circular-2.golden @@ -1,4 +1,5 @@ -Circular imports while importing "examples/non-examples/circular-2.kl" +Circular imports while importing + "examples/non-examples/circular-2.kl" Context: "examples/non-examples/circular-1.kl" "examples/non-examples/circular-2.kl" diff --git a/examples/non-examples/missing-import.golden b/examples/non-examples/missing-import.golden index e8213f82..912aa2ca 100644 --- a/examples/non-examples/missing-import.golden +++ b/examples/non-examples/missing-import.golden @@ -1 +1,2 @@ -missing-import.kl:3.22-3.27: Not available at phase p0: magic +missing-import.kl:3.22-3.27: + Not available at phase p0: magic diff --git a/examples/non-examples/stack-traces/error-in-arg.golden b/examples/non-examples/stack-traces/error-in-arg.golden index ca20a0bb..0452b8ff 100644 --- a/examples/non-examples/stack-traces/error-in-arg.golden +++ b/examples/non-examples/stack-traces/error-in-arg.golden @@ -1,3 +1,6 @@ -Expected 3 entries between parentheses, but got - #[error-in-arg.kl:3.28-3.45] - <(#%app + (error msg) 1)> +Error at phase p0: + error-in-arg.kl:5.24-5.27: + bad + stack trace: + ---- with function # + ---- Halt diff --git a/examples/non-examples/stack-traces/error-in-bind-head.golden b/examples/non-examples/stack-traces/error-in-bind-head.golden index abf41d97..63abedfc 100644 --- a/examples/non-examples/stack-traces/error-in-bind-head.golden +++ b/examples/non-examples/stack-traces/error-in-bind-head.golden @@ -1,2 +1,9 @@ -# : Output-Port -# : (IO Integer) +Error at phase p0: + error-in-bind-head.kl:3.29-3.30: + e + stack trace: + ---- in pure macro + ---- in bind macro head + λx. + pure x + ---- Halt diff --git a/examples/non-examples/stack-traces/error-in-bind-tail.golden b/examples/non-examples/stack-traces/error-in-bind-tail.golden index 14146461..d896cf94 100644 --- a/examples/non-examples/stack-traces/error-in-bind-tail.golden +++ b/examples/non-examples/stack-traces/error-in-bind-tail.golden @@ -1,4 +1,4 @@ -pure #[error-in-bind-tail.kl:3.22-3.35] +pure #[error-in-bind-tail.kl:4.15-4.28] >>= # : ∀(α : *). diff --git a/examples/non-examples/stack-traces/error-in-case-constructor.golden b/examples/non-examples/stack-traces/error-in-case-constructor.golden index 21301b50..5c3d8507 100644 --- a/examples/non-examples/stack-traces/error-in-case-constructor.golden +++ b/examples/non-examples/stack-traces/error-in-case-constructor.golden @@ -1,5 +1,6 @@ Error at phase p0: error-in-case-constructor.kl:12.20-12.31: - Im-an-errer + Im-an-error stack trace: + ---- in data case pattern: l ---- Halt diff --git a/examples/non-examples/stack-traces/error-in-cons-head.golden b/examples/non-examples/stack-traces/error-in-cons-head.golden index a02bbfe5..988b492f 100644 --- a/examples/non-examples/stack-traces/error-in-cons-head.golden +++ b/examples/non-examples/stack-traces/error-in-cons-head.golden @@ -1,6 +1,2 @@ -/home/doyougnu/programming/klister/examples/non-examples/stack-traces/error-in-cons-head.kl:12:11: - | -12 | [(l . j) (error 'Im-an-error)] - | ^ -unexpected '.' -expecting "#%app", "#%integer-literal", "#%module", "#%string-literal", ",@", "...", '"', ''', '(', ')', '+', ',', '-', '[', '`', identifier-initial character, or integer (digits) +Unknown: #[error-in-cons-head.kl:8.6-8.9] + diff --git a/examples/non-examples/stack-traces/error-in-constructor.golden b/examples/non-examples/stack-traces/error-in-constructor.golden index 62f56346..040b8f3d 100644 --- a/examples/non-examples/stack-traces/error-in-constructor.golden +++ b/examples/non-examples/stack-traces/error-in-constructor.golden @@ -3,7 +3,7 @@ Error at phase p0: Im-an-error stack trace: ---- in constructor pair - in position 2 + in field 2 ---- in let #[error-in-constructor.kl:17.22-17.24] - !!(Var 5594)!! + !!(Var 395597)!! ---- Halt diff --git a/examples/non-examples/stack-traces/error-in-let.golden b/examples/non-examples/stack-traces/error-in-let.golden index e01aa4bf..2273dcf5 100644 --- a/examples/non-examples/stack-traces/error-in-let.golden +++ b/examples/non-examples/stack-traces/error-in-let.golden @@ -4,5 +4,5 @@ Error at phase p0: stack trace: ---- with function # ---- in let #[error-in-let.kl:4.22-4.24] - !!(Var 2125)!! + !!(Var 382159)!! ---- Halt diff --git a/examples/non-examples/stack-traces/error-in-list.golden b/examples/non-examples/stack-traces/error-in-list.golden index a40e07c7..ee557994 100644 --- a/examples/non-examples/stack-traces/error-in-list.golden +++ b/examples/non-examples/stack-traces/error-in-list.golden @@ -1,2 +1,5 @@ -Internal error during expansion! This is a bug in the implementation. -All patterns should be identifier-headed +Error at phase p0: + error-in-list.kl:7.27-7.38: + Im-an-error + stack trace: + ---- Halt diff --git a/examples/non-examples/stack-traces/error-in-pure-macro.golden b/examples/non-examples/stack-traces/error-in-pure-macro.golden index 003f2af0..71f48210 100644 --- a/examples/non-examples/stack-traces/error-in-pure-macro.golden +++ b/examples/non-examples/stack-traces/error-in-pure-macro.golden @@ -1,2 +1,6 @@ -Unknown: #[error-in-pure-macro.kl:26.10-26.11] - +Error at phase p0: + error-in-pure-macro.kl:3.24-3.38: + surprise-error + stack trace: + ---- in pure macro + ---- Halt diff --git a/examples/non-examples/type-errors.golden b/examples/non-examples/type-errors.golden index a7ec0107..73a01fa9 100644 --- a/examples/non-examples/type-errors.golden +++ b/examples/non-examples/type-errors.golden @@ -1 +1,6 @@ -Type mismatch at type-errors.kl:3.36-3.37. Expected Syntax but got Integer +Type mismatch at + type-errors.kl:3.36-3.37. +Expected + Syntax +but got + Integer From b8d30c17fc2ab943e59e91ec4a57ab01f22e7e2a Mon Sep 17 00:00:00 2001 From: Jeffrey Young Date: Wed, 8 Jan 2025 12:27:49 -0500 Subject: [PATCH 17/23] wrk: add loc in expander error message --- src/Expander/Monad.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Expander/Monad.hs b/src/Expander/Monad.hs index 303e5047..9622d7ba 100644 --- a/src/Expander/Monad.hs +++ b/src/Expander/Monad.hs @@ -654,11 +654,11 @@ getDecl ptr = zonkDecl (Example loc schPtr e) = linkedCore e >>= \case - Nothing -> debug $ InternalError "Missing expr after expansion" + Nothing -> debug . InternalError $ "Missing expr after expansion at: " <> show loc Just e' -> linkedScheme schPtr >>= \case - Nothing -> debug $ InternalError "Missing example scheme after expansion" + Nothing -> debug . InternalError $ "Missing example scheme after expansion: " <> show loc Just (Scheme ks t) -> do ks' <- traverse zonkKindDefault ks pure $ CompleteDecl $ Example loc (Scheme ks' t) e' From cc73f7fc4e482201b492321a720b9cb749c21918 Mon Sep 17 00:00:00 2001 From: Jeffrey Young Date: Wed, 8 Jan 2025 13:37:25 -0500 Subject: [PATCH 18/23] wrk: misc cleanup --- klister.cabal | 1 - src/Evaluator.hs | 22 ++++++++++++++++------ src/Expander.hs | 19 ++++++------------- 3 files changed, 22 insertions(+), 20 deletions(-) diff --git a/klister.cabal b/klister.cabal index 27ed14f7..1850db38 100644 --- a/klister.cabal +++ b/klister.cabal @@ -42,7 +42,6 @@ common deps megaparsec >= 7.0.5 && < 9.7, mtl >= 2.2.2 && < 2.4, prettyprinter >= 1.2 && < 1.8, - prettyprinter >= 1.2 && < 1.8, text >= 1.2, transformers ^>= 0.6 diff --git a/src/Evaluator.hs b/src/Evaluator.hs index 631dcbd2..30af4cc0 100644 --- a/src/Evaluator.hs +++ b/src/Evaluator.hs @@ -83,6 +83,7 @@ module Evaluator , try , projectError , projectKont + , constructErrorType ) where import Control.Lens hiding (List, elements) @@ -101,8 +102,6 @@ import Syntax.SrcLoc import Type import Value -import Debug.Trace - -- ----------------------------------------------------------------------------- -- Interpreter Data Types @@ -119,7 +118,6 @@ data TypeError = TypeError , _typeErrorActual :: Type } deriving (Eq, Show) -makeLenses ''TypeError data EvalError = EvalErrorUnbound Var @@ -578,9 +576,21 @@ extends exts env = foldl' (\acc (n,x,v) -> Env.insert x n v acc) env exts evalErrorType :: Text -> Value -> EvalError evalErrorType expected got = EvalErrorType $ TypeError - { _typeErrorExpected = expected - , _typeErrorActual = describeVal got - } + { _typeErrorExpected = expected + , _typeErrorActual = describeVal got + } + +-- this is a copy of 'evalErrorType' but with no memory of how we got to this +-- error state. This should just be a stopgap and we should remove it. Its sole +-- use case is in the expander where we have redundant error checks due to +-- functions such as @doTypeCase@ +constructErrorType :: Text -> Value -> EState +constructErrorType expected got = Er err mempty Halt + where + err = EvalErrorType $ TypeError + { _typeErrorExpected = expected + , _typeErrorActual = describeVal got + } doTypeCase :: VEnv -> SrcLoc -> Ty -> [(TypePattern, Core)] -> Either EState Value -- We pass @Right $ ValueType v0@ here so that the Core type-case still matches diff --git a/src/Expander.hs b/src/Expander.hs index 937ac3b3..32c3f89b 100644 --- a/src/Expander.hs +++ b/src/Expander.hs @@ -912,8 +912,7 @@ runTask (tid, localData, task) = withLocal localData $ do forkInterpretMacroAction dest nextStep kont otherVal -> do p <- currentPhase - -- debug $ MacroEvaluationError p $ evalErrorType "macro action" otherVal - error "MacroEvaluationError p $ evalErrorType \"macro action\" otherVal" + debug $ MacroEvaluationError p $ constructErrorType "macro action" otherVal Left err -> do -- an error occurred in the evaluator, so just report it p <- currentPhase @@ -982,8 +981,7 @@ runTask (tid, localData, task) = withLocal localData $ do forkExpandSyntax dest syntax other -> do p <- currentPhase - -- debug $ MacroEvaluationError p $ evalErrorType "syntax" other - error "MacroEvaluationError p $ evalErrorType \"syntax\" other" + debug $ MacroEvaluationError p $ constructErrorType "syntax" other ContinueMacroAction dest value (closure:kont) -> do case apply closure value of Left err -> do @@ -995,8 +993,7 @@ runTask (tid, localData, task) = withLocal localData $ do forkInterpretMacroAction dest macroAction kont other -> do p <- currentPhase - -- debug $ MacroEvaluationError p $ evalErrorType "macro action" other - error "MacroEvaluationError p $ evalErrorType \"macro action\" other" + debug $ MacroEvaluationError p $ constructErrorType "macro action" other EvalDefnAction x n p expr -> linkedCore expr >>= \case @@ -1325,15 +1322,11 @@ expandOneForm prob stx ValueSyntax expansionResult -> forkExpandSyntax prob (flipScope p stepScope expansionResult) other -> debug $ ValueNotSyntax other - other -> error "ValueNotMacro other" - -- debug $ ValueNotMacro other - Nothing -> error $ show $ InternalError $ + other -> debug $ ValueNotMacro $ constructErrorType "error in user macro" other + Nothing -> debug $ InternalError $ "No transformer yet created for " ++ shortShow ident ++ " (" ++ show transformerName ++ ") at phase " ++ shortShow p - -- debug $ InternalError $ - -- "No transformer yet created for " ++ shortShow ident ++ - -- " (" ++ show transformerName ++ ") at phase " ++ shortShow p - Just other -> error "debug $ ValueNotMacro other" + Just other -> debug $ ValueNotMacro $ constructErrorType "expected macro but got value" other | otherwise = case prob of ModuleDest {} -> From cc5cbb20c70e599024bd1d8a33b994edb2bebe09 Mon Sep 17 00:00:00 2001 From: Jeffrey Young Date: Wed, 8 Jan 2025 14:09:18 -0500 Subject: [PATCH 19/23] fixup: Expander errors point to an estate --- src/Expander/Error.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Expander/Error.hs b/src/Expander/Error.hs index 154498c3..0e5147d5 100644 --- a/src/Expander/Error.hs +++ b/src/Expander/Error.hs @@ -51,8 +51,8 @@ data ExpansionErr | NotExportSpec Syntax | UnknownPattern Syntax | MacroRaisedSyntaxError (SyntaxError Syntax) - | MacroEvaluationError Phase EvalError - | ValueNotMacro Value + | MacroEvaluationError Phase EState + | ValueNotMacro EState | ValueNotSyntax Value | ImportError KlisterPathError | InternalError String From c8b2b6c14345032fe33853fcac99e4f7d44b9028 Mon Sep 17 00:00:00 2001 From: Jeffrey Young Date: Wed, 8 Jan 2025 14:24:10 -0500 Subject: [PATCH 20/23] wrk: correct pretty output --- examples/non-examples/bad-lexical-env.golden | 3 +-- examples/non-examples/circular-1.golden | 3 +-- examples/non-examples/circular-2.golden | 3 +-- examples/non-examples/error.golden | 5 ++++- examples/non-examples/missing-import.golden | 3 +-- examples/non-examples/stack-traces/error-in-arg.golden | 3 +-- .../non-examples/stack-traces/error-in-bind-head.golden | 6 ++---- .../non-examples/stack-traces/error-in-bind-tail.golden | 6 +----- .../stack-traces/error-in-case-constructor.golden | 3 +-- .../non-examples/stack-traces/error-in-cons-head.golden | 3 +-- .../non-examples/stack-traces/error-in-constructor.golden | 6 ++---- examples/non-examples/stack-traces/error-in-let.golden | 6 ++---- examples/non-examples/stack-traces/error-in-list.golden | 3 +-- .../non-examples/stack-traces/error-in-pure-macro.golden | 3 +-- examples/non-examples/stack-traces/in-arg-error.golden | 7 +------ examples/non-examples/type-errors.golden | 7 +------ 16 files changed, 22 insertions(+), 48 deletions(-) diff --git a/examples/non-examples/bad-lexical-env.golden b/examples/non-examples/bad-lexical-env.golden index 91dd5014..dd828932 100644 --- a/examples/non-examples/bad-lexical-env.golden +++ b/examples/non-examples/bad-lexical-env.golden @@ -1,2 +1 @@ -Unknown: #[bad-lexical-env.kl:3.24-3.25] - +Unknown: #[bad-lexical-env.kl:3.24-3.25] diff --git a/examples/non-examples/circular-1.golden b/examples/non-examples/circular-1.golden index 175f27f5..9286ba32 100644 --- a/examples/non-examples/circular-1.golden +++ b/examples/non-examples/circular-1.golden @@ -1,5 +1,4 @@ -Circular imports while importing - "examples/non-examples/circular-1.kl" +Circular imports while importing "examples/non-examples/circular-1.kl" Context: "examples/non-examples/circular-2.kl" "examples/non-examples/circular-1.kl" diff --git a/examples/non-examples/circular-2.golden b/examples/non-examples/circular-2.golden index c1497afb..e1877098 100644 --- a/examples/non-examples/circular-2.golden +++ b/examples/non-examples/circular-2.golden @@ -1,5 +1,4 @@ -Circular imports while importing - "examples/non-examples/circular-2.kl" +Circular imports while importing "examples/non-examples/circular-2.kl" Context: "examples/non-examples/circular-1.kl" "examples/non-examples/circular-2.kl" diff --git a/examples/non-examples/error.golden b/examples/non-examples/error.golden index 4059bbee..85cc52bc 100644 --- a/examples/non-examples/error.golden +++ b/examples/non-examples/error.golden @@ -1 +1,4 @@ -Error at phase p0: error.kl:3.18-3.34: "It went wrong." +Error at phase p0: + error.kl:3.18-3.34: "It went wrong." + stack trace: + ---- Halt diff --git a/examples/non-examples/missing-import.golden b/examples/non-examples/missing-import.golden index 912aa2ca..e8213f82 100644 --- a/examples/non-examples/missing-import.golden +++ b/examples/non-examples/missing-import.golden @@ -1,2 +1 @@ -missing-import.kl:3.22-3.27: - Not available at phase p0: magic +missing-import.kl:3.22-3.27: Not available at phase p0: magic diff --git a/examples/non-examples/stack-traces/error-in-arg.golden b/examples/non-examples/stack-traces/error-in-arg.golden index 0452b8ff..d5bf6247 100644 --- a/examples/non-examples/stack-traces/error-in-arg.golden +++ b/examples/non-examples/stack-traces/error-in-arg.golden @@ -1,6 +1,5 @@ Error at phase p0: - error-in-arg.kl:5.24-5.27: - bad + error-in-arg.kl:5.24-5.27: bad stack trace: ---- with function # ---- Halt diff --git a/examples/non-examples/stack-traces/error-in-bind-head.golden b/examples/non-examples/stack-traces/error-in-bind-head.golden index 63abedfc..9296adce 100644 --- a/examples/non-examples/stack-traces/error-in-bind-head.golden +++ b/examples/non-examples/stack-traces/error-in-bind-head.golden @@ -1,9 +1,7 @@ Error at phase p0: - error-in-bind-head.kl:3.29-3.30: - e + error-in-bind-head.kl:3.29-3.30: e stack trace: ---- in pure macro ---- in bind macro head - λx. - pure x + λx. pure x ---- Halt diff --git a/examples/non-examples/stack-traces/error-in-bind-tail.golden b/examples/non-examples/stack-traces/error-in-bind-tail.golden index d896cf94..691e01f1 100644 --- a/examples/non-examples/stack-traces/error-in-bind-tail.golden +++ b/examples/non-examples/stack-traces/error-in-bind-tail.golden @@ -1,5 +1 @@ -pure #[error-in-bind-tail.kl:4.15-4.28] - ->>= -# : ∀(α : *). - (Macro α) +pure #[error-in-bind-tail.kl:4.15-4.28] >>= # : ∀(α : *). (Macro α) diff --git a/examples/non-examples/stack-traces/error-in-case-constructor.golden b/examples/non-examples/stack-traces/error-in-case-constructor.golden index 5c3d8507..77fd034a 100644 --- a/examples/non-examples/stack-traces/error-in-case-constructor.golden +++ b/examples/non-examples/stack-traces/error-in-case-constructor.golden @@ -1,6 +1,5 @@ Error at phase p0: - error-in-case-constructor.kl:12.20-12.31: - Im-an-error + error-in-case-constructor.kl:12.20-12.31: Im-an-error stack trace: ---- in data case pattern: l ---- Halt diff --git a/examples/non-examples/stack-traces/error-in-cons-head.golden b/examples/non-examples/stack-traces/error-in-cons-head.golden index 988b492f..171cd460 100644 --- a/examples/non-examples/stack-traces/error-in-cons-head.golden +++ b/examples/non-examples/stack-traces/error-in-cons-head.golden @@ -1,2 +1 @@ -Unknown: #[error-in-cons-head.kl:8.6-8.9] - +Unknown: #[error-in-cons-head.kl:8.6-8.9] diff --git a/examples/non-examples/stack-traces/error-in-constructor.golden b/examples/non-examples/stack-traces/error-in-constructor.golden index 040b8f3d..2ce0521f 100644 --- a/examples/non-examples/stack-traces/error-in-constructor.golden +++ b/examples/non-examples/stack-traces/error-in-constructor.golden @@ -1,9 +1,7 @@ Error at phase p0: - error-in-constructor.kl:17.45-17.56: - Im-an-error + error-in-constructor.kl:17.45-17.56: Im-an-error stack trace: ---- in constructor pair in field 2 - ---- in let #[error-in-constructor.kl:17.22-17.24] - !!(Var 395597)!! + ---- in let #[error-in-constructor.kl:17.22-17.24]!!(Var 395561)!! ---- Halt diff --git a/examples/non-examples/stack-traces/error-in-let.golden b/examples/non-examples/stack-traces/error-in-let.golden index 2273dcf5..f93d0574 100644 --- a/examples/non-examples/stack-traces/error-in-let.golden +++ b/examples/non-examples/stack-traces/error-in-let.golden @@ -1,8 +1,6 @@ Error at phase p0: - error-in-let.kl:4.42-4.53: - Im-an-error + error-in-let.kl:4.42-4.53: Im-an-error stack trace: ---- with function # - ---- in let #[error-in-let.kl:4.22-4.24] - !!(Var 382159)!! + ---- in let #[error-in-let.kl:4.22-4.24]!!(Var 382123)!! ---- Halt diff --git a/examples/non-examples/stack-traces/error-in-list.golden b/examples/non-examples/stack-traces/error-in-list.golden index ee557994..52a17384 100644 --- a/examples/non-examples/stack-traces/error-in-list.golden +++ b/examples/non-examples/stack-traces/error-in-list.golden @@ -1,5 +1,4 @@ Error at phase p0: - error-in-list.kl:7.27-7.38: - Im-an-error + error-in-list.kl:7.27-7.38: Im-an-error stack trace: ---- Halt diff --git a/examples/non-examples/stack-traces/error-in-pure-macro.golden b/examples/non-examples/stack-traces/error-in-pure-macro.golden index 71f48210..fb32fe25 100644 --- a/examples/non-examples/stack-traces/error-in-pure-macro.golden +++ b/examples/non-examples/stack-traces/error-in-pure-macro.golden @@ -1,6 +1,5 @@ Error at phase p0: - error-in-pure-macro.kl:3.24-3.38: - surprise-error + error-in-pure-macro.kl:3.24-3.38: surprise-error stack trace: ---- in pure macro ---- Halt diff --git a/examples/non-examples/stack-traces/in-arg-error.golden b/examples/non-examples/stack-traces/in-arg-error.golden index 5e4a06b8..fa38ecbe 100644 --- a/examples/non-examples/stack-traces/in-arg-error.golden +++ b/examples/non-examples/stack-traces/in-arg-error.golden @@ -1,6 +1 @@ -Type mismatch at - in-arg-error.kl:5.23-5.38. -Expected - Syntax -but got - String +Type mismatch at in-arg-error.kl:5.23-5.38. Expected Syntax but got String diff --git a/examples/non-examples/type-errors.golden b/examples/non-examples/type-errors.golden index 73a01fa9..a7ec0107 100644 --- a/examples/non-examples/type-errors.golden +++ b/examples/non-examples/type-errors.golden @@ -1,6 +1 @@ -Type mismatch at - type-errors.kl:3.36-3.37. -Expected - Syntax -but got - Integer +Type mismatch at type-errors.kl:3.36-3.37. Expected Syntax but got Integer From 7562faa3d2ae38451116cea1e4adc0774acc096b Mon Sep 17 00:00:00 2001 From: Jeffrey Young Date: Sat, 1 Feb 2025 21:35:05 -0500 Subject: [PATCH 21/23] wrk: correct applyInEnv environment --- src/Evaluator.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Evaluator.hs b/src/Evaluator.hs index 30af4cc0..d51e691c 100644 --- a/src/Evaluator.hs +++ b/src/Evaluator.hs @@ -529,7 +529,7 @@ applyInEnv old_env (FO (FOClosure {..})) value = let env = Env.insert _closureVar _closureIdent value - (_closureEnv <> old_env) + (_closureEnv) in evaluateIn env _closureBody applyInEnv _ (HO prim) value = return $! prim value From e7228231cb8d0469f2b76aa18b29d90fb11f916f Mon Sep 17 00:00:00 2001 From: Jeffrey Young Date: Sat, 15 Feb 2025 15:36:53 -0500 Subject: [PATCH 22/23] wrk: track closure names of primitives --- src/Evaluator.hs | 10 ++++---- src/Expander.hs | 48 +++++++++++++++++++------------------- src/Expander/Primitives.hs | 15 ++++++------ src/Pretty.hs | 12 ++++++---- src/Value.hs | 11 ++++++--- 5 files changed, 53 insertions(+), 43 deletions(-) diff --git a/src/Evaluator.hs b/src/Evaluator.hs index d51e691c..e9b333c7 100644 --- a/src/Evaluator.hs +++ b/src/Evaluator.hs @@ -162,6 +162,7 @@ data Kont where the host's runtime instead of in the evaluator but doing so would mean that the debugger would not be able to capture the pattern that was matched. -} + InPrim :: !Text -> !Kont -> Kont InCasePattern :: !SyntaxPattern -> !Kont -> Kont InDataCasePattern :: !ConstructorPattern -> !Kont -> Kont @@ -252,6 +253,7 @@ step (Up v e k) = (\err -> Er err env kont) -- Case passthroughs, see the Note [InCasePattern] + (InPrim _ kont) -> Up v e kont (InCasePattern _ kont) -> Up v e kont (InDataCasePattern _ kont) -> Up v e kont @@ -525,13 +527,13 @@ evalAsType v on_success on_error = other -> on_error (evalErrorType "type" other) applyInEnv :: VEnv -> Closure -> Value -> Either EState Value -applyInEnv old_env (FO (FOClosure {..})) value = +applyInEnv _old_env (FO (FOClosure {..})) value = let env = Env.insert _closureVar _closureIdent value (_closureEnv) in evaluateIn env _closureBody -applyInEnv _ (HO prim) value = return $! prim value +applyInEnv _ (HO _n prim) value = return $! prim value apply :: Closure -> Value -> Either EState Value apply (FO (FOClosure {..})) value = @@ -540,7 +542,7 @@ apply (FO (FOClosure {..})) value = value _closureEnv in evaluateIn env _closureBody -apply (HO prim) value = return $! prim value +apply (HO _n prim) value = return $! prim value applyAsClosure :: VEnv -> Value -> Value -> Kont -> EState applyAsClosure e v_closure value k = case v_closure of @@ -550,7 +552,7 @@ applyAsClosure e v_closure value k = case v_closure of where app (FO (FOClosure{..})) = let env = Env.insert _closureVar _closureIdent value (_closureEnv <> e) in Down (unCore _closureBody) env k - app (HO prim) = Up (prim value) mempty k + app (HO n prim) = Up (prim value) mempty (InPrim n k) -- | predicate to check for done state final :: EState -> Bool diff --git a/src/Expander.hs b/src/Expander.hs index 32c3f89b..e4ce3cb1 100644 --- a/src/Expander.hs +++ b/src/Expander.hs @@ -405,7 +405,7 @@ initializeKernel outputChannel = do funPrims = [ ( "open-syntax" , Scheme [] $ tFun [tSyntax] (Prims.primitiveDatatype "Syntax-Contents" [tSyntax]) - , ValueClosure $ HO $ + , ValueClosure $ HO "open-syntax" $ \(ValueSyntax stx) -> case syntaxE stx of Id name -> @@ -423,11 +423,11 @@ initializeKernel outputChannel = do , ( "close-syntax" , Scheme [] $ tFun [tSyntax, tSyntax, Prims.primitiveDatatype "Syntax-Contents" [tSyntax]] tSyntax - , ValueClosure $ HO $ + , ValueClosure $ HO "close-syntax" $ \(ValueSyntax locStx) -> - ValueClosure $ HO $ + ValueClosure $ HO "close-syntax2" $ \(ValueSyntax scopesStx) -> - ValueClosure $ HO $ + ValueClosure $ HO "close-syntax3" $ -- N.B. Assuming correct constructors \(ValueCtor ctor [arg]) -> let close x = Syntax $ Stx (view (unSyntax . stxScopeSet) scopesStx) (stxLoc locStx) x @@ -457,9 +457,9 @@ initializeKernel outputChannel = do ] ++ [ ( "string=?" , Scheme [] $ tFun [tString, tString] (Prims.primitiveDatatype "Bool" []) - , ValueClosure $ HO $ + , ValueClosure $ HO "string=? operator" $ \(ValueString str1) -> - ValueClosure $ HO $ + ValueClosure $ HO "string=? operand" $ \(ValueString str2) -> if str1 == str2 then primitiveCtor "true" [] @@ -467,26 +467,26 @@ initializeKernel outputChannel = do ) , ( "string-append" , Scheme [] $ tFun [tString, tString] tString - , ValueClosure $ HO $ + , ValueClosure $ HO "string-append-l" $ \(ValueString str1) -> - ValueClosure $ HO $ + ValueClosure $ HO "string-append-r" $ \(ValueString str2) -> ValueString (str1 <> str2) ) , ( "integer->string" , Scheme [] $ tFun [tInteger] tString - , ValueClosure $ HO $ + , ValueClosure $ HO "integer->string" $ \(ValueInteger int) -> ValueString (T.pack (show int)) ) , ( "substring" , Scheme [] $ tFun [tInteger, tInteger, tString] (Prims.primitiveDatatype "Maybe" [tString]) - , ValueClosure $ HO $ + , ValueClosure $ HO "substing" $ \(ValueInteger (fromInteger -> start)) -> - ValueClosure $ HO $ + ValueClosure $ HO "substring2" $ \(ValueInteger (fromInteger -> len)) -> - ValueClosure $ HO $ + ValueClosure $ HO "substring3" $ \(ValueString str) -> if | start < 0 || start >= T.length str -> primitiveCtor "nothing" [] | len < 0 || start + len > T.length str -> primitiveCtor "nothing" [] @@ -495,23 +495,23 @@ initializeKernel outputChannel = do ) , ( "string-length" , Scheme [] $ tFun [tString] tInteger - , ValueClosure $ HO $ \(ValueString str) -> ValueInteger $ toInteger $ T.length str + , ValueClosure $ HO "string-length" $ \(ValueString str) -> ValueInteger $ toInteger $ T.length str ) , ( "string-downcase" , Scheme [] $ tFun [tString] tString - , ValueClosure $ HO $ \(ValueString str) -> ValueString $ T.toLower str + , ValueClosure $ HO "string-downcase" $ \(ValueString str) -> ValueString $ T.toLower str ) , ( "string-upcase" , Scheme [] $ tFun [tString] tString - , ValueClosure $ HO $ \(ValueString str) -> ValueString $ T.toUpper str + , ValueClosure $ HO "string-upcase" $ \(ValueString str) -> ValueString $ T.toUpper str ) , ( "string-titlecase" , Scheme [] $ tFun [tString] tString - , ValueClosure $ HO $ \(ValueString str) -> ValueString $ T.toTitle str + , ValueClosure $ HO "string-titlecase" $ \(ValueString str) -> ValueString $ T.toTitle str ) , ( "string-foldcase" , Scheme [] $ tFun [tString] tString - , ValueClosure $ HO $ \(ValueString str) -> ValueString $ T.toCaseFold str + , ValueClosure $ HO "string-foldcase" $ \(ValueString str) -> ValueString $ T.toCaseFold str ) ] ++ [ ( "string" <> name <> "?" @@ -541,7 +541,7 @@ initializeKernel outputChannel = do ] ++ [ ("pure-IO" , Scheme [KStar, KStar] $ tFun [tSchemaVar 0 []] (tIO (tSchemaVar 0 [])) - , ValueClosure $ HO $ \v -> ValueIOAction (pure v) + , ValueClosure $ HO "pure-IO" $ \v -> ValueIOAction (pure v) ) , ("bind-IO" , Scheme [KStar, KStar] $ @@ -549,12 +549,12 @@ initializeKernel outputChannel = do , tFun [tSchemaVar 0 []] (tIO (tSchemaVar 1 [])) ] (tIO (tSchemaVar 1 [])) - , ValueClosure $ HO $ \(ValueIOAction mx) -> do - ValueClosure $ HO $ \(ValueClosure f) -> do + , ValueClosure $ HO "action" $ \(ValueIOAction mx) -> do + ValueClosure $ HO "closure" $ \(ValueClosure f) -> do ValueIOAction $ do vx <- mx vioy <- case f of - HO fun -> pure (fun vx) + HO _str fun -> pure (fun vx) FO clos -> do let env = view closureEnv clos var = view closureVar clos @@ -572,9 +572,9 @@ initializeKernel outputChannel = do ) , ( "write" , Scheme [] $ tFun [tOutputPort, tString] (tIO (Prims.primitiveDatatype "Unit" [])) - , ValueClosure $ HO $ + , ValueClosure $ HO "write" $ \(ValueOutputPort h) -> - ValueClosure $ HO $ + ValueClosure $ HO "write" $ \(ValueString str) -> ValueIOAction $ do T.hPutStr h str @@ -1454,7 +1454,7 @@ interpretMacroAction prob = MacroActionIntroducer -> do sc <- freshScope "User introduction scope" pure $ Done $ - ValueClosure $ HO \(ValueCtor ctor []) -> ValueClosure $ HO \(ValueSyntax stx) -> + ValueClosure $ HO "one" \(ValueCtor ctor []) -> ValueClosure $ HO "two" \(ValueSyntax stx) -> ValueSyntax case view (constructorName . constructorNameText) ctor of "add" -> addScope' sc stx diff --git a/src/Expander/Primitives.hs b/src/Expander/Primitives.hs index 65821cd4..72fe89b5 100644 --- a/src/Expander/Primitives.hs +++ b/src/Expander/Primitives.hs @@ -6,6 +6,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS -Wno-name-shadowing #-} + module Expander.Primitives ( -- * Declaration primitives define @@ -748,23 +749,23 @@ primitiveDatatype name args = unaryIntegerPrim :: (Integer -> Integer) -> Value unaryIntegerPrim f = - ValueClosure $ HO $ + ValueClosure $ HO "TODO:Jeff:WHAT-TO-PUT-HERE" $ \(ValueInteger i) -> ValueInteger (f i) binaryIntegerPrim :: (Integer -> Integer -> Integer) -> Value binaryIntegerPrim f = - ValueClosure $ HO $ + ValueClosure $ HO "bil" $ \(ValueInteger i1) -> - ValueClosure $ HO $ + ValueClosure $ HO "bir" $ \(ValueInteger i2) -> ValueInteger (f i1 i2) binaryIntegerPred :: (Integer -> Integer -> Bool) -> Value binaryIntegerPred f = - ValueClosure $ HO $ + ValueClosure $ HO "bipl" $ \(ValueInteger i1) -> - ValueClosure $ HO $ + ValueClosure $ HO "bipr" $ \(ValueInteger i2) -> if f i1 i2 then primitiveCtor "true" [] @@ -773,9 +774,9 @@ binaryIntegerPred f = binaryStringPred :: (Text -> Text -> Bool) -> Value binaryStringPred f = - ValueClosure $ HO $ + ValueClosure $ HO "bsp-l" $ \(ValueString str1) -> - ValueClosure $ HO $ + ValueClosure $ HO "bsp-r" $ \(ValueString str2) -> if f str1 str2 then primitiveCtor "true" [] diff --git a/src/Pretty.hs b/src/Pretty.hs index b452de73..21d2fc96 100644 --- a/src/Pretty.hs +++ b/src/Pretty.hs @@ -523,7 +523,8 @@ instance Pretty VarInfo (ExprF Syntax) where pp env (List xs) = parens (group (vsep (map (pp env . syntaxE) xs))) instance Pretty VarInfo Closure where - pp _ _ = text "#" + pp _ (FO fo) = "#<" <> text (_stxValue (_closureIdent fo)) <> ">" + pp _ (HO n _) = "#<" <> text n <> ">" instance Pretty VarInfo Value where pp env (ValueClosure c) = pp env c @@ -709,10 +710,13 @@ printStack _ Down{} = hang 2 $ text "down" printKont :: Env Var () -> Kont -> Doc VarInfo -- the basics printKont _ Halt = text "Halt" +printKont e (InPrim prim k) = text "in prim" <+> pp e prim <> pp e k printKont e (InFun arg _env k) = text "with arg" <+> pp e arg <> pp e k printKont e (InArg fun _env k) = text "with function" <+> pp e fun <> pp e k -printKont e (InLetDef name _var body _env k) = text "in let" <+> pp e name - <> pp e body <> pp e k +printKont e (InLetDef name _var _body _env k) = text "in let" <+> pp e name + -- TODO: the body prints out uniques instead of the var name + -- <> pp e body + <> pp e k -- constructors printKont e (InCtor field_vals con _f_to_process _env k) = @@ -828,5 +832,3 @@ printKont e (InLog _ k) = pp e k -- would require a passthrough printKont e (InError _ k) = pp e k printKont e (InSyntaxErrorMessage _ _ k) = pp e k printKont e (InSyntaxErrorLocations _ _ _ _ k) = pp e k - --- START: figure out how to test the cons cases diff --git a/src/Value.hs b/src/Value.hs index a6629458..12048035 100644 --- a/src/Value.hs +++ b/src/Value.hs @@ -52,7 +52,11 @@ primitiveCtor name args = in ValueCtor ctor args valueText :: Value -> Text -valueText (ValueClosure _) = "#" +valueText (ValueClosure c) = "#<" <> the_closure <> ">" + where + the_closure = case c of + (FO fo) -> _stxValue $ _closureIdent fo + (HO n _) -> n valueText (ValueSyntax stx) = "'" <> syntaxText stx valueText (ValueMacroAction _) = "#" valueText (ValueIOAction _) = "#" @@ -84,10 +88,11 @@ data FOClosure = FOClosure , _closureBody :: Core } -data Closure = FO FOClosure | HO (Value -> Value) +data Closure = FO FOClosure | HO Text (Value -> Value) instance Show Closure where - show _ = "Closure {...}" + show (FO fo) = "Closure {" <> show (_closureIdent fo) <> "}" + show (HO name _) = "Closure {" <> show name <> "}" makePrisms ''MacroAction makePrisms ''Value From 4ebb0666b9336209b61ba4a837e74c7481faff83 Mon Sep 17 00:00:00 2001 From: Jeffrey Young Date: Sat, 15 Feb 2025 15:37:14 -0500 Subject: [PATCH 23/23] wrk: update golden samples --- examples/contract.golden | 8 +-- examples/datatypes.golden | 6 +- examples/error.golden | 2 +- examples/eta-case.golden | 8 +-- examples/fix.golden | 2 +- examples/higher-kinded.golden | 6 +- examples/implicit-conversion-test.golden | 2 +- examples/monad.golden | 12 ++-- .../stack-traces/error-in-arg.golden | 2 +- .../stack-traces/error-in-bind-tail.golden | 2 +- .../stack-traces/error-in-bind-tail.kl | 4 +- .../stack-traces/error-in-constructor.golden | 2 +- .../stack-traces/error-in-let.golden | 4 +- examples/prelude-test.golden | 6 +- examples/primitives-documentation.golden | 68 +++++++++---------- examples/product-type.golden | 2 +- examples/tiny-types.golden | 6 +- examples/unknown-type.golden | 4 +- examples/which-problem.golden | 8 +-- 19 files changed, 77 insertions(+), 77 deletions(-) diff --git a/examples/contract.golden b/examples/contract.golden index 2e003d5d..b163b06b 100644 --- a/examples/contract.golden +++ b/examples/contract.golden @@ -1,5 +1,5 @@ -# : (Syntax → Syntax) -# : (Syntax → (Syntax → (Syntax → (Macro Syntax)))) -# : (Syntax → (Syntax → (Syntax → (Macro Syntax)))) -# : ∀(α : *). (α → α) +# : (Syntax → Syntax) +# : (Syntax → (Syntax → (Syntax → (Macro Syntax)))) +# : (Syntax → (Syntax → (Syntax → (Macro Syntax)))) +# : ∀(α : *). (α → α) (true) : Bool diff --git a/examples/datatypes.golden b/examples/datatypes.golden index 5ce50eeb..07495cd3 100644 --- a/examples/datatypes.golden +++ b/examples/datatypes.golden @@ -3,9 +3,9 @@ (add1 (add1 (add1 (add1 (zero))))) : Nat (right (true)) : ∀(α : *). (Either α Bool) (left (:: (add1 (zero)) (nil))) : ∀(α : *). (Either (List Nat) α) -# : (Nat → (Nat → Nat)) +# : (Nat → (Nat → Nat)) (add1 (add1 (add1 (add1 (add1 (zero)))))) : Nat -# : (Alphabet → Integer) -# : (Alphabet → Bool) +# : (Alphabet → Integer) +# : (Alphabet → Bool) (true) : Bool (false) : Bool diff --git a/examples/error.golden b/examples/error.golden index 2f715be2..7a8bb500 100644 --- a/examples/error.golden +++ b/examples/error.golden @@ -1 +1 @@ -# : ∀(α : *). (Syntax → α) +# : ∀(α : *). (Syntax → α) diff --git a/examples/eta-case.golden b/examples/eta-case.golden index a7d403f3..4796258b 100644 --- a/examples/eta-case.golden +++ b/examples/eta-case.golden @@ -10,11 +10,11 @@ #[eta-case.kl:225.13-225.20]<((eta-case-aux ...) (::))> : Syntax #[eta-case.kl:243.19-243.22] <(eta-case-aux (list 1 2 3) (::) (pair) ((nil) (pair 0 (nil))))> : Syntax -# : ∀(α : *). (α → ((List α) → (List α))) -# : ((List Integer) → (List Integer)) +# : ∀(α : *). (α → ((List α) → (List α))) +# : ((List Integer) → (List Integer)) (:: 1 (:: 2 (:: 3 (nil)))) : (List Integer) -# : ∀(α : *). (α → ((List α) → (List α))) -# : ((List Integer) → (List Integer)) +# : ∀(α : *). (α → ((List α) → (List α))) +# : ((List Integer) → (List Integer)) (:: 1 (:: 2 (:: 3 (nil)))) : (List Integer) (pair 1 (:: 2 (:: 3 (nil)))) : (Pair Integer (List Integer)) (pair 1 (:: 2 (:: 3 (nil)))) : (Pair Integer (List Integer)) diff --git a/examples/fix.golden b/examples/fix.golden index 01f89732..16de42ea 100644 --- a/examples/fix.golden +++ b/examples/fix.golden @@ -1,7 +1,7 @@ (in (cons "hello" (in (cons "world" (in (nil)))))) : (Fix (ListF String)) (in (cons "hello" (in (cons "world" (in (nil)))))) : (Fix (ListF String)) (in (succ (in (succ (in (zero)))))) : (Fix NatF) -# : ∀(α : *) (β : *). ((α → β) → ((Fix (ListF α)) → (Fix (ListF β)))) +# : ∀(α : *) (β : *). ((α → β) → ((Fix (ListF α)) → (Fix (ListF β)))) (in (cons (in (succ (in (succ (in (zero)))))) (in (cons (in (succ (in (succ (in (succ (in (zero)))))))) (in (nil)))))) : (Fix (ListF (Fix NatF))) diff --git a/examples/higher-kinded.golden b/examples/higher-kinded.golden index 094e34b5..c09a887b 100644 --- a/examples/higher-kinded.golden +++ b/examples/higher-kinded.golden @@ -1,7 +1,7 @@ (of-unit #) : (OfUnit IO) -(of-unit #) : (OfUnit (→ Unit)) +(of-unit #) : (OfUnit (→ Unit)) (of-unit (just (unit))) : (OfUnit Maybe) (of-unit (pair (unit) (unit))) : (OfUnit (Pair Unit)) -(of-unit-unit #) : (OfUnitUnit (→)) -(of-unit-unit #) : (OfUnitUnit (→)) +(of-unit-unit #) : (OfUnitUnit (→)) +(of-unit-unit #) : (OfUnitUnit (→)) (of-unit-unit (pair (unit) (unit))) : (OfUnitUnit Pair) diff --git a/examples/implicit-conversion-test.golden b/examples/implicit-conversion-test.golden index 900459ae..29156fc6 100644 --- a/examples/implicit-conversion-test.golden +++ b/examples/implicit-conversion-test.golden @@ -1,5 +1,5 @@ 42 : Integer 4 : Integer "4!" : String -# : (Integer → Integer) +# : (Integer → Integer) "31!" : String diff --git a/examples/monad.golden b/examples/monad.golden index 502d2f90..1df5f6f7 100644 --- a/examples/monad.golden +++ b/examples/monad.golden @@ -1,14 +1,14 @@ -# : ∀(α : *). (α → α) -# : ∀(α : (* → *)) (β : *) (γ : *). ((Functor α β γ) → ((β → γ) → ((α β) → (α γ)))) -(applicative (functor #) # #) : ∀(α : *) (β : *). (Applicative Macro α β) -# : ∀(α : (* → *)) (β : *) (γ : *). ((Applicative α β γ) → (β → (α β))) -# : ∀(α : (* → *)) (β : *) (γ : *). +# : ∀(α : *). (α → α) +# : ∀(α : (* → *)) (β : *) (γ : *). ((Functor α β γ) → ((β → γ) → ((α β) → (α γ)))) +(applicative (functor #) # #) : ∀(α : *) (β : *). (Applicative Macro α β) +# : ∀(α : (* → *)) (β : *) (γ : *). ((Applicative α β γ) → (β → (α β))) +# : ∀(α : (* → *)) (β : *) (γ : *). ((Applicative α β γ) → ((α (β → γ)) → ((α β) → (α γ)))) (just "applicative notation") : (Maybe String) (nothing) : (Maybe String) (just "applicative notation") : (Maybe String) (nothing) : (Maybe String) -# : ∀(α : (* → *)) (β : *) (γ : *). +# : ∀(α : (* → *)) (β : *) (γ : *). ((Monad α β γ) → ((α β) → ((β → (α γ)) → (α γ)))) (just "hey") : (Maybe String) (just "hey") : (Maybe String) diff --git a/examples/non-examples/stack-traces/error-in-arg.golden b/examples/non-examples/stack-traces/error-in-arg.golden index d5bf6247..327846fc 100644 --- a/examples/non-examples/stack-traces/error-in-arg.golden +++ b/examples/non-examples/stack-traces/error-in-arg.golden @@ -1,5 +1,5 @@ Error at phase p0: error-in-arg.kl:5.24-5.27: bad stack trace: - ---- with function # + ---- with function # ---- Halt diff --git a/examples/non-examples/stack-traces/error-in-bind-tail.golden b/examples/non-examples/stack-traces/error-in-bind-tail.golden index 691e01f1..01d413cf 100644 --- a/examples/non-examples/stack-traces/error-in-bind-tail.golden +++ b/examples/non-examples/stack-traces/error-in-bind-tail.golden @@ -1 +1 @@ -pure #[error-in-bind-tail.kl:4.15-4.28] >>= # : ∀(α : *). (Macro α) +pure #[error-in-bind-tail.kl:4.15-4.28] >>= # : ∀(α : *). (Macro α) diff --git a/examples/non-examples/stack-traces/error-in-bind-tail.kl b/examples/non-examples/stack-traces/error-in-bind-tail.kl index 419c489f..9d1e2ab3 100644 --- a/examples/non-examples/stack-traces/error-in-bind-tail.kl +++ b/examples/non-examples/stack-traces/error-in-bind-tail.kl @@ -3,6 +3,6 @@ (example (>>= (pure 'hello-go-boom) (lambda (x) - (>>= (syntax-error x) + (>>= (pure x) -- TODO: why doesn't this work? - (lambda (y) (pure y)))))) \ No newline at end of file + (lambda (y) (error y)))))) \ No newline at end of file diff --git a/examples/non-examples/stack-traces/error-in-constructor.golden b/examples/non-examples/stack-traces/error-in-constructor.golden index 2ce0521f..634a282f 100644 --- a/examples/non-examples/stack-traces/error-in-constructor.golden +++ b/examples/non-examples/stack-traces/error-in-constructor.golden @@ -3,5 +3,5 @@ Error at phase p0: stack trace: ---- in constructor pair in field 2 - ---- in let #[error-in-constructor.kl:17.22-17.24]!!(Var 395561)!! + ---- in let #[error-in-constructor.kl:17.22-17.24] ---- Halt diff --git a/examples/non-examples/stack-traces/error-in-let.golden b/examples/non-examples/stack-traces/error-in-let.golden index f93d0574..c6e35fef 100644 --- a/examples/non-examples/stack-traces/error-in-let.golden +++ b/examples/non-examples/stack-traces/error-in-let.golden @@ -1,6 +1,6 @@ Error at phase p0: error-in-let.kl:4.42-4.53: Im-an-error stack trace: - ---- with function # - ---- in let #[error-in-let.kl:4.22-4.24]!!(Var 382123)!! + ---- with function # + ---- in let #[error-in-let.kl:4.22-4.24] ---- Halt diff --git a/examples/prelude-test.golden b/examples/prelude-test.golden index e4458dc3..472b0675 100644 --- a/examples/prelude-test.golden +++ b/examples/prelude-test.golden @@ -1,4 +1,4 @@ #[prelude-test.kl:3.18-3.19] : Syntax -# : ∀(α : *) (β : *). ((α → β) → (α → β)) -# : ∀(α : *). (α → α) -# : ∀(α : *). (α → α) +# : ∀(α : *) (β : *). ((α → β) → (α → β)) +# : ∀(α : *). (α → α) +# : ∀(α : *). (α → α) diff --git a/examples/primitives-documentation.golden b/examples/primitives-documentation.golden index f92ed433..c7d13f37 100644 --- a/examples/primitives-documentation.golden +++ b/examples/primitives-documentation.golden @@ -1,33 +1,33 @@ -(pair "open-syntax" #) : (Pair String (Syntax → (Syntax-Contents Syntax))) -(pair "close-syntax" #) : (Pair String (Syntax → (Syntax → ((Syntax-Contents Syntax) → Syntax)))) -(pair "+" #) : (Pair String (Integer → (Integer → Integer))) -(pair "-" #) : (Pair String (Integer → (Integer → Integer))) -(pair "*" #) : (Pair String (Integer → (Integer → Integer))) -(pair "/" #) : (Pair String (Integer → (Integer → Integer))) -(pair "abs" #) : (Pair String (Integer → Integer)) -(pair "negate" #) : (Pair String (Integer → Integer)) -(pair ">" #) : (Pair String (Integer → (Integer → Bool))) -(pair ">=" #) : (Pair String (Integer → (Integer → Bool))) -(pair "<" #) : (Pair String (Integer → (Integer → Bool))) -(pair "<=" #) : (Pair String (Integer → (Integer → Bool))) -(pair "=" #) : (Pair String (Integer → (Integer → Bool))) -(pair "/=" #) : (Pair String (Integer → (Integer → Bool))) -(pair "integer->string" #) : (Pair String (Integer → String)) -(pair "string-append" #) : (Pair String (String → (String → String))) -(pair "substring" #) : (Pair String (Integer → (Integer → (String → (Maybe String))))) -(pair "string-length" #) : (Pair String (String → Integer)) -(pair "string=?" #) : (Pair String (String → (String → Bool))) -(pair "string/=?" #) : (Pair String (String → (String → Bool))) -(pair "string) : (Pair String (String → (String → Bool))) -(pair "string<=?" #) : (Pair String (String → (String → Bool))) -(pair "string>?" #) : (Pair String (String → (String → Bool))) -(pair "string>=?" #) : (Pair String (String → (String → Bool))) -(pair "string-upcase" #) : (Pair String (String → String)) -(pair "string-downcase" #) : (Pair String (String → String)) -(pair "string-titlecase" #) : (Pair String (String → String)) -(pair "string-foldcase" #) : (Pair String (String → String)) -(pair "pure-IO" #) : ∀(α : *). (Pair String (α → (IO α))) -(pair "bind-IO" #) : ∀(α : *) (β : *). (Pair String ((IO α) → ((α → (IO β)) → (IO β)))) +(pair "open-syntax" #) : (Pair String (Syntax → (Syntax-Contents Syntax))) +(pair "close-syntax" #) : (Pair String (Syntax → (Syntax → ((Syntax-Contents Syntax) → Syntax)))) +(pair "+" #) : (Pair String (Integer → (Integer → Integer))) +(pair "-" #) : (Pair String (Integer → (Integer → Integer))) +(pair "*" #) : (Pair String (Integer → (Integer → Integer))) +(pair "/" #) : (Pair String (Integer → (Integer → Integer))) +(pair "abs" #) : (Pair String (Integer → Integer)) +(pair "negate" #) : (Pair String (Integer → Integer)) +(pair ">" #) : (Pair String (Integer → (Integer → Bool))) +(pair ">=" #) : (Pair String (Integer → (Integer → Bool))) +(pair "<" #) : (Pair String (Integer → (Integer → Bool))) +(pair "<=" #) : (Pair String (Integer → (Integer → Bool))) +(pair "=" #) : (Pair String (Integer → (Integer → Bool))) +(pair "/=" #) : (Pair String (Integer → (Integer → Bool))) +(pair "integer->string" #string>) : (Pair String (Integer → String)) +(pair "string-append" #) : (Pair String (String → (String → String))) +(pair "substring" #) : (Pair String (Integer → (Integer → (String → (Maybe String))))) +(pair "string-length" #) : (Pair String (String → Integer)) +(pair "string=?" #) : (Pair String (String → (String → Bool))) +(pair "string/=?" #) : (Pair String (String → (String → Bool))) +(pair "string) : (Pair String (String → (String → Bool))) +(pair "string<=?" #) : (Pair String (String → (String → Bool))) +(pair "string>?" #) : (Pair String (String → (String → Bool))) +(pair "string>=?" #) : (Pair String (String → (String → Bool))) +(pair "string-upcase" #) : (Pair String (String → String)) +(pair "string-downcase" #) : (Pair String (String → String)) +(pair "string-titlecase" #) : (Pair String (String → String)) +(pair "string-foldcase" #) : (Pair String (String → String)) +(pair "pure-IO" #) : ∀(α : *). (Pair String (α → (IO α))) +(pair "bind-IO" #) : ∀(α : *) (β : *). (Pair String ((IO α) → ((α → (IO β)) → (IO β)))) (flip) : ScopeAction (add) : ScopeAction (remove) : ScopeAction @@ -43,8 +43,8 @@ (nil) : ∀(α : *). (List α) make-introducer : (Macro (ScopeAction → (Syntax → Syntax))) which-problem : (Macro Problem) -(pair "id" #) : ∀(α : *). (Pair String (α → α)) -(pair "const" #) : ∀(α : *) (β : *). (Pair String (α → (β → α))) -(pair "compose" #) : ∀(α : *) (β : *) (γ : *). (Pair String ((α → β) → ((γ → α) → (γ → β)))) +(pair "id" #) : ∀(α : *). (Pair String (α → α)) +(pair "const" #) : ∀(α : *) (β : *). (Pair String (α → (β → α))) +(pair "compose" #) : ∀(α : *) (β : *) (γ : *). (Pair String ((α → β) → ((γ → α) → (γ → β)))) (pair "stdout" #) : (Pair String Output-Port) -(pair "write" #) : (Pair String (Output-Port → (String → (IO Unit)))) +(pair "write" #) : (Pair String (Output-Port → (String → (IO Unit)))) diff --git a/examples/product-type.golden b/examples/product-type.golden index cfa22906..fdd2b206 100644 --- a/examples/product-type.golden +++ b/examples/product-type.golden @@ -1,2 +1,2 @@ #[product-type.kl:12.23-12.24] : Syntax -# : ∀(α : *) (β : *). ((× α β) → α) +# : ∀(α : *) (β : *). ((× α β) → α) diff --git a/examples/tiny-types.golden b/examples/tiny-types.golden index 7d082367..3b69342d 100644 --- a/examples/tiny-types.golden +++ b/examples/tiny-types.golden @@ -2,10 +2,10 @@ (false) : Bool #[tiny-types.kl:5.25-5.28] : Syntax pure #[tiny-types.kl:6.39-6.42] : (Macro Syntax) -# : (Bool → Bool) -# : (Bool → Syntax) +# : (Bool → Bool) +# : (Bool → Syntax) (free-identifier=? #[tiny-types.kl:10.40-10.41] #[tiny-types.kl:10.43-10.44]) >>= -# : (Macro (Bool → Bool)) +# : (Macro (Bool → Bool)) diff --git a/examples/unknown-type.golden b/examples/unknown-type.golden index 3f4b291b..bdfca69b 100644 --- a/examples/unknown-type.golden +++ b/examples/unknown-type.golden @@ -1,4 +1,4 @@ (nothing) : ∀(α : *). (Maybe α) (just #[unknown-type.kl:24.33-24.37]) : (Maybe Syntax) -(just #) : ∀(α : *). (Maybe (α → α)) -(pair (just #) (nothing)) : ∀(α : *). (Pair (Maybe (α → α)) (Maybe (α → α))) +(just #) : ∀(α : *). (Maybe (α → α)) +(pair (just #) (nothing)) : ∀(α : *). (Pair (Maybe (α → α)) (Maybe (α → α))) diff --git a/examples/which-problem.golden b/examples/which-problem.golden index 558d37f4..d5fa3651 100644 --- a/examples/which-problem.golden +++ b/examples/which-problem.golden @@ -1,9 +1,9 @@ (true) : Bool (true) : Bool -# : (Bool → (Bool → (Bool → (Bool → Unit)))) -# : (Bool → (Bool → (Bool → (Bool → Unit)))) -(both # #) : ∀(α : *) (β : *) (γ : *). (Both (α → (β → (γ → Syntax)))) -(both # #) : ∀(α : *) (β : *) (γ : *). (Both (α → (β → (γ → Syntax)))) +#<_> : (Bool → (Bool → (Bool → (Bool → Unit)))) +#<_> : (Bool → (Bool → (Bool → (Bool → Unit)))) +(both # #<_>) : ∀(α : *) (β : *) (γ : *). (Both (α → (β → (γ → Syntax)))) +(both #<_> #) : ∀(α : *) (β : *) (γ : *). (Both (α → (β → (γ → Syntax)))) "String" : String "String -> String" : String "String -> String -> String" : String