unisonweb/unison
1
0
Fork 0
mirror of https://github.com/unisonweb/unison.git synced 2024-10-04 21:57:25 +03:00
Code Issues Projects Releases Wiki Activity

get rid of redundant fields of PrettyPrintEnv

Browse Source
This commit is contained in:
Paul Chiusano 2018-11-11 15:08:08 -05:00
parent 61505a266a
commit a58032976a
3 changed files with 17 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
parser-typechecker/src/Unison/Codebase.hs
View File

@ -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'

4
parser-typechecker/src/Unison/Codebase/Branch.hs
View File

@ -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 ]

31
parser-typechecker/src/Unison/PrettyPrintEnv.hs
View File

@ -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)