From a58032976aed5218eaf58ef11d779020f46ebc34 Mon Sep 17 00:00:00 2001 From: Paul Chiusano Date: Sun, 11 Nov 2018 15:08:08 -0500 Subject: [PATCH] get rid of redundant fields of PrettyPrintEnv --- parser-typechecker/src/Unison/Codebase.hs | 13 +++++--- .../src/Unison/Codebase/Branch.hs | 4 +-- .../src/Unison/PrettyPrintEnv.hs | 31 +++++-------------- 3 files changed, 17 insertions(+), 31 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase.hs b/parser-typechecker/src/Unison/Codebase.hs index 99851a467..a99f6c948 100644 --- a/parser-typechecker/src/Unison/Codebase.hs +++ b/parser-typechecker/src/Unison/Codebase.hs @@ -184,26 +184,29 @@ makeSelfContained :: (Monad m, Var v) => Codebase m v a -> Branch -> UF.UnisonFi makeSelfContained code b (UF.UnisonFile datas0 effects0 tm) = do deps <- foldM (transitiveDependencies code) Set.empty (Term.dependencies tm) let pp = Branch.prettyPrintEnv1 b + termName r = PPE.termName pp (Names.Ref r) + typeName r = PPE.typeName pp r decls <- fmap catMaybes . forM (toList deps) $ \case r@(Reference.DerivedId rid) -> fmap (r,) <$> getTypeDeclaration code rid _ -> pure Nothing termsByRef <- fmap catMaybes . forM (toList deps) $ \case - r@(Reference.DerivedId rid) -> fmap (r,Var.named (PPE.termName pp r),) <$> getTerm code rid + r@(Reference.DerivedId rid) -> fmap (r,Var.named (termName r),) <$> getTerm code rid _ -> pure Nothing let unref t = ABT.visitPure go t where go t@(Term.Ref' (r@(Reference.DerivedId _))) = - Just (Term.var (ABT.annotation t) (Var.named $ PPE.termName pp r)) + Just (Term.var (ABT.annotation t) (Var.named $ termName r)) go _ = Nothing datas = Map.fromList [ (v, (r, dd)) | (r, Right dd) <- decls, - v <- [Var.named (PPE.typeName pp r)]] + v <- [Var.named (typeName r)]] effects = Map.fromList [ (v, (r, ed)) | (r, Left ed) <- decls, - v <- [Var.named (PPE.typeName pp r)]] + v <- [Var.named (typeName r)]] bindings = [ ((ABT.annotation t, v), unref t) | (_, v, t) <- termsByRef ] + unrefBindings bs = [ (av, unref t) | (av, t) <- bs ] tm' = case tm of Term.LetRecNamedAnnotatedTop' top ann bs e -> - Term.letRec top ann (bindings ++ bs) (unref e) + Term.letRec top ann (bindings ++ unrefBindings bs) (unref e) tm -> Term.letRec True (ABT.annotation tm) bindings (unref tm) pure $ UF.UnisonFile (datas0 <> datas) (effects0 <> effects) tm' diff --git a/parser-typechecker/src/Unison/Codebase/Branch.hs b/parser-typechecker/src/Unison/Codebase/Branch.hs index e974f57f1..9bfe8d458 100644 --- a/parser-typechecker/src/Unison/Codebase/Branch.hs +++ b/parser-typechecker/src/Unison/Codebase/Branch.hs @@ -176,10 +176,8 @@ namesForPattern ref cid = R.lookupRan (ref, cid) . patternNamespace . Causal.head . unbranch prettyPrintEnv1 :: Branch -> PrettyPrintEnv -prettyPrintEnv1 b = PrettyPrintEnv terms ctors reqs patterns types where +prettyPrintEnv1 b = PrettyPrintEnv terms patterns types where terms r = multiset $ namesForTerm r b - ctors r cid = multiset $ namesForTerm (Names.Con r cid) b - reqs r cid = multiset $ namesForTerm (Names.Req r cid) b patterns r cid = multiset $ namesForPattern r cid b types r = multiset $ namesForType r b multiset ks = Map.fromList [ (k, 1) | k <- Set.toList ks ] diff --git a/parser-typechecker/src/Unison/PrettyPrintEnv.hs b/parser-typechecker/src/Unison/PrettyPrintEnv.hs index edd94a6ce..5e0b4d1a3 100644 --- a/parser-typechecker/src/Unison/PrettyPrintEnv.hs +++ b/parser-typechecker/src/Unison/PrettyPrintEnv.hs @@ -14,11 +14,8 @@ type Histogram = Map Name Word -- Maps terms, types, constructors and constructor patterns to a histogram of names. data PrettyPrintEnv = PrettyPrintEnv { - -- names for terms + -- names for terms, constructors, and requests terms :: Referent -> Histogram, - -- names for constructors that appear as terms - constructors :: Reference -> Int -> Histogram, - requests :: Reference -> Int -> Histogram, -- names for constructors that appear as patterns patterns :: Reference -> Int -> Histogram, -- names for types @@ -31,21 +28,11 @@ fromNames ns = [ (r, n) | (n, r) <- Map.toList (Names.termNames ns) ] patterns = Map.fromList [ ((r, i), n) | (n, (r, i)) <- Map.toList (Names.patternNames ns) ] - constructors = Map.fromList - [ ((r, i), n) - | (n, Names.Con r i) <- Map.toList (Names.termNames ns) - ] - requests = Map.fromList - [ ((r, i), n) - | (n, Names.Req r i) <- Map.toList (Names.termNames ns) - ] types = Map.fromList [ (r, n) | (n, r) <- Map.toList (Names.typeNames ns) ] hist :: Ord k => Map k Name -> k -> Histogram hist m k = maybe mempty (\n -> Map.fromList [(n, 1)]) $ Map.lookup k m in PrettyPrintEnv (hist terms) - (curry $ hist constructors) - (curry $ hist requests) (curry $ hist patterns) (hist types) @@ -54,20 +41,16 @@ fromNames ns = instance Semigroup PrettyPrintEnv where (<>) = mappend instance Monoid PrettyPrintEnv where - mempty = PrettyPrintEnv (const mempty) (\_ _ -> mempty) (\_ _ -> mempty) (\_ _ -> mempty) (const mempty) + mempty = PrettyPrintEnv (const mempty) (\_ _ -> mempty) (const mempty) mappend e1 e2 = PrettyPrintEnv (\r -> Map.unionWith (+) (terms e1 r) (terms e2 r)) - (\r i -> Map.unionWith (+) (constructors e1 r i) (constructors e2 r i)) - (\r i -> Map.unionWith (+) (requests e1 r i) (requests e2 r i)) (\r i -> Map.unionWith (+) (patterns e1 r i) (patterns e2 r i)) (\r -> Map.unionWith (+) (types e1 r) (types e2 r)) adjust :: (Word -> Word) -> PrettyPrintEnv -> PrettyPrintEnv adjust by e = PrettyPrintEnv (\r -> by <$> terms e r) - (\r i -> by <$> constructors e r i) - (\r i -> by <$> requests e r i) (\r i -> by <$> patterns e r i) (\r -> by <$> types e r) @@ -100,8 +83,10 @@ fromConstructorNames ctors reqs = let rs = Map.fromList reqs toH Nothing = mempty toH (Just t) = Map.fromList [(t, 1)] - in mempty { constructors = \r i -> toH $ Map.lookup (r,i) cs - , requests = \r i -> toH $ Map.lookup (r,i) rs + in mempty { terms = \r -> case r of + Names.Con r i -> toH $ Map.lookup (r,i) cs + Names.Req r i -> toH $ Map.lookup (r,i) rs + _ -> mempty , patterns = \r i -> toH $ Map.lookup (r,i) (cs `Map.union` rs) } -- These functions pick out the most common name and fall back @@ -114,10 +99,10 @@ typeName :: PrettyPrintEnv -> Reference -> Name typeName env r = pickName r (types env r) constructorName :: PrettyPrintEnv -> Reference -> Int -> Name -constructorName env r cid = pickNameCid r cid (constructors env r cid) +constructorName env r cid = pickNameCid r cid (terms env (Names.Con r cid)) requestName :: PrettyPrintEnv -> Reference -> Int -> Name -requestName env r cid = pickNameCid r cid (requests env r cid) +requestName env r cid = pickNameCid r cid (terms env (Names.Req r cid)) patternName :: PrettyPrintEnv -> Reference -> Int -> Name patternName env r cid = pickNameCid r cid (patterns env r cid)