Remove tracing from Purus modules

src/Language/PureScript/CST/Convert.hs

@@ -22,7 +22,7 @@ import Control.Monad.State
 import Data.Bifunctor (bimap, first, second)
 import Data.Bitraversable (Bitraversable (..))
 import Data.Char (toLower)
-import Data.Foldable (foldl', foldrM, toList, traverse_)
+import Data.Foldable (foldrM, toList, traverse_)
 import Data.Functor (($>))
 import Data.List.NonEmpty qualified as NE
 import Data.Map (Map)
@@ -46,7 +46,6 @@ import Language.PureScript.PSString (mkString, prettyPrintStringJS)
 import Language.PureScript.Types qualified as T
 
 import Data.List (partition)
-import Debug.Trace (trace)
 
 type ConvertM a = State (Map Text T.SourceType) a
 
@@ -82,11 +81,10 @@ srcTokenRange = tokRange . tokAnn
    type signature in scope when we convert the declaration.
 
 -}
-groupSignaturesAndDeclarations :: (Show a) => [Declaration a] -> [[Declaration a]]
+groupSignaturesAndDeclarations :: [Declaration a] -> [[Declaration a]]
 groupSignaturesAndDeclarations [] = []
 groupSignaturesAndDeclarations decls =
-  trace ("DECLARATIONS (grouping): \n" <> concatMap ((<> "\n\n") . show) decls) $
-    go kindSigs typeSigs decls'
+  go kindSigs typeSigs decls'
   where
     ((kindSigs, typeSigs), decls') =
       foldr
@@ -239,7 +237,7 @@ convertType' withinVta fileName = go
       TypeForall _ kw bindings _ ty -> do
         -- TODO: Refactor this (if it works)
         let
-          doBind (TypeVarKinded (Wrapped _ (Labeled (v, a) _ b) _)) = do
+          doBind (TypeVarKinded (Wrapped _ (Labeled (_, a) _ b) _)) = do
             let nm = getIdent (nameValue a)
             b' <- go b
             bindTv nm b'
@@ -255,7 +253,7 @@ convertType' withinVta fileName = go
             bindTv nm b'
             pure $ mkForAll a b' v t
           -- TODO: Fix this better
-          k (TypeVarName (v, a)) t = internalError $ "Error: Universally quantified type variable without kind annotation: " <> (Text.unpack . getIdent . nameValue $ a) <> "\nat: " <> show v
+          k (TypeVarName (v, a)) _ = internalError $ "Error: Universally quantified type variable without kind annotation: " <> (Text.unpack . getIdent . nameValue $ a) <> "\nat: " <> show v
         traverse_ doBind bindings
         inner <- go ty
         ty' <- foldrM k inner bindings

src/Language/PureScript/CoreFn/Desugar.hs

@@ -3,7 +3,7 @@
 
 module Language.PureScript.CoreFn.Desugar (moduleToCoreFn) where
 
-import Protolude (Bifunctor (bimap), MonadError (..), orEmpty, ordNub, sortOn, zipWithM)
+import Protolude (MonadError (..), orEmpty, ordNub, sortOn, zipWithM)
 import Prelude
 
 import Data.Foldable (foldl')
@@ -12,15 +12,13 @@ import Data.List.NonEmpty qualified as NEL
 import Data.Map qualified as M
 import Data.Maybe (mapMaybe)
 
-import Control.Monad (foldM, forM, (<=<), (>=>))
+import Control.Monad (foldM, forM, (>=>))
 import Control.Monad.State.Strict (MonadState, gets, modify)
 import Control.Monad.Writer.Class (MonadWriter)
 import Data.Either (lefts)
 import Data.List.NonEmpty qualified as NE
 import Data.Set qualified as S
 import Data.Text qualified as T
-import Data.Text.Lazy qualified as LT
-import Debug.Trace (traceM)
 import Language.PureScript.AST.Binders qualified as A
 import Language.PureScript.AST.Declarations qualified as A
 import Language.PureScript.AST.Literals (Literal (..))
@@ -75,7 +73,6 @@ import Language.PureScript.Environment (
   NameVisibility (..),
   function,
   isDictTypeName,
-  lookupConstructor,
   lookupValue,
   tyBoolean,
   tyChar,
@@ -129,7 +126,7 @@ import Language.PureScript.Types (
   rowToList,
   pattern REmptyKinded,
  )
-import Language.Purus.Pretty (ppType, prettyDatatypes, prettyStr, renderExprStr)
+import Language.Purus.Pretty (ppType)
 import Prettyprinter (Pretty (pretty))
 
 {-
@@ -162,8 +159,7 @@ moduleToCoreFn (A.Module modSS coms mn _decls (Just exps)) = do
   decls' <- concat <$> traverse (declToCoreFn mn) nonDataDecls
   let dataDecls' = mkDataDecls mn dataDecls
       result = Module modSS coms mn (spanName modSS) imports exps' reExps externs decls' dataDecls'
-  traceM $ prettyStr dataDecls'
-  pure $ result
+  pure result
   where
     setModuleName = modify $ \cs ->
       cs {checkCurrentModule = Just mn}
@@ -214,12 +210,8 @@ lookupType sp tn = do
   case M.lookup (Qualified (BySourcePos sp) tn) (names env) of
     Nothing -> case M.lookup (mkQualified tn mn) (names env) of
       Nothing -> error $ "No type found for " <> show tn
-      Just (ty, _, nv) -> do
-        traceM $ "lookupType: " <> showIdent' tn <> " :: " <> ppType 10 ty
-        pure (ty, nv)
-    Just (ty, _, nv) -> do
-      traceM $ "lookupType: " <> showIdent' tn <> " :: " <> ppType 10 ty
-      pure (ty, nv)
+      Just (ty, _, nv) -> pure (ty, nv)
+    Just (ty, _, nv) -> pure (ty, nv)
 
 getInnerListTy :: Type a -> Maybe (Type a)
 getInnerListTy (ListT arr) = Just arr
@@ -234,7 +226,6 @@ getInnerObjectTy _ = Nothing
 
 objectToCoreFn :: forall m. (M m) => ModuleName -> SourceSpan -> SourceType -> SourceType -> [(PSString, A.Expr)] -> m (Expr Ann)
 objectToCoreFn mn ss recTy row objFields = do
-  traceM $ "ObjLitTy: " <> show row
   let (tyFields, _) = rowToList row
       tyMap = M.fromList $ (\x -> (runLabel (rowListLabel x), x)) <$> tyFields
   resolvedFields <- foldM (go tyMap) [] objFields
@@ -273,7 +264,7 @@ declToCoreFn _ (A.DataDeclaration (ss, com) Newtype name _ [ctor]) = wrapTrace (
 declToCoreFn _ d@(A.DataDeclaration _ Newtype _ _ _) =
   error $ "Found newtype with multiple constructors: " ++ show d
 -- Data declarations shouldn't exist here
-declToCoreFn mn (A.DataDeclaration (ss, com) Data tyName _ ctors) =
+declToCoreFn mn (A.DataDeclaration (_, _) Data tyName _ _) =
   error $
     "declToCoreFn: INTERNAL ERROR. Encountered a data declaration in module "
       <> show (pretty mn)
@@ -286,9 +277,7 @@ declToCoreFn mn (A.DataBindingGroupDeclaration ds) = wrapTrace "declToCoreFn DAT
 -- Essentially a wrapper over `exprToCoreFn`. Not 100% sure if binding the type of the declaration is necessary here?
 -- NOTE: Should be impossible to have a guarded expr here, make it an error
 declToCoreFn mn (A.ValueDecl (ss, _) name _ _ [A.MkUnguarded e]) = wrapTrace ("decltoCoreFn VALDEC " <> show name) $ do
-  traceM $ renderValue 100 e
   (valDeclTy, nv) <- lookupType (spanStart ss) name
-  traceM (ppType 100 valDeclTy)
   bindLocalVariables [(ss, name, valDeclTy, nv)] $ do
     expr <- exprToCoreFn mn ss (Just valDeclTy) e -- maybe wrong? might need to bind something here?
     pure [NonRec (ssA ss) name expr]
@@ -318,7 +307,6 @@ exprToCoreFn :: forall m. (M m) => ModuleName -> SourceSpan -> Maybe SourceType
 exprToCoreFn mn ss (Just arrT) astlit@(A.Literal _ (ListLiteral ts))
   | Just ty <- getInnerListTy arrT =
       wrapTrace ("exprToCoreFn ARRAYLIT " <> renderValue 100 astlit) $ do
-        traceM $ ppType 100 arrT
         mkList ty <$> traverse (exprToCoreFn mn ss (Just ty)) ts
 exprToCoreFn _ _ Nothing astlit@(A.Literal _ (ListLiteral _)) =
   internalError $ "Error while desugaring List Literal. No type provided for literal:\n" <> renderValue 100 astlit
@@ -336,7 +324,7 @@ exprToCoreFn _ _ _ (A.Literal ss (NumericLiteral (Right number))) =
   pure $ Literal (ss, [], Nothing) tyNumber (NumericLiteral (Right number))
 exprToCoreFn _ _ _ (A.Literal ss (CharLiteral char)) =
   pure $ Literal (ss, [], Nothing) tyChar (CharLiteral char)
-exprToCoreFn _ _ _ (A.Literal ss (BooleanLiteral boolean)) =
+exprToCoreFn _ _ _ (A.Literal _ (BooleanLiteral boolean)) =
   if boolean then pure true else pure false
 exprToCoreFn _ _ _ (A.Literal ss (StringLiteral string)) =
   pure $ Literal (ss, [], Nothing) tyString (StringLiteral string)
@@ -430,25 +418,17 @@ exprToCoreFn _ _ t lam@(A.Abs _ _) =
 -}
 exprToCoreFn mn ss mTy app@(A.App fun arg)
   | isDictCtor fun = wrapTrace "exprToCoreFn APP DICT " $ do
-      traceM $ "APP Dict type" <> show (ppType 100 <$> mTy)
-      traceM $ "APP Dict expr:\n" <> renderValue 100 app
       let analyzed = mTy >>= analyzeCtor
-          prettyAnalyzed = bimap (ppType 100) (fmap (ppType 100)) <$> analyzed
-      traceM $ "APP DICT analyzed:\n" <> show prettyAnalyzed
       case mTy of
         Just iTy ->
           case analyzed of
             -- Branch for a "normal" (i.e. non-empty) typeclass dictionary application
             Just (TypeConstructor _ (Qualified qb nm), args) -> do
-              traceM $ "APP Dict name: " <> T.unpack (runProperName nm)
               env <- getEnv
               case M.lookup (Qualified qb $ coerceProperName nm) (dataConstructors env) of
                 Just (_, _, ty, _) -> do
-                  traceM $ "APP Dict original type:\n" <> ppType 100 ty
                   case instantiate ty args of
-                    iFun@(iArg :-> iRes) -> do
-                      traceM $ "APP Dict iArg:\n" <> ppType 100 iArg
-                      traceM $ "APP Dict iRes:\n" <> ppType 100 iRes
+                    iFun@(iArg :-> _) -> do
                       fun' <- exprToCoreFn mn ss (Just iFun) fun
                       arg' <- exprToCoreFn mn ss (Just iArg) arg
                       pure $ App (ss, [], Nothing) fun' arg'
@@ -467,12 +447,8 @@ exprToCoreFn mn ss mTy app@(A.App fun arg)
                 _ -> error "An application desguared to something else. This should not be possible."
         Nothing -> error $ "APP Dict w/o type passed in (impossible to infer):\n" <> renderValue 100 app
   | otherwise = wrapTrace "exprToCoreFn APP" $ do
-      traceM $ renderValue 100 app
       fun' <- exprToCoreFn mn ss Nothing fun
-      let funTy = exprType fun'
-      traceM $ "app fun:\n" <> ppType 100 funTy <> "\n" <> renderExprStr fun'
       arg' <- exprToCoreFn mn ss Nothing arg -- We want to keep the original "concrete" arg type
-      traceM $ "app arg:\n" <> ppType 100 (exprType arg') <> "\n" <> renderExprStr arg'
       pure $ App (ss, [], Nothing) fun' arg'
   where
     isDictCtor = \case
@@ -497,7 +473,7 @@ exprToCoreFn _ _ _ (A.Var ss ident) =
         lookupDictType ident >>= \case
           Just ty -> pure $ Var (ss, [], getValueMeta env ident) (purusTy ty) ident
           Nothing -> internalError $ "No known type for identifier " <> show ident
-exprToCoreFn _ _ mty expr@(A.Var ss ident) =
+exprToCoreFn _ _ mty expr@(A.Var _ _) =
   internalError $
     "Internal compiler error (exprToCoreFn var fail): Cannot synthesize type for var "
       <> show expr
@@ -549,18 +525,14 @@ exprToCoreFn _ _ Nothing ctor@(A.Constructor _ _) =
          complexity (machinery is complicated) and would not be good for performance (typechecking
          and inference have bad complexity).
 -}
-exprToCoreFn mn ss (Just caseTy) astCase@(A.Case vs alts) = wrapTrace "exprToCoreFn CASE" $ do
-  traceM $ "CASE:\n" <> renderValue 100 astCase
-  traceM $ "CASE TY:\n" <> show (ppType 100 caseTy)
+exprToCoreFn mn ss (Just caseTy) (A.Case vs alts) = wrapTrace "exprToCoreFn CASE" $ do
   (vs', ts) <- unzip <$> traverse (exprToCoreFn mn ss Nothing >=> (\e -> pure (e, exprType e))) vs -- extract type information for the *scrutinees*
   alts' <- traverse (altToCoreFn mn ss caseTy ts) alts -- see explanation in altToCoreFn. We pass in the types of the scrutinee(s)
   pure $ Case (ssA ss) (purusTy caseTy) vs' alts'
 exprToCoreFn mn ss Nothing astCase@(A.Case vs alts@(alt : _)) = wrapTrace "exprToCoreFn CASE (no type)" $ do
   case alt of
     A.CaseAlternative _ (A.GuardedExpr _ body1 : _) -> do
       caseTy <- exprType <$> exprToCoreFn mn ss Nothing body1
-      traceM $ "CASE:\n" <> renderValue 100 astCase
-      traceM $ "CASE TY:\n" <> show (ppType 100 caseTy)
       (vs', ts) <- unzip <$> traverse (exprToCoreFn mn ss Nothing >=> (\e -> pure (e, exprType e))) vs -- extract type information for the *scrutinees*
       alts' <- traverse (altToCoreFn mn ss caseTy ts) alts -- see explanation in altToCoreFn. We pass in the types of the scrutinee(s)
       pure $ Case (ssA ss) (purusTy caseTy) vs' alts'
@@ -698,16 +670,12 @@ inferBinder' _ (A.LiteralBinder _ (NumericLiteral (Right _))) = wrapTrace "infer
 inferBinder' _ (A.LiteralBinder _ (BooleanLiteral _)) = wrapTrace "inferBinder' BOOLLIT" $ return M.empty
 inferBinder' val (A.VarBinder ss name) = wrapTrace ("inferBinder' VAR " <> T.unpack (runIdent name)) $ return $ M.singleton name (ss, val)
 inferBinder' val (A.ConstructorBinder ss ctor binders) = wrapTrace ("inferBinder' CTOR: " <> show ctor) $ do
-  traceM $ "InferBinder VAL:\n" <> ppType 100 val
   env <- getEnv
   let cArgs = ctorArgs val
-  traceM $ "InferBinder CTOR ARGS:\n" <> concatMap (\x -> ppType 100 x <> "\n") cArgs
   case M.lookup ctor (dataConstructors env) of
     Just (_, _, _ty, _) -> do
       let ty = instantiate _ty cArgs
-      traceM $ "InferBinder CTOR TY:\n" <> ppType 100 ty
       let (args, _) = peelArgs ty
-      traceM $ "InferBinder ARGS:\n" <> concatMap (\x -> ppType 100 x <> "\n") args
       M.unions <$> zipWithM inferBinder' (reverse args) binders
     _ -> throwError . errorMessage' ss . UnknownName . fmap DctorName $ ctor
   where
@@ -717,7 +685,6 @@ inferBinder' val (A.ConstructorBinder ss ctor binders) = wrapTrace ("inferBinder
         go args (TypeApp _ (TypeApp _ fn arg) ret) | eqType fn tyFunction = go (arg : args) ret
         go args ret = (args, ret)
 inferBinder' val (A.LiteralBinder _ (ObjectLiteral props)) = wrapTrace "inferBinder' OBJECTLIT" $ do
-  traceM $ ppType 100 val
   let props' = sortOn fst props
   case unwrapRecord val of
     Left notARecord ->

src/Language/PureScript/CoreFn/Desugar/Utils.hs

@@ -5,7 +5,7 @@
 
 module Language.PureScript.CoreFn.Desugar.Utils where
 
-import Protolude (MonadError (..), traverse_)
+import Protolude (MonadError (..))
 import Prelude
 
 import Data.Function (on)
@@ -20,7 +20,6 @@ import Data.Bifunctor (Bifunctor (..))
 import Data.List (foldl')
 import Data.List.NonEmpty qualified as NEL
 import Data.Text qualified as T
-import Debug.Trace (trace, traceM)
 import Language.PureScript.AST qualified as A
 import Language.PureScript.AST.Declarations (declSourceSpan)
 import Language.PureScript.AST.Literals (Literal (..))
@@ -61,7 +60,6 @@ import Language.PureScript.Sugar (desugarGuardedExprs)
 import Language.PureScript.TypeChecker.Monad (
   CheckState (checkCurrentModule, checkEnv),
   bindLocalVariables,
-  debugNames,
   getEnv,
   withScopedTypeVars,
  )
@@ -271,9 +269,7 @@ unwrapRecord = \case
     go RowListItem {..} = (runLabel rowListLabel, rowListType)
 
 traceNameTypes :: (M m) => m ()
-traceNameTypes = do
-  nametypes <- getEnv >>= pure . debugNames
-  traverse_ traceM nametypes
+traceNameTypes = pure ()
 
 desugarCasesEverywhere :: (M m) => A.Declaration -> m A.Declaration
 desugarCasesEverywhere d = traverseDeclBodies (transformM $ desugarGuardedExprs (declSourceSpan d)) d
@@ -402,21 +398,12 @@ desugarConstraintsInDecl = \case
   other -> other
 
 -- TODO: Remove this 
-pTrace :: (Monad m, Show a) => a -> m ()
-pTrace = traceM . show
+pTrace :: (Monad m) => a -> m ()
+pTrace _ = pure ()
 
 -- | Given a string and a monadic action, produce a trace with the given message before & after the action (with pretty lines to make it more readable)
-wrapTrace :: (Monad m) => String -> m a -> m a
-wrapTrace msg act = do
-  traceM startMsg
-  res <- act
-  traceM endMsg
-  pure res
-  where
-    padding = replicate 10 '='
-    pad str = padding <> str <> padding
-    startMsg = pad $ "BEGIN " <> msg
-    endMsg = pad $ "END " <> msg
+wrapTrace :: String -> m a -> m a
+wrapTrace _ act = act
 
 {-
   This is used to solve a problem that arises with re-exported instances.
@@ -639,9 +626,8 @@ binderToCoreFn dict env mn _ss (A.LiteralBinder ss lit) =
    in LiteralBinder (ss, [], Nothing) lit'
 binderToCoreFn _ _ _ ss A.NullBinder =
   NullBinder (ss, [], Nothing)
-binderToCoreFn dict _ _ _ss vb@(A.VarBinder ss name) =
-  trace ("binderToCoreFn: " <> show vb) $
-    VarBinder (ss, [], Nothing) name (dict M.! name)
+binderToCoreFn dict _ _ _ss (A.VarBinder ss name) =
+  VarBinder (ss, [], Nothing) name (dict M.! name)
 binderToCoreFn dict env mn _ss (A.ConstructorBinder ss dctor@(Qualified mn' _) bs) =
   let (_, tctor, _, _) = lookupConstructor env dctor
       args = binderToCoreFn dict env mn _ss <$> bs

src/Language/PureScript/CoreFn/TypeLike.hs

@@ -12,10 +12,8 @@ import Control.Applicative
 import Control.Lens.Operators ((<&>))
 import Data.Kind qualified as GHC
 import Data.Maybe (catMaybes)
-import Debug.Trace (trace)
 import Language.PureScript.AST.SourcePos (pattern NullSourceAnn)
 import Language.PureScript.Environment (pattern RecordT, pattern (:->))
-import Language.Purus.Debug (doTrace)
 import Language.Purus.Pretty.Common
 import Prettyprinter (Pretty)
 
@@ -98,17 +96,8 @@ getInstantiations mono poly = catMaybes mInstantiations
     mInstantiations = freeInPoly <&> \nm -> (nm,) <$> instantiates nm mono poly
 
 instantiateWithArgs :: forall t. (TypeLike t, Pretty t) => t -> [t] -> t
-instantiateWithArgs f args = doTrace "instantiateWithArgs" msg result
+instantiateWithArgs f args = result 
   where
-    msg =
-      "instantiateWithArgs:\n  fun: "
-        <> prettyStr f
-        <> "\n  args: "
-        <> prettyStr args
-        <> "\n  instantiations: "
-        <> prettyStr instantiations
-        <> "\n  result: "
-        <> prettyStr result
     result = quantify $ replaceAllTypeVars instantiations (unQuantify f)
     instantiations = getAllInstantiations f args
 
@@ -118,7 +107,7 @@ getAllInstantiations ::
   t ->
   [t] ->
   [(Text, t)]
-getAllInstantiations fun args@(_ : _) = doTrace "getAllInstantiations" (prettyStr result) result
+getAllInstantiations fun args@(_ : _) = result
   where
     result = catMaybes $ zipWith go funArgs args
 

src/Language/PureScript/Make.hs

@@ -55,7 +55,6 @@ import System.Directory (doesFileExist)
 import System.FilePath (replaceExtension)
 
 -- Temporary
-import Debug.Trace (traceM)
 import Language.Purus.Pretty (ppType)
 
 initEnvironmentPurus :: Environment
@@ -129,11 +128,9 @@ rebuildModuleWithIndex MakeActions {..} exEnv externs m@(Module _ _ moduleName _
   regrouped <- createBindingGroups moduleName . collapseBindingGroups $ deguarded
 
   let mod' = Module ss coms moduleName regrouped exps
-  traceM $ "PURUS START HERE: " <> T.unpack (runModuleName moduleName)
   -- pTrace regrouped
   -- pTrace exps
   ((coreFn, chkSt'), nextVar'') <- runSupplyT nextVar' $ runStateT (CFT.moduleToCoreFn mod') chkSt -- (emptyCheckState env')
-  traceM . T.unpack $ CFT.prettyModuleTxt coreFn
   let corefn = coreFn
       (optimized, nextVar''') = runSupply nextVar'' $ CF.optimizeCoreFn corefn
       (renamedIdents, renamed) = renameInModule optimized

src/Language/PureScript/Sugar/CaseDeclarations.hs

@@ -26,7 +26,6 @@ import Language.PureScript.Errors (ErrorMessage (..), MultipleErrors (..), Simpl
 import Language.PureScript.Names (Ident (..), Qualified (..), freshIdent', pattern ByNullSourcePos)
 import Language.PureScript.TypeChecker.Monad (guardWith)
 
-import Debug.Trace
 import Language.PureScript.Types (SourceType, Type (TypeVar), quantify)
 
 {- |