diff --git a/src/Language/PureScript/CST/Convert.hs b/src/Language/PureScript/CST/Convert.hs index 9e686816..290b076a 100644 --- a/src/Language/PureScript/CST/Convert.hs +++ b/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 diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index 295050fe..ed97a1eb 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/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,9 +525,7 @@ 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' @@ -559,8 +533,6 @@ exprToCoreFn mn ss Nothing astCase@(A.Case vs alts@(alt : _)) = wrapTrace "exprT 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 -> diff --git a/src/Language/PureScript/CoreFn/Desugar/Utils.hs b/src/Language/PureScript/CoreFn/Desugar/Utils.hs index 3672c62a..93803b3e 100644 --- a/src/Language/PureScript/CoreFn/Desugar/Utils.hs +++ b/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 diff --git a/src/Language/PureScript/CoreFn/TypeLike.hs b/src/Language/PureScript/CoreFn/TypeLike.hs index 30c32c40..c1c6a1cb 100644 --- a/src/Language/PureScript/CoreFn/TypeLike.hs +++ b/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 diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index fc3b5ca0..d5179141 100644 --- a/src/Language/PureScript/Make.hs +++ b/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 diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs index e186f464..ec0f51b1 100644 --- a/src/Language/PureScript/Sugar/CaseDeclarations.hs +++ b/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) {- | diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index ce862790..0d14054d 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -34,7 +34,6 @@ import Control.Monad.Error.Class (MonadError (..)) import Control.Monad.State (MonadState, gets, modify) import Control.Monad.Supply.Class (MonadSupply (..)) -import Data.Bifunctor (first, second) import Data.Bitraversable (bitraverse) import Data.Foldable (for_, traverse_) import Data.Function (on) @@ -42,12 +41,11 @@ import Data.Functor (($>)) import Data.IntSet qualified as IS import Data.List (nubBy, sortOn, (\\)) import Data.Map qualified as M -import Data.Maybe (fromJust, fromMaybe) +import Data.Maybe (fromJust) import Data.Text (Text) import Data.Text qualified as T import Data.Traversable (for) -import Language.PureScript.CST.Types (Comment) import Language.PureScript.Crash (HasCallStack, internalError) import Language.PureScript.Environment qualified as E import Language.PureScript.Errors @@ -58,68 +56,18 @@ import Language.PureScript.TypeChecker.Skolems (newSkolemConstant, newSkolemScop import Language.PureScript.TypeChecker.Synonyms (replaceAllTypeSynonyms) import Language.PureScript.Types -import Data.Bifunctor (bimap) -import Debug.Trace -import Language.Purus.Pretty.Types (prettyTypeStr) - -moduleTraces :: Bool -moduleTraces = True - -goTrace :: forall x. String -> x -> x -goTrace str x - | moduleTraces = trace str x - | otherwise = x - -goTraceM :: forall f. (Applicative f) => String -> f () -goTraceM msg - | moduleTraces = traceM msg - | otherwise = pure () - -spacer = '\n' : replicate 20 '-' -prettySubstitution :: Substitution -> String -prettySubstitution Substitution {..} = - "SUBSTITUTION: " - <> "\n SUBST_TYPE: " - <> show (bimap show prettyTypeStr <$> M.toList substType) - <> "\n SUBST_UNSOLVED: " - <> show (bimap show (bimap show prettyTypeStr) <$> M.toList substUnsolved) - <> "\n SUBST_NAMES: " - <> show (M.toList substNames) +import Data.Bifunctor (first, second) -- TODO/REVIEW/HACK: ----------------------------------- -- NO CLUE IF THE CHANGES I MADE HERE ARE CORRECT generalizeUnknowns :: [(Unknown, SourceType)] -> SourceType -> SourceType generalizeUnknowns unks ty = - goTrace msg $ - generalizeUnknownsWithVars (unknownVarNames (fst <$> usedTypeVariables ty) unks) ty - where - result = generalizeUnknownsWithVars (unknownVarNames (fst <$> usedTypeVariables ty) unks) ty - msg = - "GENERALIZE UNKNOWNS:\nUNKNOWNS" - <> prettyUnknowns - <> "\n INPUT TYPE: " - <> prettyTypeStr ty - <> "\n OUTPUT TYPE: " - <> prettyTypeStr result - <> spacer - prettyUnknowns = concatMap (\x -> show (fst x) <> " :: " <> show (snd x) <> "\n") unks + generalizeUnknownsWithVars (unknownVarNames (fst <$> usedTypeVariables ty) unks) ty generalizeUnknownsWithVars :: [(Unknown, (Text, SourceType))] -> SourceType -> SourceType generalizeUnknownsWithVars binders ty = - goTrace msg $ - mkForAll ((getAnnForType ty,) . fmap (replaceUnknownsWithVars binders) . snd <$> binders) . replaceUnknownsWithVars binders $ + mkForAll ((getAnnForType ty,) . fmap (replaceUnknownsWithVars binders) . snd <$> binders) . replaceUnknownsWithVars binders $ ty - where - prettyBinders :: [(Unknown, (Text, SourceType))] -> String - prettyBinders xs = concatMap (\x -> show (fst x) <> ", " <> T.unpack (fst (snd x)) <> " := " <> prettyTypeStr (snd (snd x)) <> "\n") xs - - msg = - "GENERALIZE UNKNOWNS WITH VARS:" - <> "\n UNKNOWNS: " - <> prettyBinders binders - <> "\n TYPE: " - <> prettyTypeStr ty - <> spacer replaceUnknownsWithVars :: [(Unknown, (Text, SourceType))] -> SourceType -> SourceType replaceUnknownsWithVars binders ty @@ -144,13 +92,7 @@ unknownVarNames used unks = vars = fmap (("k" <>) . T.pack . show) ([1 ..] :: [Int]) apply :: (MonadState CheckState m) => SourceType -> m SourceType -apply ty = goTrace msg $ flip substituteType ty <$> gets checkSubstitution - where - msg = - "APPLY" - <> "\n TYPE: " - <> prettyTypeStr ty - <> spacer +apply ty = flip substituteType ty <$> gets checkSubstitution substituteType :: Substitution -> SourceType -> SourceType substituteType sub = everywhereOnTypes $ \case @@ -223,17 +165,7 @@ inferKind :: inferKind = \tyToInfer -> withErrorMessageHint (ErrorInferringKind tyToInfer) . rethrowWithPosition (fst $ getAnnForType tyToInfer) - $ do - result <- go tyToInfer - let msg = - "\nINFERKIND INPUT: " - <> prettyTypeStr tyToInfer - <> "\nINFERKIND RESULT: " - <> prettyTypeStr (snd result) - <> "\n" - <> replicate 20 '-' - goTraceM msg - pure result + $ go tyToInfer where go = \case ty@(TypeConstructor ann v) -> do @@ -260,12 +192,12 @@ inferKind = \tyToInfer -> pure (ty, E.kindSymbol $> ann) ty@(TypeLevelInt ann _) -> pure (ty, E.tyInt $> ann) - ty@(TypeVar ann v kx) -> do + ty@(TypeVar ann _ kx) -> do -- moduleName <- unsafeCheckCurrentModule -- kind <- apply =<< lookupTypeVariable moduleName (Qualified ByNullSourcePos $ ProperName v) pure (ty, kx $> ann) ty@(Skolem ann _ mbK _ _) -> do - kind <- apply $ mbK + kind <- apply mbK pure (ty, kind $> ann) ty@(TUnknown ann u) -> do kind <- apply . snd =<< lookupUnsolved u @@ -439,7 +371,7 @@ subsumesKind = go scope <- maybe newSkolemScope pure mbScope skolc <- newSkolemConstant go a $ skolemize ann var mbKind skolc scope b - (ForAll ann _ var (kind) a _, b) -> do + (ForAll ann _ var kind a _, b) -> do a' <- freshKindWithKind (fst ann) kind go (replaceTypeVars var a' a) b (TUnknown ann u, b@(TypeApp _ (TypeApp _ arr _) _)) @@ -495,7 +427,7 @@ unifyKindsWithFailure :: unifyKindsWithFailure onFailure = go where goWithLabel l t1 t2 = withErrorMessageHint (ErrorInRowLabel l) $ go t1 t2 - go tx1 tx2 = goTrace msg $ case (tx1, tx2) of + go tx1 tx2 = case (tx1, tx2) of (TypeApp _ p1 p2, TypeApp _ p3 p4) -> do go p1 p3 join $ go <$> apply p2 <*> apply p4 @@ -519,16 +451,7 @@ unifyKindsWithFailure onFailure = go solveUnknown a' p1 (w1, w2) -> onFailure w1 w2 - where - msg = - "UNIFY KINDS WITH FAILURE" - <> "\n Ty1: " - <> prettyTypeStr tx1 - <> "\n Ty2: " - <> prettyTypeStr tx2 - <> "\n" - <> replicate 20 '-' - + unifyRows r1 r2 = do let (matches, rest) = alignRowsWith goWithLabel r1 r2 sequence_ matches @@ -613,13 +536,13 @@ elaborateKind = \case throwError . errorMessage' (fst ann) . UnknownName . fmap TyName $ v Just (kind, _) -> ($> ann) <$> apply kind - TypeVar ann a kind -> do + TypeVar ann _ kind -> do -- moduleName <- unsafeCheckCurrentModule -- kind <- apply =<< lookupTypeVariable moduleName (Qualified ByNullSourcePos $ ProperName a) -- unifyKinds ki kind -- TODO/REVIEW/HACK: I DO NOT KNOW WHETHER THIS IS WHAT WE WANT pure (kind $> ann) (Skolem ann _ mbK _ _) -> do - kind <- apply $ mbK + kind <- apply mbK pure $ kind $> ann TUnknown ann a' -> do kind <- snd <$> lookupUnsolved a' @@ -729,7 +652,7 @@ inferDataDeclaration :: ModuleName -> DataDeclarationArgs -> m [(DataConstructorDeclaration, SourceType)] -inferDataDeclaration moduleName (ann, tyName, tyArgs, ctors) = do +inferDataDeclaration moduleName (_, tyName, tyArgs, ctors) = do tyKind <- apply =<< lookupTypeVariable moduleName (Qualified ByNullSourcePos tyName) let (sigBinders, tyKind') = fromJust . completeBinderList $ tyKind bindLocalTypeVariables moduleName (first ProperName . snd <$> sigBinders) $ do @@ -916,7 +839,7 @@ inferClassDeclaration :: ModuleName -> ClassDeclarationArgs -> m ([(Text, SourceType)], [SourceConstraint], [Declaration]) -inferClassDeclaration moduleName (ann, clsName, clsArgs, superClasses, decls) = do +inferClassDeclaration moduleName (_, clsName, clsArgs, superClasses, decls) = do clsKind <- apply =<< lookupTypeVariable moduleName (Qualified ByNullSourcePos $ coerceProperName clsName) let (sigBinders, clsKind') = fromJust . completeBinderList $ clsKind bindLocalTypeVariables moduleName (first ProperName . snd <$> sigBinders) $ do diff --git a/src/Language/PureScript/TypeChecker/Subsumption.hs b/src/Language/PureScript/TypeChecker/Subsumption.hs index 5187b5e8..f609c9c7 100644 --- a/src/Language/PureScript/TypeChecker/Subsumption.hs +++ b/src/Language/PureScript/TypeChecker/Subsumption.hs @@ -19,30 +19,14 @@ import Data.Ord (comparing) import Language.PureScript.AST (ErrorMessageHint (..), Expr (..), pattern NullSourceAnn) import Language.PureScript.Crash (internalError) import Language.PureScript.Environment (tyFunction, tyRecord) -import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage (..), errorMessage, internalCompilerError) +import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage (..), errorMessage) import Language.PureScript.TypeChecker.Monad (CheckState, getHints, getTypeClassDictionaries, withErrorMessageHint) import Language.PureScript.TypeChecker.Skolems (newSkolemConstant, skolemize) import Language.PureScript.TypeChecker.Unify (alignRowsWith, freshTypeWithKind, unifyTypes) import Language.PureScript.Types (RowListItem (..), SourceType, Type (..), eqType, isREmpty, replaceTypeVars, rowFromList) -import Debug.Trace (trace, traceM) import Language.Purus.Pretty.Types (prettyTypeStr) -moduleTraces :: Bool -moduleTraces = True - -goTrace :: forall x. String -> x -> x -goTrace str x - | moduleTraces = trace str x - | otherwise = x - -goTraceM :: forall f. (Applicative f) => String -> f () -goTraceM msg - | moduleTraces = traceM msg - | otherwise = pure () - -spacer = "\n" <> replicate 20 '-' - {- | Subsumption can operate in two modes: * Elaboration mode, in which we try to insert type class dictionaries @@ -84,16 +68,8 @@ subsumes :: SourceType -> m (Expr -> Expr) subsumes ty1 ty2 = - goTrace msg $ withErrorMessageHint (ErrorInSubsumption ty1 ty2) $ subsumes' SElaborate ty1 ty2 - where - msg = - "SUBSUMES" - <> "\n TYPE 1: " - <> prettyTypeStr ty1 - <> "\n TYPE 2: " - <> prettyTypeStr ty2 -- | Check that one type subsumes another subsumes' :: diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index 9846090f..bd7066a9 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -77,7 +77,6 @@ import Language.PureScript.TypeChecker.TypeSearch (typeSearch) import Language.PureScript.TypeChecker.Unify (freshTypeWithKind, replaceTypeWildcards, substituteType, unifyTypes, unknownsInType, varIfUnknown) import Language.PureScript.Types -import Debug.Trace import Language.PureScript.Pretty.Values (renderValue) import Language.Purus.Pretty.Types (prettyTypeStr) @@ -85,14 +84,10 @@ moduleTraces :: Bool moduleTraces = True goTrace :: forall x. String -> x -> x -goTrace str x - | moduleTraces = trace str x - | otherwise = x +goTrace _ x = x goTraceM :: forall f. (Applicative f) => String -> f () -goTraceM msg - | moduleTraces = traceM msg - | otherwise = pure () +goTraceM _ = pure () spacer = '\n' : replicate 20 '-' diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs index 02bee845..a7af45d6 100644 --- a/src/Language/PureScript/TypeChecker/Unify.hs +++ b/src/Language/PureScript/TypeChecker/Unify.hs @@ -35,21 +35,16 @@ import Language.PureScript.TypeChecker.Skolems (newSkolemConstant, skolemize) import Language.PureScript.Types (Constraint (..), RowListItem (..), SourceType, Type (..), WildcardData (..), alignRowsWith, everythingOnTypes, everywhereOnTypes, everywhereOnTypesM, getAnnForType, mkForAll, rowFromList, srcTUnknown, pattern REmptyKinded) import Data.Bifunctor (bimap) -import Debug.Trace import Language.Purus.Pretty.Types (prettyTypeStr) moduleTraces :: Bool moduleTraces = True goTrace :: forall x. String -> x -> x -goTrace str x - | moduleTraces = trace str x - | otherwise = x +goTrace _ x = x goTraceM :: forall f. (Applicative f) => String -> f () -goTraceM msg - | moduleTraces = traceM msg - | otherwise = pure () +goTraceM _ = pure () spacer = "\n" <> replicate 20 '-' diff --git a/src/Language/Purus/IR.hs b/src/Language/Purus/IR.hs index 739d7c7f..01a66a29 100644 --- a/src/Language/Purus/IR.hs +++ b/src/Language/Purus/IR.hs @@ -41,7 +41,6 @@ import Language.PureScript.Types ( genPureName, ) -import Language.Purus.Debug (doTrace) import Language.Purus.Pretty ((<::>)) import Language.Purus.Pretty.Common (prettyStr) @@ -805,30 +804,25 @@ expTy' f scoped = case instantiateEither (either (V . B) (V . F)) scoped of (Name might be a bit confusing, does not apply types) -} appType :: forall x t a. (TypeLike t, Pretty t) => (a -> Var (BVar t) (FVar t)) -> Exp x t a -> Exp x t a -> t -appType h fe ae = doTrace "appType" msg result +appType h fe ae = case unsafeAnalyzeApp (AppE fe ae) of + (fe', ae') -> + quantify + . foldr1Trace funTy + . drop (length ae') + . splitFunTyParts + . snd + . stripQuantifiers + $ instantiateWithArgs (expTy h fe') (expTy h <$> ae') where - errmsg = - ( "\nINPUT FUN:\n" - <> prettyStr (expTy h fe) - <> "\n\nINPUT ARGS:\n" - <> prettyStr (expTy h ae) - ) - - msg = errmsg <> "\n\nRESULT\n: " <> prettyStr result - - foldr1Trace f xs - | null xs = error $ "appType\n\n" <> errmsg - | otherwise = foldr1 f xs - - result = case unsafeAnalyzeApp (AppE fe ae) of - (fe', ae') -> - quantify - . foldr1Trace funTy - . drop (length ae') - . splitFunTyParts - . snd - . stripQuantifiers - $ instantiateWithArgs (expTy h fe') (expTy h <$> ae') + foldr1Trace :: forall b . (b -> b -> b) -> [b] -> b + foldr1Trace f = \case + [] -> error $ "appType\n\n" <> errmsg + xs -> foldr1 f xs + errmsg :: String + errmsg = "\nINPUTFun:\n" <> + prettyStr (expTy h fe) <> + "\n\nINPUT ARGS:\n" <> + prettyStr (expTy h ae) $(deriveShow1 ''BindE) diff --git a/src/Language/Purus/Make.hs b/src/Language/Purus/Make.hs index fb85b67f..3e1138ba 100644 --- a/src/Language/Purus/Make.hs +++ b/src/Language/Purus/Make.hs @@ -78,7 +78,6 @@ import System.FilePath.Glob qualified as Glob import PlutusCore.Evaluation.Result (EvaluationResult) --- import Debug.Trace (traceM) -- import PlutusIR.Core.Instance.Pretty.Readable (prettyPirReadable) {- Compiles a main function to PIR, given its module name, dependencies, and a @@ -113,7 +112,6 @@ compile primModule orderedModules mainModuleName mainFunctionName = go = do (summedModule, dsCxt) <- runDesugarCore $ desugarCoreModules primModule orderedModules let - -- traceBracket lbl msg = traceM ("\n" <> lbl <> "\n\n" <> msg <> "\n\n") decls = moduleDecls summedModule declIdentsSet = foldBinds (\acc nm _ -> S.insert nm acc) S.empty decls couldn'tFindMain n = @@ -126,26 +124,16 @@ compile primModule orderedModules mainModuleName mainFunctionName = <> "\nin declarations:\n" <> prettyStr (S.toList declIdentsSet) mainFunctionIx <- note (couldn'tFindMain 1) $ dsCxt ^? globalScope . at mainModuleName . folded . at mainFunctionName . folded - -- traceM $ "Found main function Index: " <> show mainFunctionIx mainFunctionBody <- note (couldn'tFindMain 2) $ findDeclBodyWithIndex mainFunctionName mainFunctionIx decls - -- traceM "Found main function body" inlined <- runInline summedModule $ lift (mainFunctionName, mainFunctionIx) mainFunctionBody >>= inline - -- traceBracket "Done inlining. Result:" $ prettyStr inlined let !instantiated = applyPolyRowArgs $ instantiateTypes inlined - -- traceBracket "Done instantiating types. Result:" $ prettyStr instantiated withoutObjects <- instantiateTypes <$> runCounter (desugarObjects instantiated) - -- traceBracket "Desugared objects. Result:\n" $ prettyStr withoutObjects datatypes <- runCounter $ desugarObjectsInDatatypes (moduleDataTypes summedModule) - -- traceM "Desugared datatypes" runPlutusContext initDatatypeDict $ do generateDatatypes datatypes - -- traceM "Generated PIR datatypes" withoutCases <- eliminateCases datatypes withoutObjects - -- traceM "Eliminated case expressions. Compiling to PIR..." compileToPIR datatypes withoutCases --- traceM . docString $ prettyPirReadable pirTerm - modulesInDependencyOrder :: [[FilePath]] -> IO [Module (Bind Ann) PurusType PurusType Ann] modulesInDependencyOrder (concat -> paths) = do modules <- traverse decodeModuleIO paths diff --git a/src/Language/Purus/Pipeline/CompileToPIR.hs b/src/Language/Purus/Pipeline/CompileToPIR.hs index 3e1518ff..446143bb 100644 --- a/src/Language/Purus/Pipeline/CompileToPIR.hs +++ b/src/Language/Purus/Pipeline/CompileToPIR.hs @@ -24,7 +24,6 @@ import Language.PureScript.CoreFn.FromJSON () import Language.PureScript.CoreFn.Module ( Datatypes, ) -import Language.PureScript.CoreFn.TypeLike (TypeLike (..)) import Language.PureScript.Names ( Ident (..), Qualified (..), @@ -33,7 +32,6 @@ import Language.PureScript.Names ( ) import Language.PureScript.PSString (prettyPrintString) -import Language.Purus.Debug (doTraceM, prettify) import Language.Purus.IR ( BVar (..), BindE (..), @@ -41,8 +39,7 @@ import Language.Purus.IR ( FVar (..), Lit (CharL, IntL, StringL), Ty, - expTy, - expTy', + expTy ) import Language.Purus.IR qualified as IR import Language.Purus.IR.Utils (Vars, WithoutObjects, toExp) @@ -85,12 +82,6 @@ compileToPIR _datatypes _exp = do resBody <- compileToPIR' _datatypes _exp datatypes <- view pirDatatypes let binds = NE.fromList $ map (PIR.DatatypeBind ()) . M.elems $ datatypes - msg = - prettify - [ "INPUT:\n" <> prettyStr _exp - , "OUTPUT (BODY):\n" <> prettyStr resBody - ] - doTraceM "compileToPIR" msg pure $ PIR.Let () PIR.Rec binds resBody compileToPIR' :: @@ -98,7 +89,7 @@ compileToPIR' :: Exp WithoutObjects Ty (Vars Ty) -> PlutusContext PIRTerm compileToPIR' datatypes _exp = - doTraceM "compileToPIR'" (prettyStr _exp) >> case _exp of + case _exp of V x -> case x of F Unit -> pure $ mkConstant () () F (FVar _ ident@(Qualified _ (runIdent -> nm))) -> @@ -117,24 +108,12 @@ compileToPIR' datatypes _exp = <> "report this bug to the Purus authors. " B (BVar bvix _ (runIdent -> nm)) -> pure $ PIR.Var () (Name nm $ Unique bvix) LitE _ lit -> compileToPIRLit lit - lam@(LamE (BVar bvIx bvT bvNm) body) -> do - let lty = funTy bvT (expTy' id body) + (LamE (BVar bvIx bvT bvNm) body) -> do ty' <- toPIRType bvT let nm = Name (runIdent bvNm) $ Unique bvIx body' = toExp body body'' <- compileToPIR' datatypes body' - let result = PIR.LamAbs () nm ty' body'' - msg = - "BVar:\n" - <> prettyStr bvNm - <> "\n\nInput Lam:\n" - <> prettyStr lam - <> "\n\nInferred Lam Ty:\n" - <> prettyStr lty - <> "\n\nRESULT: " - <> prettyStr result - doTraceM "compileToPIRLamTy" msg - pure result + pure $ PIR.LamAbs () nm ty' body'' AppE e1 e2 -> do e1' <- compileToPIR' datatypes e1 e2' <- compileToPIR' datatypes e2 diff --git a/src/Language/Purus/Pipeline/DesugarCore.hs b/src/Language/Purus/Pipeline/DesugarCore.hs index 651f68b9..f93684d6 100644 --- a/src/Language/Purus/Pipeline/DesugarCore.hs +++ b/src/Language/Purus/Pipeline/DesugarCore.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} @@ -12,7 +11,6 @@ import Data.Map qualified as M import Data.Text (Text) import Data.Text qualified as T -import Data.Char (isUpper) import Data.Foldable (Foldable (foldl'), foldrM, traverse_) import Data.List (sort, sortOn) import Data.Maybe (fromJust, isJust) @@ -35,7 +33,6 @@ import Language.PureScript.CoreFn.Expr ( ) import Language.PureScript.CoreFn.Module (Datatypes, Module (..)) import Language.PureScript.CoreFn.TypeLike (TypeLike (..)) -import Language.PureScript.CoreFn.Utils (exprType) import Language.PureScript.Environment (mkCtorTy, mkTupleTyName) import Language.PureScript.Names ( Ident (..), @@ -49,11 +46,6 @@ import Language.PureScript.Names ( ) import Language.PureScript.Types (Type (..)) -import Language.Purus.Debug ( - doTrace, - doTraceM, - prettify, - ) import Language.Purus.IR ( Alt (..), BVar (..), @@ -63,7 +55,6 @@ import Language.Purus.IR ( FuncType (..), Lit (CharL, IntL, ObjectL, StringL), Pat (..), - expTy, ) import Language.Purus.IR.Utils ( IR_Decl, @@ -80,7 +71,6 @@ import Language.Purus.Pipeline.Monad ( globalScope, localScope, ) -import Language.Purus.Pretty (prettyStr, prettyTypeStr, renderExprStr) import Language.Purus.Pretty.Common qualified as PC import Bound (Var (..), abstract) @@ -98,9 +88,6 @@ import Control.Lens ( (^?), ) -import Debug.Trace (traceM) -import Prettyprinter (Pretty (..)) - {- This runs the computation in an empty *local* context. The globals (i.e. top level declarations and imports are still in scope.) @@ -117,8 +104,6 @@ bindLocal :: Ident -> DesugarCore Int bindLocal ident = do i <- next modify $ over localScope (M.insert ident i) -- localScope . at ident .= i - s <- view localScope - doTraceM "bind" ("IDENT: " <> T.unpack (runIdent ident) <> "\n\nINDEX: " <> prettyStr i <> "\n\nSCOPE:\n" <> prettyStr (M.toList s)) pure i {- Binds a "global" variable to the specific index. @@ -135,13 +120,6 @@ forceBindGlobal mn i indx = do over globalScope (M.insert mn M.empty) modify $ over (globalScope . ix mn) (M.insert i indx) -{- -} -isCtorOrPrim :: Exp x t (Vars t) -> Bool -isCtorOrPrim = \case - V (F (FVar _ (Qualified (ByModuleName (ModuleName "Prim")) _))) -> True - V (F (FVar _ (Qualified _ (Ident i)))) -> isUpper (T.head i) - _ -> False - {- We don't bind anything b/c the type level isn't `Bound` -} tyAbs :: forall x t. Text -> KindOf t -> Exp x t (Vars t) -> DesugarCore (Exp x t (Vars t)) tyAbs nm k exp' = do @@ -186,10 +164,7 @@ desugarCoreModule inScope imports Module {..} = do decls' <- traverse (freshly . desugarCoreDecl . doEtaReduce) moduleDecls decls <- bindLocalTopLevelDeclarations decls' let allDatatypes = moduleDataTypes <> inScope - s <- get - traceM $ "DesugarContext for " <> prettyStr moduleName <> "\n" <> prettyStr s let result = Module {moduleDecls = decls <> imports, moduleDataTypes = allDatatypes, ..} - -- traceM $ "Desugar Coure output for " <> prettyStr moduleName <> "\n" <> docString (prettyModule result) pure result where doEtaReduce = \case @@ -203,13 +178,7 @@ desugarCoreModule inScope imports Module {..} = do let topLevelIdents = foldBinds (\acc nm _ -> nm : acc) [] ds traverse_ (uncurry (forceBindGlobal moduleName)) topLevelIdents s <- get - doTraceM "bindLocalTopLevelDeclarations" $ - prettify - [ -- "Input (Module Decls):\n" <> prettify (prettyStr <$> ds) - "Top level idents:\n" <> prettify (prettyStr <$> topLevelIdents) - , "State:\n" <> prettyStr s - ] - -- this is only safe because every locally-scoped (i.e. inside a decl) variable should be + -- this is only safe because every locally-scoped (i.e. inside a decl) variable should be -- bound by this point let upd = \case V (B bv) -> V $ B bv @@ -232,20 +201,6 @@ desugarCoreDecl = \case let scoped = abstr desugared pure $ NonRecursive ident bvix scoped Rec xs -> do - let inMsg = - concatMap - ( \((_, i), x) -> - prettyStr i - <> " :: " - <> prettyTypeStr (exprType x) - <> "\n" - <> prettyStr i - <> " = " - <> renderExprStr x - <> "\n\n" - ) - xs - doTraceM "desugarCoreDecl" inMsg first_pass <- traverse (\((_, ident), e) -> bindLocal ident >>= \u -> pure ((ident, u), e)) xs s <- view localScope let abstr = abstract (matchLet s) @@ -258,7 +213,6 @@ desugarCoreDecl = \case pure ((ident, bvix), scoped) ) first_pass - doTraceM "desugarCoreDecl" ("RESULT (RECURSIVE):\n" <> prettyStr (fmap fromScope <$> second_pass)) pure $ Recursive second_pass {- | Turns a list of expressions into an n-ary @@ -280,22 +234,11 @@ tuplify es = foldl' (App nullAnn) tupCtor es tupCtor = Var nullAnn tupCtorType (properToIdent <$> tupName) desugarCore :: Expr Ann -> DesugarCore (Exp WithObjects PurusType (Vars PurusType)) -desugarCore e = do - let ty = exprType e - result <- desugarCore' e - let msg = - prettify - [ "INPUT:\n" <> renderExprStr e - , "INPUT TY:\n" <> prettyTypeStr ty - , "OUTPUT:\n" <> prettyStr result - , "OUTPUT TY:\n" <> prettyStr (expTy id result) - ] - doTraceM "desugarCore" msg - pure result +desugarCore = desugarCore' desugarCore' :: Expr Ann -> DesugarCore (Exp WithObjects PurusType (Vars PurusType)) desugarCore' (Literal _ann ty lit) = LitE ty <$> desugarLit lit -desugarCore' lam@(Abs _ann ty ident expr) = do +desugarCore' (Abs _ann ty ident expr) = do bvIx <- bindLocal ident s <- view localScope expr' <- desugarCore' expr @@ -303,21 +246,7 @@ desugarCore' lam@(Abs _ann ty ident expr) = do (vars', _) = stripQuantifiers ty vars = (\(_, b, c) -> (b, c)) <$> vars' scopedExpr = abstract (matchLet s) expr' - result <- tyAbsMany vars $ LamE (BVar bvIx ty' ident) scopedExpr - let msg = - prettify - [ "ANNOTATED LAM TY:\n" <> prettyStr ty - , "BOUND VAR TY:\n" <> prettyStr ty' - , "BOUND VAR INDEX: " <> prettyStr bvIx - , "BOUND VAR IDENT: " <> prettyStr ident - , "BODY TY:\n" <> prettyStr (exprType expr) - , "INPUT EXPR:\n" <> renderExprStr lam - , "RESULT EXPR:\n" <> prettyStr result - , "RESULT EXPR TY:\n" <> prettyStr (expTy id result) - , "LOCAL SCOPE:\n" <> prettyStr (M.toList s) - ] - doTraceM "desugarCoreLam" msg - pure result + tyAbsMany vars $ LamE (BVar bvIx ty' ident) scopedExpr desugarCore' appE@(App {}) = case fromJust $ PC.analyzeApp appE of (f, args) -> do f' <- desugarCore f @@ -451,17 +380,12 @@ matchVarLamAbs nm bvix (FVar ty n') | nm == disqualify n' = Just (BVar bvix ty nm) | otherwise = Nothing -matchLet :: (Pretty ty) => M.Map Ident Int -> Vars ty -> Maybe (BVar ty) +matchLet :: M.Map Ident Int -> Vars ty -> Maybe (BVar ty) matchLet _ (B bv) = Just bv -matchLet binds fv@(F (FVar ty n')) = case result of +matchLet binds (F (FVar ty n')) = case result of Nothing -> Nothing - Just _ -> doTrace "matchLet" msg result + Just _ -> result where - msg = - "INPUT:\n" - <> prettyStr fv - <> "\n\nOUTPUT:\n" - <> prettyStr result result = do let nm = disqualify n' bvix <- M.lookup nm binds @@ -490,7 +414,7 @@ etaReduce input = case partitionLam input of let (bvars, inner) = stripLambdas e (f, args) <- analyzeAppCfn inner argBVars <- traverse argToBVar args - pure $ (bvars, f, argBVars) + pure (bvars, f, argBVars) argToBVar :: Expr ann -> Maybe Ident argToBVar = \case diff --git a/src/Language/Purus/Pipeline/DesugarObjects.hs b/src/Language/Purus/Pipeline/DesugarObjects.hs index 636c8e61..3229ddf1 100644 --- a/src/Language/Purus/Pipeline/DesugarObjects.hs +++ b/src/Language/Purus/Pipeline/DesugarObjects.hs @@ -37,7 +37,6 @@ import Language.PureScript.Types ( srcTypeApp, srcTypeConstructor, ) -import Language.Purus.Debug (doTraceM) import Language.Purus.IR ( Alt (..), BVar (..), @@ -49,7 +48,6 @@ import Language.Purus.IR ( Pat (..), Ty (..), expTy, - ppExp, pattern (:~>), ) import Language.Purus.IR.Utils ( @@ -139,19 +137,7 @@ rowLast t = case rowToList t of desugarObjects :: Exp WithObjects SourceType (Vars SourceType) -> Counter (Exp WithoutObjects Ty (Vars Ty)) -desugarObjects __expr = do - result <- go __expr - let msg = - "INPUT:\n" - <> ppExp __expr - <> "\n\nINPUT TY:\n" - <> prettyStr (expTy id __expr) - <> "\n\nRESULT:\n" - <> ppExp result - <> "\n\nRESULT TY:\n" - <> prettyStr (expTy id result) - doTraceM "desugarObjects" msg - pure result +desugarObjects __expr = go __expr where go :: Exp WithObjects SourceType (Vars SourceType) -> @@ -369,7 +355,7 @@ desugarObjects __expr = do PSString -> Exp WithObjects SourceType (Vars SourceType) -> Counter (Exp WithoutObjects Ty (Vars Ty)) - desugarObjectAccessor resTy lbl e = do + desugarObjectAccessor _ lbl e = do _fs <- case expTy id e of RecordT fs -> pure fs other -> @@ -394,21 +380,6 @@ desugarObjects __expr = do rhs = V . B $ BVar n fieldTy dummyNm altBranch = F <$> UnguardedAlt ctorBndr (toScope rhs) e' <- desugarObjects e - let result = CaseE fieldTy e' [altBranch] - msg = - "INPUT EXP:\n" - <> prettyStr e - <> "\n\nLABEL:\n" - <> prettyStr lbl - <> "\n\nSUPPLIED RESTYPE:\n" - <> prettyStr resTy - <> "\n\nFIELD TYPES:\n" - <> prettyStr types' - <> "\n\nRESULT RHS:\n" - <> prettyStr rhs - <> "\n\nOUTPUT RESULT:\n" - <> prettyStr result - doTraceM "desugarObjectAccessor" msg pure $ CaseE fieldTy e' [altBranch] assembleDesugaredObjectLit :: forall x a. Exp x Ty a -> Ty -> [Exp x Ty a] -> Counter (Exp x Ty a) @@ -418,7 +389,7 @@ assembleDesugaredObjectLit _ _ _ = error "something went wrong in assembleDesuga purusTypeToKind :: SourceType -> Either String Kind purusTypeToKind _t = - doTraceM "sourceTypeToKind" (prettyStr _t) >> case _t of + case _t of TypeConstructor _ C.Type -> pure KindType t1 :-> t2 -> do t1' <- purusTypeToKind t1 diff --git a/src/Language/Purus/Pipeline/EliminateCases.hs b/src/Language/Purus/Pipeline/EliminateCases.hs index ca29be87..914167db 100644 --- a/src/Language/Purus/Pipeline/EliminateCases.hs +++ b/src/Language/Purus/Pipeline/EliminateCases.hs @@ -31,10 +31,7 @@ import Language.PureScript.CoreFn.TypeLike ( TypeLike ( applyType, funTy, - instTy, - quantify, - replaceAllTypeVars, - splitFunTyParts + replaceAllTypeVars ), getAllInstantiations, getInstantiations, @@ -46,13 +43,11 @@ import Language.PureScript.Names ( ProperNameType (..), Qualified (..), runIdent, - showQualified, ) import Language.PureScript.Types ( TypeVarVisibility (TypeVarVisible), ) -import Language.Purus.Debug (doTrace, doTraceM, prettify) import Language.Purus.IR ( Alt (..), BVar (BVar), @@ -145,7 +140,6 @@ eliminateCases :: PlutusContext (Exp WithoutObjects Ty (Var (BVar Ty) (FVar Ty))) eliminateCases datatypes _exp = do res <- eliminateCaseExpressions datatypes . desugarIrrefutables . desugarLiteralPatterns $ _exp - doTraceM "eliminateCaseExpressions" ("INPUT:\n" <> prettyStr _exp <> "\n\nOUTPUT:\n" <> prettyStr res) pure . instantiateNullaryWithAnnotatedType datatypes . instantiateCtors datatypes @@ -181,13 +175,6 @@ eliminateCaseExpressions datatypes = \case case ezMonomorphize $ monomorphizePatterns datatypes ce of CaseE resTy _scrut _alts -> do let retTy = case head _alts of UnguardedAlt _ e -> expTy' id e - msg = - prettify - [ "ANN RES TY:\n " <> prettyStr resTy - , "SCRUTINEE:\n" <> prettyStr _scrut - , "ALTS:\n" <> prettyStr _alts - ] - doTraceM "eliminateCaseExpressions" msg scrut <- eliminateCaseExpressions datatypes _scrut alts <- traverse eliminateCasesInAlt _alts desugarConstructorPattern datatypes retTy (CaseE resTy scrut alts) @@ -240,14 +227,6 @@ mkDestructorFunTy datatypes tn = do ctorfs = map snd . view cdCtorFields <$> dDecl ^. dDataCtors let funTyRHS = tyAppliedToArgs :~> mkFunTyRHS outVar ctorfs -- foldr funTy outVar funTyCtorArgs let result = funTyLHS funTyRHS - doTraceM - "mkDestructorFunTy" - $ prettify - [ "TYPE NAME:\n" <> prettyStr tn - , "TY CTOR FIELDS:\n" <> prettyStr ctorfs - , "TY RHS:\n" <> prettyStr funTyRHS - , "RESULT:\n" <> prettyStr result - ] pure (null tyArgs, result) where mkFunTyRHS outVar [] = outVar @@ -269,10 +248,7 @@ desugarConstructorPattern datatypes altBodyTy _e = conPatAlts = takeWhile isConP alts scrutTy = expTy id scrut indexedBranches <- sortOn fst <$> traverse (mkIndexedBranch scrutTy) conPatAlts - let branchTy = expTy id . snd . head $ indexedBranches - branchSplit = splitFunTyParts branchTy - branchRetTy = last . splitFunTyParts $ branchTy - allCtors = zip [0 ..] $ getAllConstructorDecls tn datatypes + let allCtors = zip [0 ..] $ getAllConstructorDecls tn datatypes (Name dcTor (Unique dctorIx)) <- getDestructorTy tn (isNullaryTyCon, dctorTy) <- mkDestructorFunTy datatypes tn let destructorRaw = V . B $ BVar dctorIx dctorTy (Ident dcTor) @@ -281,30 +257,12 @@ desugarConstructorPattern datatypes altBodyTy _e = | isNullaryTyCon = id | otherwise = mkInstantiateTyCon (expTy id scrut) - retTy' = mkInstantiateResTy scrutTy altBodyTy -- NOTE: We'll need more sophisticated "pattern sorting" with as patterns case dropWhile isConP alts of [] -> do -- In this branch we know we have exhaustive constructor patterns in the alts let destructor = TyInstE altBodyTy (AppE (instantiateTyCon destructorRaw) scrut) - result = foldl' AppE destructor (snd <$> indexedBranches) - msg = - prettify - [ "INPUT TY:\n" <> prettyStr _eTy - , "RESULT TY:\n" <> prettyStr (expTy id result) - , "DESTRUCTOR TY:\n" <> prettyStr (expTy id destructor) - , "ORIGINAL CASE RES TY:\n" <> prettyStr _resTy - , "DEDUCED BRANCH RES TY:\n" <> prettyStr branchRetTy - , "SPLIT BRANCH TY:\n" <> prettyStr branchSplit - , "FULL BRANCH TY:\n" <> prettyStr branchTy - , "SCRUT TY:\n" <> prettyStr scrutTy - , "SCRUT EXPR:\n" <> prettyStr scrut - , "RESULT:\n" <> prettyStr result - , "ALT BODY TY:\n" <> prettyStr altBodyTy - , "INSTANTIATED ALT BODY TY:\n" <> prettyStr retTy' - ] - doTraceM "desugarConstructorPattern" msg - pure result + pure $ foldl' AppE destructor (snd <$> indexedBranches) irrefutables -> do let destructor = TyInstE altBodyTy (AppE (instantiateTyCon destructorRaw) scrut) {- This is confusing and I keep making mistakes, so what's going on with 'irrefutables' is: @@ -365,25 +323,7 @@ desugarConstructorPattern datatypes altBodyTy _e = then scrut else V . B $ bv other -> error $ "Expected an irrefutable alt but got: " <> prettyStr other - result <- assemblePartialCtorCase (CtorCase irrefutable (M.fromList indexedBranches) destructor scrutTy) allCtors - let msg = - prettify - [ "INPUT TY:\n" <> prettyStr _eTy - , "INPUT:\n" <> prettyStr _e - , "RESULT TY:\n" <> prettyStr (expTy id result) - , "DESTRUCTOR TY:\n" <> prettyStr (expTy id destructor) - , "ORIGINAL CASE RES TY:\n" <> prettyStr _resTy - , "DEDUCED BRANCH RES TY:\n" <> prettyStr branchRetTy - , "SPLIT BRANCH TY:\n" <> prettyStr branchSplit - , "FULL BRANCH TY:\n" <> prettyStr branchTy - , "SCRUT TY:\n" <> prettyStr scrutTy - , "SCRUT EXPR:\n" <> prettyStr scrut - , "RESULT:\n" <> prettyStr result - , "ALT BODY TY:\n" <> prettyStr altBodyTy - , "INSTANTIATED ALT BODY TY:\n" <> prettyStr retTy' - ] - doTraceM "desugarConstructorPattern" msg - pure result + assemblePartialCtorCase (CtorCase irrefutable (M.fromList indexedBranches) destructor scrutTy) allCtors other -> pure other where assemblePartialCtorCase :: CtorCase -> [(Int, CtorDecl Ty)] -> PlutusContext (Exp WithoutObjects Ty (Var (BVar Ty) (FVar Ty))) @@ -423,45 +363,17 @@ desugarConstructorPattern datatypes altBodyTy _e = Ty -> Exp WithoutObjects Ty (Var (BVar Ty) (FVar Ty)) -> Exp WithoutObjects Ty (Var (BVar Ty) (FVar Ty)) - mkInstantiateTyCon t e = doTrace "instantiateTyCon" msg result + mkInstantiateTyCon t e = result where result = case analyzeTyApp t of Just (_, tyArgs) -> foldr TyInstE e (reverse tyArgs) Nothing -> e - resTy = expTy id result - - msg = - prettify - [ "INPUT TY:\n" <> prettyStr t - , "INPUT EXPR:\n" <> prettyStr e - , "INPUT EXPR TY:\n" <> prettyStr (expTy id e) - , "OUTPUT TY:\n" <> prettyStr resTy - , "OUTPUT:\n" <> prettyStr result - ] - {- This is a bit weird. If the alt body type is already quantified then we don't want to - do any instantiations. TODO: Explain why (kind of complicated) - -} - mkInstantiateResTy :: Ty -> Ty -> Ty - mkInstantiateResTy _ altT@(Forall {}) = doTrace "instantiateResTy" ("UNCHANGED:\n" <> prettyStr altT) altT - mkInstantiateResTy scrutT altT = doTrace "instantiateResTy" msg result - where - result = case analyzeTyApp scrutT of - Just (_, tyArgs) -> foldr instTy (quantify altT) (reverse tyArgs) - Nothing -> altT - msg = - prettify - [ "INPUT SCRUT TY:\n" <> prettyStr scrutT - , "INPUT TARG TY:\n" <> prettyStr altT - , "OUTPUT TY:\n" <> prettyStr result - ] - mkIndexedBranch :: Ty -> Alt WithoutObjects Ty (Exp WithoutObjects Ty) (Var (BVar Ty) (FVar Ty)) -> PlutusContext (Int, Exp WithoutObjects Ty (Var (BVar Ty) (FVar Ty))) - mkIndexedBranch scrutTy alte@(UnguardedAlt (ConP tn cn binders) rhs) = do - doTraceM "mkIndexedBranch" ("INPUT:\n" <> prettyStr alte) + mkIndexedBranch scrutTy (UnguardedAlt (ConP tn cn binders) rhs) = do let go (x, t) acc = case x of VarP bvId bvIx bvTy' -> do let lamBV = BVar bvIx bvTy' bvId @@ -476,14 +388,12 @@ desugarConstructorPattern datatypes altBodyTy _e = pure $ LamE lamBv . toScope . fmap F . acc other -> error $ "Unexpected pattern in alternative: Expected a VarP but got " <> show other monoFields = snd $ monoCtorFields tn cn scrutTy datatypes - doTraceM "mkIndexedBranch" ("MONO FIELDS:\n" <> prettyStr monoFields) lambdaLHS <- foldrM go id (zip binders monoFields) let indx = case fst <$> getConstructorIndexAndDecl cn datatypes of Left _ -> error $ "No constructor data for ctor " <> show cn Right i -> i rhsUnscoped = toExp rhs result = lambdaLHS rhsUnscoped - doTraceM "mkIndexedBranch" ("RESULT:\n" <> prettyStr result) pure (indx, result) mkIndexedBranch _ (UnguardedAlt otherP _) = error $ "mkIndexedBranch: Expected constructor pattern but got " <> prettyStr otherP @@ -509,17 +419,7 @@ instantiateCtor datatypes expr = case expr of Just tn -> tn monoFields = monoCtorInst tyNm ctorNm (funResultTy t) datatypes fe' = foldr TyInstE fe monoFields - result = foldl' AppE fe' args - msg = - prettify - [ "NAME:" <> T.unpack (showQualified runIdent n) - , "MONO TYPE:\n" <> prettyStr t - , "INPUT:\n" <> prettyStr expr - , "RESULT:\n" <> prettyStr result - , "MONO FIELDS:\n" <> prettyStr monoFields - , "INSTANTIATED FUN:\n" <> prettyStr fe' - ] - in doTrace "instantiateCtor" msg result + in foldl' AppE fe' args _ -> expr _ -> expr @@ -528,13 +428,8 @@ instantiateNullaryWithAnnotatedType :: Datatypes IR.Kind Ty -> Exp x Ty (Vars Ty) -> Exp x Ty (Vars Ty) -instantiateNullaryWithAnnotatedType datatypes _e = doTrace "instantiateNullaryWithAnnotatedType" msg result +instantiateNullaryWithAnnotatedType datatypes _e = result where - msg = - prettify - [ "INPUT:\n" <> prettyStr _e - , "OUTPUT:\n" <> prettyStr result - ] result = transform go _e go :: Exp x Ty (Vars Ty) -> @@ -557,23 +452,8 @@ monoCtorInst :: Ty -> -- the type of the scrutinee Datatypes IR.Kind Ty -> [Ty] -- Constructor index & list of field types -monoCtorInst tn cn t datatypes = doTrace "monoCtorInst" msg $ snd <$> reverse instantiations +monoCtorInst tn _ t datatypes = snd <$> reverse instantiations where - msg = - "TYPE NAME:" - <> T.unpack (showQualified runProperName tn) - <> "CTOR NAME:\n" - <> T.unpack (showQualified runProperName cn) - <> "MONO IN TYPE:\n" - <> prettyStr t - <> "CTOR DECL ARGS:\n" - <> prettyStr ctorArgs - <> "POLY TY:\n" - <> prettyStr polyTy - <> "INSTANTIATIONS:\n" - <> prettyStr instantiations - (_, thisCtorDecl) = either error id $ getConstructorIndexAndDecl cn datatypes - ctorArgs = snd <$> thisCtorDecl ^. cdCtorFields thisDataDecl = fromJust $ lookupDataDecl tn datatypes declArgVars = uncurry IR.TyVar <$> thisDataDecl ^. dDataArgs dataTyCon = TyCon tn @@ -593,18 +473,8 @@ monoCtorFields :: Ty -> -- the type of the scrutinee Datatypes IR.Kind Ty -> (Int, [Ty]) -- Constructor index & list of field types -monoCtorFields tn cn t datatypes = doTrace "monoCtorFields" msg (thisCtorIx, monoCtorArgs) +monoCtorFields tn cn t datatypes = (thisCtorIx, monoCtorArgs) where - msg = - prettify - [ "TYPE NAME:" <> T.unpack (showQualified runProperName tn) - , "CTOR NAME:\n" <> T.unpack (showQualified runProperName cn) - , "MONO IN TYPE:\n" <> prettyStr t - , "CTOR DECL ARGS:\n" <> prettyStr ctorArgs - , "POLY TY:\n" <> prettyStr polyTy - , "RESULT TYS:\n" <> prettyStr monoCtorArgs - , "INSTANTIATIONS:\n" <> prettyStr instantiations - ] (thisCtorIx, thisCtorDecl) = either error id $ getConstructorIndexAndDecl cn datatypes ctorArgs = snd <$> thisCtorDecl ^. cdCtorFields thisDataDecl = fromJust $ lookupDataDecl tn datatypes @@ -646,8 +516,7 @@ monomorphizePatterns datatypes _e' = case _e' of CaseE resTy scrut alts -> let scrutTy = expTy id scrut alts' = goAlt scrutTy <$> alts -- REVIEW: Why do we do this twice? Was there a reason or is this just a mistake? - res = CaseE resTy scrut $ goAlt scrutTy <$> alts' - in doTrace "monomorphizePatterns" ("INPUT:\n" <> prettyStr _e' <> "RESULT:\n" <> prettyStr res) res + in CaseE resTy scrut $ goAlt scrutTy <$> alts' other -> other where monomorphPat :: @@ -779,21 +648,6 @@ ezMonomorphize = transform go instantiations' -> let instantiations = reverse (snd <$> instantiations') f' = foldr TyInstE f instantiations - result = foldl' AppE f' args - msg = - prettify - [ "INPUT:\n" <> prettyStr expr - , "OUTPUT:\n" - , prettyStr result - ] - in doTrace "ezMonomorphize" msg result - ft -> - let msg = - prettify - [ "NO CHANGE (NOT A FORALL):" - , "FUN TY:\n" <> prettyStr ft - , "ARG TYPES:\n" <> prettyStr (expTy id <$> args) - , "ORIGINAL EXPR:\n" <> prettyStr expr - ] - in doTrace "ezMonomorphize" msg expr - _ -> expr -- doTrace "ezMonomorphize" ("" <> prettyStr expr) expr + in foldl' AppE f' args + _ -> expr + _ -> expr diff --git a/src/Language/Purus/Pipeline/GenerateDatatypes.hs b/src/Language/Purus/Pipeline/GenerateDatatypes.hs index b10d2476..f8321018 100644 --- a/src/Language/Purus/Pipeline/GenerateDatatypes.hs +++ b/src/Language/Purus/Pipeline/GenerateDatatypes.hs @@ -37,7 +37,6 @@ import Language.PureScript.CoreFn.Module ( tyDict, ) import Language.PureScript.CoreFn.TypeLike -import Language.PureScript.Environment (pattern (:->)) import Language.PureScript.Names ( ProperName (..), ProperNameType (..), @@ -45,12 +44,7 @@ import Language.PureScript.Names ( showQualified, pattern ByThisModuleName, ) -import Language.PureScript.Types ( - SourceType, - Type (TypeConstructor), - ) -import Language.Purus.Debug (doTraceM) import Language.Purus.IR ( Ty (..), ppTy, @@ -63,14 +57,11 @@ import Language.Purus.Pipeline.GenerateDatatypes.Utils ( mkConstrName, mkNewTyVar, mkTyName, - prettyQPN, ) import Language.Purus.Pipeline.Monad ( MonadCounter (next), PlutusContext, ) -import Language.Purus.Pretty.Common (prettyStr) -import Language.Purus.Pretty.Types (prettyTypeStr) import Language.Purus.Types (PIRType, destructors, pirDatatypes) import PlutusCore qualified as PLC @@ -118,9 +109,7 @@ mkPIRDatatypes :: Datatypes IR.Kind Ty -> S.Set (Qualified (ProperName 'TypeName)) -> PlutusContext () -mkPIRDatatypes datatypes tyConsInExp = - doTraceM "mkPIRDatatypes" (show $ S.map prettyQPN tyConsInExp) - >> traverse_ go tyConsInExp +mkPIRDatatypes datatypes tyConsInExp = traverse_ go tyConsInExp where -- these things don't have datatype definitions anywhere truePrimitives = S.fromList [C.Function, C.Int, C.Char, C.String] @@ -130,7 +119,7 @@ mkPIRDatatypes datatypes tyConsInExp = PlutusContext () go qn | qn `S.member` truePrimitives = pure () go qn@(Qualified _ (ProperName tnm)) = - doTraceM "mkPIRDatatypes" ("go: " <> prettyQPN qn) >> case lookupDataDecl qn datatypes of + case lookupDataDecl qn datatypes of Nothing -> throwError $ "Error when translating data types to PIR: " @@ -138,10 +127,7 @@ mkPIRDatatypes datatypes tyConsInExp = <> T.unpack (showQualified runProperName qn) Just dDecl -> do -- TODO: newtypes should probably be newtype-ey - let declArgs = fst <$> dDecl ^. dDataArgs - declKind = mkDeclKind $ mkKind . snd <$> dDecl ^. dDataArgs - doTraceM "mkPIRDatatypes" $ "Decl " <> prettyStr dDecl - doTraceM "mkPIRDatatypes" $ "decl args: " <> show declArgs + let declKind = mkDeclKind $ mkKind . snd <$> dDecl ^. dDataArgs tyName <- mkTyName qn let typeNameDecl = TyVarDecl () tyName declKind dataArgs = dDecl ^. dDataArgs @@ -159,7 +145,7 @@ mkPIRDatatypes datatypes tyConsInExp = (Int, CtorDecl Ty) -> PlutusContext (PIR.VarDecl PIR.TyName PIR.Name PLC.DefaultUni ()) mkCtorDecl qTyName dataArgs (cix, ctorDecl) = - doTraceM "mkCtorDecl" (prettyQPN qTyName) >> do + do let ctorFields = snd <$> ctorDecl ^. cdCtorFields resultTy' = foldl' TyApp (TyCon qTyName) (uncurry TyVar <$> dataArgs) ctorFunTy :: Ty @@ -189,20 +175,13 @@ toPIRType _ty = case _ty of ByThisModuleName "Prim" | isJust (handlePrimTy qtn) -> pure . fromJust $ handlePrimTy qtn _ -> do tyName <- mkTyName qtn - let result = PIR.TyVar () tyName - doTraceM "toPIRType" ("\nINPUT:\n" <> prettyStr _ty <> "\n\nRESULT:\n" <> prettyStr result) - pure result - IR.TyApp t1 t2 -> do - result <- goTypeApp t1 t2 - doTraceM "toPIRType" ("\nINPUT:\n" <> prettyStr _ty <> "\n\nRESULT:\n" <> prettyStr result) - pure result + pure $ PIR.TyVar () tyName + IR.TyApp t1 t2 -> goTypeApp t1 t2 Forall _ v k ty _ -> do vTyName <- mkNewTyVar v bindTV v vTyName ty' <- toPIRType ty - let result = TyForall () vTyName (mkKind k) ty' - doTraceM "toPIRType" ("\nINPUT:\n" <> prettyStr _ty <> "\n\nRESULT:\n" <> prettyStr result) - pure result + pure $ TyForall () vTyName (mkKind k) ty' other -> error $ "Upon reflection, other types like " <> ppTy other <> " shouldn't be allowed in the Ty ast" where goTypeApp (IR.TyApp (TyCon C.Function) a) b = do diff --git a/src/Language/Purus/Pipeline/GenerateDatatypes/Utils.hs b/src/Language/Purus/Pipeline/GenerateDatatypes/Utils.hs index 49611b40..e352abc7 100644 --- a/src/Language/Purus/Pipeline/GenerateDatatypes/Utils.hs +++ b/src/Language/Purus/Pipeline/GenerateDatatypes/Utils.hs @@ -24,7 +24,6 @@ import Data.Text (Text) import Data.Text qualified as T import Control.Monad.State (gets, modify) -import Debug.Trace (traceM) import Language.PureScript.CoreFn.TypeLike import Language.PureScript.Names ( @@ -38,7 +37,6 @@ import Language.PureScript.Names ( showQualified, ) -import Language.Purus.Debug (doTraceM) import Language.Purus.IR ( Ty (..), ) @@ -86,7 +84,7 @@ pseudoRandomChar i = fst $ randomR ('a', 'z') (mkStdGen i) mkTyName :: Qualified (ProperName 'TypeName) -> PlutusContext PIR.TyName mkTyName qn = - doTraceM "mkTyName" (prettyQPN qn) >> gets (view tyNames) >>= \tnames -> case M.lookup qn tnames of + gets (view tyNames) >>= \tnames -> case M.lookup qn tnames of Just tyname -> pure tyname Nothing -> do uniq <- next @@ -96,7 +94,7 @@ mkTyName qn = mkConstrName :: Qualified Ident -> Int -> PlutusContext PIR.Name mkConstrName qi cix = - doTraceM "mkConstrName" (prettyQI qi) >> gets (view constrNames) >>= \cnames -> case M.lookup qi cnames of + gets (view constrNames) >>= \cnames -> case M.lookup qi cnames of Just cname -> pure $ fst cname Nothing -> do uniq <- next @@ -107,7 +105,7 @@ mkConstrName qi cix = -- | Only gives you a TyName, doesn't insert anything into the context mkNewTyVar :: Text -> PlutusContext TyName mkNewTyVar nm = - doTraceM "mkNewTyVar" (T.unpack nm) >> do + do uniq <- next pure . PIR.TyName $ PIR.Name nm $ PLC.Unique uniq @@ -120,7 +118,7 @@ freshName = do getBoundTyVarName :: Text -> PlutusContext PIR.TyName getBoundTyVarName nm = - doTraceM "mkBoundTyVarName" (T.unpack nm) >> do + do boundTyVars <- gets _tyVars case M.lookup nm boundTyVars of Just tyName -> pure tyName @@ -145,9 +143,8 @@ getDestructorTy qn = do getConstructorName :: Qualified Ident -> PlutusContext (Maybe PLC.Name) getConstructorName qi = - doTraceM "getConstructorName" (show qi) >> do + do ctors <- gets (view constrNames) - traceM $ show ctors pure $ ctors ^? at qi . folded . _1 prettyQPN :: Qualified (ProperName 'TypeName) -> String diff --git a/src/Language/Purus/Pipeline/Inline.hs b/src/Language/Purus/Pipeline/Inline.hs index 85c26e0d..fb58be20 100644 --- a/src/Language/Purus/Pipeline/Inline.hs +++ b/src/Language/Purus/Pipeline/Inline.hs @@ -18,7 +18,6 @@ import Control.Monad.State ( evalState, execState, unless, - void, when, ) @@ -32,7 +31,6 @@ import Language.PureScript.Environment (pattern RecordT) -- for the instance import Language.PureScript.Names ( Ident (GenIdent, Ident), - runIdent, ) import Language.PureScript.Types ( Type ( @@ -47,7 +45,6 @@ import Language.PureScript.Types ( isMonoType, ) -import Language.Purus.Debug (doTrace, doTraceM, prettify) import Language.Purus.IR ( BVar (..), BindE (..), @@ -94,7 +91,6 @@ import Language.Purus.Pipeline.Lift.Types ( pattern LiftedHole, ) import Language.Purus.Pipeline.Monad (Inline, MonadCounter (next)) -import Language.Purus.Pretty.Common (prettyStr) import Algebra.Graph.AdjacencyMap ( AdjacencyMap (..), @@ -114,14 +110,6 @@ import Control.Lens.Operators ((.=), (^..)) import Bound (Var (..)) import Bound.Scope (abstract) -import Prettyprinter ( - Pretty (pretty), - align, - hardline, - vcat, - (<+>), - ) - inline :: LiftResult -> Inline MonoExp inline (LiftResult decls bodyE) = do declsPrepared <- inlineInLifted decls @@ -192,17 +180,7 @@ inline (LiftResult decls bodyE) = do t = expTy id e' free = freeTypeVariables t bvars <- traverse (\(nm, ki) -> next >>= \u -> pure $ BVar u ki (Ident nm)) free - let result = foldr TyAbs e' bvars - msg = - prettify - [ "INPUT EXPR:\n" <> prettyStr e - , "INPUT EXPR TY:\n" <> prettyStr t <> "\n\n" <> show (void t) - , "FREE TY VARS IN INPUT:\n" <> prettyStr free - , "RESULT:\n" <> prettyStr result - , "RESULT TY:\n" <> prettyStr (expTy id result) - ] - doTraceM "addTypeAbstractions" msg - pure result + pure $ foldr TyAbs e' bvars -- sorry koz. in my heart i know you're right about type synonyms, but... type InlineState a = State (Map (Ident, Int) InlineBodyData) a @@ -234,26 +212,14 @@ handleSelfRecursive (nm, indx) body pure $ M.fromList [updatedOriginalDecl, newBreakerDecl] inlineWithData :: MonoExp -> InlineState MonoExp -inlineWithData = transformM go'' +inlineWithData = transformM go where - go'' ex = do - res <- go ex - let msg = prettify ["INPUT:\n" <> prettyStr ex, "RESULT:\n" <> prettyStr res] - doTraceM "inlineWithData" msg - pure res go :: MonoExp -> InlineState MonoExp go ex = get >>= \dict -> case ex of fv@(V (F {})) -> case toHole fv of Just (Hole hId hIx _) -> case M.lookup (hId, hIx) dict of - Just (NotALoopBreaker (toExp -> e)) -> do - let msg = - prettify - [ "INPUT:\n" <> prettyStr fv - , "RESULT:\n" <> prettyStr e - ] - doTraceM "inlineWithData" msg - pure e + Just (NotALoopBreaker (toExp -> e)) -> pure e _ -> pure fv _ -> pure fv V b@B {} -> pure $ V b @@ -280,26 +246,8 @@ doneInlining :: MonoExp -> InlineState Bool doneInlining me = do dct <- get let allInlineable = M.keysSet $ M.filter notALoopBreaker dct - allHoles = S.fromList $ mapMaybe (fmap unHole . toHole) (me ^.. cosmos) - result = S.null $ S.intersection allHoles allInlineable - msg = - prettify - [ "Input Expr:\n" <> prettyStr me - , "All Inlineable Vars:\n" <> prettyStr (S.toList allInlineable) - , "All Holes in expr:\n" <> prettyStr (S.toList allHoles) - , "Not yet inlined:\n" <> prettyStr (S.toList $ S.intersection allHoles allInlineable) - , "Are we done?: " <> show result - ] - doTraceM "doneInlining" msg - pure result - -prettyDict :: Map (Ident, Int) InlineBodyData -> String -prettyDict = - show - . align - . vcat - . map (\((i, n), b) -> pretty (runIdent i) <+> "#" <+> pretty n <+> "=" <+> pretty (toExp $ getInlineBody b) <+> hardline) - . M.toList + let allHoles = S.fromList $ mapMaybe (fmap unHole . toHole) (me ^.. cosmos) + pure . S.null $ S.intersection allHoles allInlineable inlineInLifted :: [MonoBind] -> Inline (Map (Ident, Int) InlineBodyData) inlineInLifted decls = do @@ -313,19 +261,12 @@ inlineInLifted decls = do ) M.empty decls - let res = flip execState dict $ update [] (M.keys dict) - msg = prettify ["Input:\n" <> prettyStr decls, "Result:\n" <> prettyDict res, "Breakers:\n" <> prettyStr (S.toList breakers)] - doTraceM "inlineLifted" msg - pure res + pure . flip execState dict $ update [] (M.keys dict) where update :: [(Ident, Int)] -> [(Ident, Int)] -> InlineState () update [] [] = pure () - update retry [] = do - let msg = "RETRY:\n" <> prettyStr retry - doTraceM "update" msg - update [] retry + update retry [] = update [] retry update retry (i : is) = do - doTraceM "update" (prettify ["GO", "RETRY STACK:\n" <> prettyStr retry, "ACTIVE STACK:\n" <> prettyStr (i : is)]) s <- get let e = s M.! i done1 <- doneInlining . toExp . getInlineBody $ e @@ -378,18 +319,14 @@ inlineInLifted decls = do breakLoops :: AdjacencyMap (Ident, Int) -> Set LoopBreaker - breakLoops adjMap = doTrace "breakLoops" msg result + breakLoops = evalState breakEm where - result = evalState breakEm adjMap - msg = "RESULT:\n" <> prettyStr (S.toList result) - breakEm :: State (AdjacencyMap (Ident, Int)) (Set LoopBreaker) breakEm = do adjaMap <- get let stronglyConnected = gmap fromNonEmpty $ scc adjaMap revTopoSorted :: [AdjacencyMap (Ident, Int)] revTopoSorted = reverse $ either cycleErr id $ topSort stronglyConnected - doTraceM "breakEm" ("RevTopoSorted:\n" <> prettyStr (vertexList <$> revTopoSorted)) case find nonTrivialGroup revTopoSorted of Nothing -> pure S.empty Just target -> do diff --git a/src/Language/Purus/Pipeline/Instantiate.hs b/src/Language/Purus/Pipeline/Instantiate.hs index c8e4c70a..947f2953 100644 --- a/src/Language/Purus/Pipeline/Instantiate.hs +++ b/src/Language/Purus/Pipeline/Instantiate.hs @@ -20,7 +20,6 @@ import Language.PureScript.CoreFn.TypeLike (TypeLike (..), instantiates) import Language.PureScript.Names (Ident (Ident)) import Language.PureScript.Types (Type (..)) -import Language.Purus.Debug (doTrace, prettify) import Language.Purus.IR (BVar (..), Exp (..), analyzeApp, expTy) import Language.Purus.IR.Utils ( Vars, @@ -30,7 +29,6 @@ import Language.Purus.IR.Utils ( transformTypesInExp, viaExp, ) -import Language.Purus.Pretty.Common (prettyStr) import Control.Lens (transform, view, _2) import Prettyprinter (Pretty) @@ -44,7 +42,7 @@ applyPolyRowArgs :: Exp WithObjects PurusType (Vars PurusType) -> Exp WithObjects PurusType (Vars PurusType) applyPolyRowArgs = transform $ \case - instE@(TyInstE t (TyAbs (BVar kvI kvTy (Ident kvNm)) innerE)) -> case kvTy of + instE@(TyInstE t (TyAbs (BVar _ kvTy (Ident kvNm)) innerE)) -> case kvTy of TypeApp _ (TypeConstructor _ C.Row) _ -> transformTypesInExp (replaceAllTypeVars [(kvNm, t)]) innerE _ -> instE other -> other @@ -67,7 +65,7 @@ instantiateTypes = \case TyAbs t inner -> TyAbs t (instantiateTypes inner) TyInstE t inner -> TyInstE t (instantiateTypes inner) -instantiateApp :: forall x (t :: *). (Pretty t, TypeLike t, Pretty (KindOf t)) => Exp x t (Vars t) -> Exp x t (Vars t) +instantiateApp :: forall x (t :: *). (Pretty t, TypeLike t) => Exp x t (Vars t) -> Exp x t (Vars t) instantiateApp e = case analyzeApp e of Nothing -> e Just (f, args) -> @@ -77,18 +75,7 @@ instantiateApp e = case analyzeApp e of quantifiedTyVars = view _2 <$> fTyVars instantiations = getInstantiations quantifiedTyVars fTypes argTypes f' = go instantiations quantifiedTyVars f - msg = - prettify - [ "Function:\n" <> prettyStr f - , "Arguments:\n" <> prettyStr args - , "Split Fun Types:\n" <> prettyStr fTypes - , "Split Arg Types:\n" <> prettyStr argTypes - , "Quantified TyVars:\n" <> prettyStr quantifiedTyVars - , "Instantiations:\n" <> prettyStr (M.toList instantiations) - , "New Function:\n" <> prettyStr f' - , "New Function Type:\n" <> prettyStr (expTy id f') - ] - in doTrace "instantiateTypes" msg $ foldl' AppE f' args + in foldl' AppE f' args where go :: Map Text t -> [Text] -> Exp x t (Vars t) -> Exp x t (Vars t) go _ [] ex = ex diff --git a/src/Language/Purus/Pipeline/Lift.hs b/src/Language/Purus/Pipeline/Lift.hs index 083d3c8b..1ac58dca 100644 --- a/src/Language/Purus/Pipeline/Lift.hs +++ b/src/Language/Purus/Pipeline/Lift.hs @@ -16,10 +16,6 @@ import Language.PureScript.CoreFn.TypeLike ( ) import Language.PureScript.Names (Ident (..), runIdent) import Language.PureScript.PSString (PSString) -import Language.Purus.Debug ( - doTraceM, - prettify, - ) import Language.Purus.IR ( Alt (..), BVar (..), @@ -60,7 +56,7 @@ import Language.Purus.Pipeline.Lift.Types ( pattern LiftedHoleTerm, ) import Language.Purus.Pipeline.Monad (Inline, MonadCounter (next)) -import Language.Purus.Pretty.Common (docString, prettyStr) +import Language.Purus.Pretty.Common (prettyStr) import Control.Applicative (Alternative ((<|>))) @@ -75,23 +71,13 @@ import Data.Set qualified as S import Control.Monad.Reader (asks, foldM) -import Debug.Trace (trace) - import Data.Text qualified as T -import Control.Lens (cosmos, over, toListOf, transform, (^..), _1) +import Control.Lens (cosmos, over, transform, (^..), _1) import Bound.Scope (abstract) import Bound.Var (Var (..)) -import Prettyprinter ( - Pretty (pretty), - align, - hardline, - indent, - vcat, - ) - {- Given a collection of declarations that will be lifted, determine for each declaration the "deep" (recursive) set of NEW variable dependencies which need to be added as additional arguments. @@ -225,15 +211,6 @@ updateAllBinds deepDict prunedBody _binds = do binds = mapBind go <$> _binds - msg = - prettify - [ "Pruned body:\n " <> prettyStr prunedBody - , "AllDeclIdents:\n " <> prettyStr allLiftedIdents - , "AdjustedBody:\n " <> prettyStr adjustedBody - , "Binds:\n" <> concatMap (\x -> prettyStr x <> "\n\n") binds - , "Deep Dict:\n" <> prettyStr (M.toList (S.toList <$> deepDict)) - ] - doTraceM "updateAllBinds" msg pure (binds, adjustedBody) where coerceOldToNew :: @@ -347,22 +324,11 @@ lift mainNm _e = do e <- handleSelfRecursiveMain modDict <- mkModDict let collectDict = mkDict S.empty modDict e - prettyCollectDict = docString . indent 2 . align . vcat $ map (\((nm, indx), b) -> pretty nm <> "#" <> pretty indx <> pretty (toExp b) <> hardline) (M.toList collectDict) (toLift, prunedExp, _) = collect S.empty collectDict S.empty S.empty e deepDict = deepAnalysis toLift liftThese = S.toList . S.unions $ declarations <$> S.toList toLift (binds, body) <- updateAllBinds deepDict prunedExp liftThese - result <- cleanupLiftedTypes $ LiftResult binds body - let msg = - prettify - [ "Input Expr:\n" <> prettyStr e - , "Pruned Expr:\n" <> prettyStr prunedExp - , "ToLifts:\n" <> prettyStr (S.toList toLift) - , "Collect Dict:\n" <> prettyCollectDict - , "Result\n" <> prettyStr result - ] - doTraceM "lift" msg - pure result + cleanupLiftedTypes $ LiftResult binds body where handleSelfRecursiveMain :: Inline MonoExp handleSelfRecursiveMain @@ -395,7 +361,7 @@ lift mainNm _e = do Map (Ident, Int) MonoScoped -> MonoExp -> Map (Ident, Int) MonoScoped - mkDict visited acc me = trace "mkDict" $ case me of + mkDict visited acc me = case me of V F {} -> acc (V (B (BVar bvIx _ bvId))) -> case S.member (bvId, bvIx) visited of True -> acc @@ -426,7 +392,7 @@ lift mainNm _e = do Set (BVar (KindOf PurusType)) -> MonoExp -> (Set ToLift, MonoExp, Set (Ident, Int)) - collect visited dict boundVars boundTyVars me = trace "collect" $ case me of + collect visited dict boundVars boundTyVars me = case me of -- we ignore free variables. For us, a free variable more or less represents "shouldn't/can't be inlined" V fv@F {} -> (S.empty, V fv, visited) V b@(B (BVar bvIx (stripSkolems -> bvTy) bvIdent)) -> case M.lookup (bvIdent, bvIx) dict of @@ -498,7 +464,7 @@ lift mainNm _e = do Set (BVar (KindOf PurusType)) -> [MonoBind] -> (Set ToLift, Set (Ident, Int)) - collectFromNestedDeclarations vis termBound typeBound liftThese = trace "collectFromNested" $ foldBinds go (S.empty, vis) liftThese + collectFromNestedDeclarations vis termBound typeBound liftThese = foldBinds go (S.empty, vis) liftThese where go :: (Set ToLift, Set (Ident, Int)) -> (Ident, Int) -> MonoScoped -> (Set ToLift, Set (Ident, Int)) go (liftAcc, visAcc) (nm, indx) scoped = diff --git a/src/Language/Purus/Utils.hs b/src/Language/Purus/Utils.hs index e8e6ed6d..949b4d63 100644 --- a/src/Language/Purus/Utils.hs +++ b/src/Language/Purus/Utils.hs @@ -17,7 +17,6 @@ import Language.PureScript.Names ( pattern ByNullSourcePos, ) -import Language.Purus.Debug (doTrace) import Language.Purus.IR (BVar, BindE (..), Exp) import Language.Purus.IR.Utils (IR_Decl, Vars, WithObjects, foldBinds, toExp) @@ -60,7 +59,7 @@ findMain :: Text -> Module IR_Decl k PurusType Ann -> Maybe ((Ident, Int), Scope (BVar PurusType) (Exp WithObjects PurusType) (Vars PurusType)) -findMain nm Module {..} = doTrace "findDeclBody" ("NAME: " <> T.unpack nm) $ findMain' (Ident nm) moduleDecls +findMain nm Module {..} = findMain' (Ident nm) moduleDecls findMain' :: forall x ty.