From 1a6b7cd3ffa25681ed0d3193e6ef065ec4c00a83 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Sat, 10 Nov 2018 17:49:05 -0500 Subject: [PATCH] Branch.termNamespace maps Name to Referent --- parser-typechecker/src/Unison/Codebase.hs | 21 +- .../src/Unison/Codebase/Branch.hs | 314 ++++++++---------- .../src/Unison/Codebase/Serialization/V0.hs | 12 +- .../src/Unison/Codebase/TermEdit.hs | 12 +- parser-typechecker/src/Unison/Names.hs | 29 +- .../src/Unison/PrettyPrintEnv.hs | 42 ++- parser-typechecker/src/Unison/PrintError.hs | 3 +- parser-typechecker/src/Unison/TermPrinter.hs | 10 +- parser-typechecker/src/Unison/UnisonFile.hs | 16 +- 9 files changed, 239 insertions(+), 220 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase.hs b/parser-typechecker/src/Unison/Codebase.hs index e503cf6e9..ee8f0a8f3 100644 --- a/parser-typechecker/src/Unison/Codebase.hs +++ b/parser-typechecker/src/Unison/Codebase.hs @@ -1,14 +1,14 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} -{-# LANGUAGE LambdaCase #-} module Unison.Codebase where -import Data.Char (toLower) -import Control.Monad (forM, foldM) +import Control.Monad (foldM, forM) +import Data.Char (toLower) import Data.Foldable (toList, traverse_) import Data.List import qualified Data.Map as Map @@ -23,7 +23,8 @@ import qualified Unison.Builtin as Builtin import Unison.Codebase.Branch (Branch) import qualified Unison.Codebase.Branch as Branch import qualified Unison.DataDeclaration as DD -import Unison.Names (Name) +import Unison.Names (Name, Referent) +import qualified Unison.Names as Names import Unison.Parser (Ann) import qualified Unison.PrettyPrintEnv as PPE import Unison.Reference (Reference) @@ -100,9 +101,9 @@ initialize c = do goData = go Right prettyBinding :: (Var.Var v, Monad m) - => Codebase m v a -> Name -> Reference -> Branch -> m (Maybe (PrettyPrint String)) -prettyBinding _ _ (Reference.Builtin _) _ = pure Nothing -prettyBinding cb name r0@(Reference.DerivedId r) b = go =<< getTerm cb r where + => Codebase m v a -> Name -> Referent -> Branch -> m (Maybe (PrettyPrint String)) +prettyBinding _ _ (Names.Ref (Reference.Builtin _)) _ = pure Nothing +prettyBinding cb name r0@(Names.Ref r1@(Reference.DerivedId r)) b = go =<< getTerm cb r where go Nothing = pure Nothing go (Just tm) = let -- We boost the `(r0,name)` association since if this is a recursive @@ -112,14 +113,14 @@ prettyBinding cb name r0@(Reference.DerivedId r) b = go =<< getTerm cb r where in case tm of Term.Ann' _ _ -> pure $ Just (TermPrinter.prettyBinding ppEnv (Var.named name) tm) _ -> do - Just typ <- getTypeOfTerm cb r0 + Just typ <- getTypeOfTerm cb r1 pure . Just $ TermPrinter.prettyBinding ppEnv (Var.named name) (Term.ann (ABT.annotation tm) tm typ) prettyBinding _ _ r _ = error $ "unpossible " ++ show r prettyBindings :: (Var.Var v, Monad m) - => Codebase m v a -> [(Name,Reference)] -> Branch -> m (PrettyPrint String) + => Codebase m v a -> [(Name,Referent)] -> Branch -> m (PrettyPrint String) prettyBindings cb tms b = do ds <- catMaybes <$> (forM tms $ \(name,r) -> prettyBinding cb name r b) pure $ PP.linesSpaced ds @@ -176,7 +177,7 @@ sortedApproximateMatches q possible = trim (sortOn fst matches) where editDistance q s = levenshteinDistance defaultEditCosts q s matches = map (\s -> (score s, s)) possible trim ((_,h):_) | h == q = [h] - trim ms = map snd $ takeWhile (\(n,_) -> n - 7 < nq `div` 4) ms + trim ms = map snd $ takeWhile (\(n,_) -> n - 7 < nq `div` 4) ms branchExists :: Functor m => Codebase m v a -> Name -> m Bool branchExists codebase name = elem name <$> branches codebase diff --git a/parser-typechecker/src/Unison/Codebase/Branch.hs b/parser-typechecker/src/Unison/Codebase/Branch.hs index 241870d1c..e974f57f1 100644 --- a/parser-typechecker/src/Unison/Codebase/Branch.hs +++ b/parser-typechecker/src/Unison/Codebase/Branch.hs @@ -1,44 +1,44 @@ -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ViewPatterns #-} + {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Unison.Codebase.Branch where -- import Unison.Codebase.NameEdit (NameEdit) -import Prelude hiding (head) -import Control.Monad (foldM, join) -import Data.Bifunctor (bimap) +import Control.Monad (join) +import Data.Bifunctor (bimap) import Data.Foldable -import Data.Functor.Identity (runIdentity) -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Set (Set) -import qualified Data.Set as Set ---import Control.Monad (join) -import Unison.Codebase.Causal (Causal) -import qualified Unison.Codebase.Causal as Causal -import Unison.Names (Name, Names (..)) -import qualified Unison.Names as Names -import Unison.Codebase.TermEdit (TermEdit, Typing) -import qualified Unison.Codebase.TermEdit as TermEdit -import Unison.Codebase.TypeEdit (TypeEdit) -import qualified Unison.Codebase.TypeEdit as TypeEdit -import Unison.Hash (Hash) -import Unison.Hashable (Hashable) -import qualified Unison.Hashable as H -import Unison.Reference (Reference) -import qualified Unison.UnisonFile as UF -import Unison.Util.Relation (Relation) -import qualified Unison.Util.Relation as R -import qualified Unison.Term as Term -import qualified Unison.Var as Var -import Unison.Var (Var) -import Unison.PrettyPrintEnv (PrettyPrintEnv(..)) +import Data.Functor.Identity (runIdentity) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set +import Prelude hiding (head) +import Unison.Codebase.Causal (Causal) +import qualified Unison.Codebase.Causal as Causal +import Unison.Codebase.TermEdit (TermEdit, Typing) +import qualified Unison.Codebase.TermEdit as TermEdit +import Unison.Codebase.TypeEdit (TypeEdit) +import qualified Unison.Codebase.TypeEdit as TypeEdit +import Unison.Hash (Hash) +import Unison.Hashable (Hashable) +import qualified Unison.Hashable as H +import Unison.Names (Name, Names (..), Referent) +import qualified Unison.Names as Names +import Unison.Reference (Reference) +import qualified Unison.UnisonFile as UF +import Unison.Util.Relation (Relation) +import qualified Unison.Util.Relation as R +-- import qualified Unison.Term as Term +import Unison.PrettyPrintEnv (PrettyPrintEnv (..)) +import Unison.Var (Var) +import qualified Unison.Var as Var --import Data.Semigroup (sconcat) --import Data.List.NonEmpty (nonEmpty) @@ -76,11 +76,11 @@ import Unison.PrettyPrintEnv (PrettyPrintEnv(..)) newtype Branch = Branch { unbranch :: Causal Branch0 } deriving Eq data Branch0 = - Branch0 { termNamespace :: Relation Name Reference + Branch0 { termNamespace :: Relation Name Referent , patternNamespace :: Relation Name (Reference,Int) - , typeNamespace :: Relation Name Reference - , editedTerms :: Relation Reference TermEdit - , editedTypes :: Relation Reference TypeEdit + , typeNamespace :: Relation Name Reference + , editedTerms :: Relation Referent TermEdit + , editedTypes :: Relation Reference TypeEdit } deriving (Eq) data Diff = Diff { ours :: Branch0, theirs :: Branch0 } @@ -88,16 +88,9 @@ data Diff = Diff { ours :: Branch0, theirs :: Branch0 } fromNames :: Names -> Branch0 fromNames names = Branch0 terms pats types R.empty R.empty where - terms = R.fromList - [ (name, referentToRef t) - | (name, t) <- Map.toList $ Names.termNames names - ] + terms = R.fromList . Map.toList $ Names.termNames names pats = R.fromList . Map.toList $ Names.patternNames names types = R.fromList . Map.toList $ Names.typeNames names - referentToRef r = case r of - Names.Ref r -> r - Names.Req r id -> Term.hashRequest r id - Names.Con r id -> Term.hashConstructor r id diff :: Branch -> Branch -> Diff diff ours theirs = @@ -162,7 +155,7 @@ hasTypeNamed n b = not . null $ typesNamed n b hasPatternNamed :: Name -> Branch -> Bool hasPatternNamed n b = not . null $ patternsNamed n b -termsNamed :: Name -> Branch -> Set Reference +termsNamed :: Name -> Branch -> Set Referent termsNamed name = R.lookupDom name . termNamespace . Causal.head . unbranch typesNamed :: Name -> Branch -> Set Reference @@ -172,7 +165,7 @@ patternsNamed :: Name -> Branch -> Set (Reference, Int) patternsNamed name = R.lookupDom name . patternNamespace . Causal.head . unbranch -namesForTerm :: Reference -> Branch -> Set Name +namesForTerm :: Referent -> Branch -> Set Name namesForTerm ref = R.lookupRan ref . termNamespace . Causal.head . unbranch namesForType :: Reference -> Branch -> Set Name @@ -183,9 +176,10 @@ namesForPattern ref cid = R.lookupRan (ref, cid) . patternNamespace . Causal.head . unbranch prettyPrintEnv1 :: Branch -> PrettyPrintEnv -prettyPrintEnv1 b = PrettyPrintEnv terms ctors patterns types where +prettyPrintEnv1 b = PrettyPrintEnv terms ctors reqs patterns types where terms r = multiset $ namesForTerm r b - ctors r cid = multiset $ namesForTerm (Term.hashConstructor r cid) 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 ] @@ -225,7 +219,7 @@ resolved f = resolved' . f . Causal.head . unbranch where -- * terms and types depending on updated types -- * terms depending on updated terms data RemainingWork - = TermNameConflict Name (Set Reference) + = TermNameConflict Name (Set Referent) | TypeNameConflict Name (Set Reference) | TermEditConflict Reference (Set TermEdit) | TypeEditConflict Reference (Set TypeEdit) @@ -234,89 +228,90 @@ data RemainingWork | ObsoleteType Reference (Set (Reference, TypeEdit)) deriving (Eq, Ord, Show) -remaining :: forall m. Monad m => ReferenceOps m -> Branch -> m (Set RemainingWork) -remaining ops b@(Branch (Causal.head -> b0)) = do --- If any of r's dependencies have been updated, r should be updated. --- Alternatively: If `a` has been edited, then all of a's dependents --- should be edited. (Maybe a warning if they are updated to something --- that still uses `a`.) - -- map from updated term to dependent + termedit - (obsoleteTerms, obsoleteTypes) <- wrangleUpdatedTypes ops =<< wrangleUpdatedTerms - pure . Set.fromList $ - (uncurry TermNameConflict <$> Map.toList (conflicts termNamespace b)) ++ - (uncurry TypeNameConflict <$> Map.toList (conflicts typeNamespace b)) ++ - (uncurry TermEditConflict <$> Map.toList (conflicts editedTerms b)) ++ - (uncurry TypeEditConflict <$> Map.toList (conflicts editedTypes b)) ++ - (uncurry ObsoleteTerm <$> Map.toList obsoleteTerms) ++ - (uncurry ObsoleteType <$> Map.toList obsoleteTypes) - where -- referent -> (oldreference, edit) - wrangleUpdatedTerms :: m (Map Reference (Set (Reference, Either TermEdit TypeEdit))) - wrangleUpdatedTerms = - -- 1. filter the edits to find the ones that are resolved (not conflicted) - -- 2. for each resolved (oldref,edit) pair, - -- 2b. look up the referents of that oldref. - -- 2c. if the referent is unedited, add it to the work: - -- 2c(i). add it to the term work list if it's a term ref, - -- 2c(ii). only terms can depend on terms, so it's a term ref. - let termEdits :: Map Reference TermEdit -- oldreference, edit - termEdits = resolved editedTerms b - transitiveDependents :: Reference -> m (Set Reference) - transitiveDependents r = transitiveClosure1 (dependents ops) r - isEdited r = R.memberDom r (editedTerms b0) - uneditedTransitiveDependents :: Reference -> m [Reference] - uneditedTransitiveDependents r = - filter (not . isEdited) . toList <$> transitiveDependents r - asSingleton :: Reference -> TermEdit -> Reference -> Map Reference (Set (Reference, Either TermEdit TypeEdit)) - asSingleton oldRef edit referent = Map.singleton referent (Set.singleton (oldRef, Left edit)) - workFromEdit :: (Reference, TermEdit) -> m (Map Reference (Set (Reference, Either TermEdit TypeEdit))) - workFromEdit (oldRef, edit) = - mconcat . fmap (asSingleton oldRef edit) <$> uneditedTransitiveDependents oldRef - in fmap mconcat (traverse workFromEdit $ Map.toList termEdits) - - wrangleUpdatedTypes :: - Monad m => ReferenceOps m - -> Map Reference (Set (Reference, Either TermEdit TypeEdit)) - -> m (Map Reference (Set (Reference, Either TermEdit TypeEdit)) - ,Map Reference (Set (Reference, TypeEdit))) - wrangleUpdatedTypes ops initialTermEdits = - -- 1. filter the edits to find the ones that are resolved (not conflicted) - -- 2. for each resolved (oldref,edit) pair, - -- 2b. look up the referents of that oldref. - -- 2c. if the referent is unedited, add it to the work: - -- 2c(i). add it to the term work list if it's a term ref, - -- 2c(ii). add it to the type work list if it's a type ref - foldM go (initialTermEdits, Map.empty) (Map.toList typeEdits) - where - typeEdits :: Map Reference TypeEdit -- oldreference, edit - typeEdits = resolved editedTypes b - go :: Monad m - => (Map Reference (Set (Reference, Either TermEdit TypeEdit)) - ,Map Reference (Set (Reference, TypeEdit))) - -> (Reference, TypeEdit) - -> m (Map Reference (Set (Reference, Either TermEdit TypeEdit)) - ,Map Reference (Set (Reference, TypeEdit))) - go (termWork, typeWork) (oldRef, edit) = - foldM go2 (termWork, typeWork) =<< - (transitiveClosure1 (dependents ops) oldRef) where - single referent oldRef edit = - Map.singleton referent (Set.singleton (oldRef, edit)) - singleRight referent oldRef edit = - Map.singleton referent (Set.singleton (oldRef, Right edit)) - go2 :: (Map Reference (Set (Reference, Either TermEdit TypeEdit)) - ,Map Reference (Set (Reference, TypeEdit))) - -> Reference - -> m (Map Reference (Set (Reference, Either TermEdit TypeEdit)) - ,Map Reference (Set (Reference, TypeEdit))) - go2 (termWorkAcc, typeWorkAcc) referent = - termOrTypeOp ops referent - (pure $ - if not $ R.memberDom referent (editedTerms b0) - then (termWorkAcc <> singleRight referent oldRef edit, typeWorkAcc) - else (termWorkAcc, typeWorkAcc)) - (pure $ - if not $ R.memberDom referent (editedTypes b0) - then (termWorkAcc, typeWorkAcc <> single referent oldRef edit) - else (termWorkAcc, typeWorkAcc)) +-- remaining :: forall m. Monad m => ReferenceOps m -> Branch -> m (Set RemainingWork) +-- remaining _ops _b = error "todo" +-- remaining ops b@(Branch (Causal.head -> b0)) = do +-- -- If any of r's dependencies have been updated, r should be updated. +-- -- Alternatively: If `a` has been edited, then all of a's dependents +-- -- should be edited. (Maybe a warning if they are updated to something +-- -- that still uses `a`.) +-- -- map from updated term to dependent + termedit +-- (obsoleteTerms, obsoleteTypes) <- wrangleUpdatedTypes ops =<< wrangleUpdatedTerms +-- pure . Set.fromList $ +-- (uncurry TermNameConflict <$> Map.toList (conflicts termNamespace b)) ++ +-- (uncurry TypeNameConflict <$> Map.toList (conflicts typeNamespace b)) ++ +-- (uncurry TermEditConflict <$> Map.toList (conflicts editedTerms b)) ++ +-- (uncurry TypeEditConflict <$> Map.toList (conflicts editedTypes b)) ++ +-- (uncurry ObsoleteTerm <$> Map.toList obsoleteTerms) ++ +-- (uncurry ObsoleteType <$> Map.toList obsoleteTypes) +-- where -- referent -> (oldreference, edit) +-- wrangleUpdatedTerms :: m (Map Reference (Set (Reference, Either TermEdit TypeEdit))) +-- wrangleUpdatedTerms = +-- -- 1. filter the edits to find the ones that are resolved (not conflicted) +-- -- 2. for each resolved (oldref,edit) pair, +-- -- 2b. look up the referents of that oldref. +-- -- 2c. if the referent is unedited, add it to the work: +-- -- 2c(i). add it to the term work list if it's a term ref, +-- -- 2c(ii). only terms can depend on terms, so it's a term ref. +-- let termEdits :: Map Reference TermEdit -- oldreference, edit +-- termEdits = resolved editedTerms b +-- transitiveDependents :: Reference -> m (Set Reference) +-- transitiveDependents r = transitiveClosure1 (dependents ops) r +-- isEdited r = R.memberDom r (editedTerms b0) +-- uneditedTransitiveDependents :: Reference -> m [Reference] +-- uneditedTransitiveDependents r = +-- filter (not . isEdited) . toList <$> transitiveDependents r +-- asSingleton :: Reference -> TermEdit -> Reference -> Map Reference (Set (Reference, Either TermEdit TypeEdit)) +-- asSingleton oldRef edit referent = Map.singleton referent (Set.singleton (oldRef, Left edit)) +-- workFromEdit :: (Reference, TermEdit) -> m (Map Reference (Set (Reference, Either TermEdit TypeEdit))) +-- workFromEdit (oldRef, edit) = +-- mconcat . fmap (asSingleton oldRef edit) <$> uneditedTransitiveDependents oldRef +-- in fmap mconcat (traverse workFromEdit $ Map.toList termEdits) +-- +-- wrangleUpdatedTypes :: +-- Monad m => ReferenceOps m +-- -> Map Reference (Set (Reference, Either TermEdit TypeEdit)) +-- -> m (Map Reference (Set (Reference, Either TermEdit TypeEdit)) +-- ,Map Reference (Set (Reference, TypeEdit))) +-- wrangleUpdatedTypes ops initialTermEdits = +-- -- 1. filter the edits to find the ones that are resolved (not conflicted) +-- -- 2. for each resolved (oldref,edit) pair, +-- -- 2b. look up the referents of that oldref. +-- -- 2c. if the referent is unedited, add it to the work: +-- -- 2c(i). add it to the term work list if it's a term ref, +-- -- 2c(ii). add it to the type work list if it's a type ref +-- foldM go (initialTermEdits, Map.empty) (Map.toList typeEdits) +-- where +-- typeEdits :: Map Reference TypeEdit -- oldreference, edit +-- typeEdits = resolved editedTypes b +-- go :: Monad m +-- => (Map Reference (Set (Reference, Either TermEdit TypeEdit)) +-- ,Map Reference (Set (Reference, TypeEdit))) +-- -> (Reference, TypeEdit) +-- -> m (Map Reference (Set (Reference, Either TermEdit TypeEdit)) +-- ,Map Reference (Set (Reference, TypeEdit))) +-- go (termWork, typeWork) (oldRef, edit) = +-- foldM go2 (termWork, typeWork) =<< +-- (transitiveClosure1 (dependents ops) oldRef) where +-- single referent oldRef edit = +-- Map.singleton referent (Set.singleton (oldRef, edit)) +-- singleRight referent oldRef edit = +-- Map.singleton referent (Set.singleton (oldRef, Right edit)) +-- go2 :: (Map Reference (Set (Reference, Either TermEdit TypeEdit)) +-- ,Map Reference (Set (Reference, TypeEdit))) +-- -> Reference +-- -> m (Map Reference (Set (Reference, Either TermEdit TypeEdit)) +-- ,Map Reference (Set (Reference, TypeEdit))) +-- go2 (termWorkAcc, typeWorkAcc) referent = +-- termOrTypeOp ops referent +-- (pure $ +-- if not $ R.memberDom referent (editedTerms b0) +-- then (termWorkAcc <> singleRight referent oldRef edit, typeWorkAcc) +-- else (termWorkAcc, typeWorkAcc)) +-- (pure $ +-- if not $ R.memberDom referent (editedTypes b0) +-- then (termWorkAcc, typeWorkAcc <> single referent oldRef edit) +-- else (termWorkAcc, typeWorkAcc)) empty :: Branch empty = Branch (Causal.one mempty) @@ -343,17 +338,21 @@ nameCollisions b0 b = go b0 (head b) where -- editsFromNameCollisions :: Codebase -> Branch0 -> Branch -> Branch -- Promote a typechecked file to a `Branch0` which can be added to a `Branch` -typecheckedFile :: Var v => UF.TypecheckedUnisonFile v a -> Branch0 +typecheckedFile :: forall v a. Var v => UF.TypecheckedUnisonFile v a -> Branch0 typecheckedFile file = let toName = Var.name hashedTerms = UF.hashTerms file + ctors :: [(v, Referent)] ctors = Map.toList $ UF.hashConstructors file - ctorNamespace = R.fromList [ (toName v, r) | (v, (r,_)) <- ctors ] - patternNamespace = R.fromList [ (toName v, (r,i)) | (v,(_,Term.Constructor' r i)) <- ctors ] - termNamespace1 = R.fromList [ (toName v, r) | (v, (r, _, _)) <- Map.toList hashedTerms ] + conNamespace = R.fromList [ (toName v, r) | (v, r@(Names.Con _ _)) <- ctors ] + reqNamespace = R.fromList [ (toName v, r) | (v, r@(Names.Req _ _)) <- ctors ] + patternNamespace = + R.fromList ([ (toName v, (r,i)) | (v, (Names.Con r i)) <- ctors ] <> + [ (toName v, (r,i)) | (v, (Names.Req r i)) <- ctors ]) + termNamespace1 = R.fromList [ (toName v, Names.Ref r) | (v, (r, _, _)) <- Map.toList hashedTerms ] typeNamespace1 = R.fromList [ (toName v, r) | (v, (r, _) ) <- Map.toList (UF.dataDeclarations' file) ] typeNamespace2 = R.fromList [ (toName v, r) | (v, (r, _) ) <- Map.toList (UF.effectDeclarations' file) ] - in Branch0 (termNamespace1 `R.union` ctorNamespace) + in Branch0 (termNamespace1 `R.union` conNamespace `R.union` reqNamespace) patternNamespace (typeNamespace1 `R.union` typeNamespace2) R.empty @@ -404,20 +403,13 @@ replaceType :: Monad m => ReferenceOps m -> Reference -> Reference -> Branch -> m Branch replaceType = undefined -add :: Monad m => ReferenceOps m -> Name -> Reference -> Branch -> m Branch -add ops n r (Branch b) = Branch <$> Causal.stepM go b where - go b = -- add to appropriate namespace - termOrTypeOp ops r - (pure b { termNamespace = R.insert n r $ termNamespace b }) - (pure b { typeNamespace = R.insert n r $ typeNamespace b }) - insertNames :: Monad m => ReferenceOps m -> Relation Reference Name -> Reference -> m (Relation Reference Name) insertNames ops m r = foldl' (flip $ R.insert r) m <$> name ops r -replaceTerm :: Reference -> Reference -> Typing -> Branch -> Branch +replaceTerm :: Referent -> Referent -> Typing -> Branch -> Branch replaceTerm old new typ (Branch b) = Branch $ Causal.step go b where edit = TermEdit.Replace new typ go b = b { editedTerms = R.insert old edit (editedTerms b) @@ -430,12 +422,14 @@ deleteOrphans deleteOrphans as b c = foldl' (\c a -> if R.memberDom a b then c else R.deleteDom a c) c as +-- Collect all the term/type references mentioned in this branch. codebase :: Monad m => ReferenceOps m -> Branch -> m (Set Reference) codebase ops (Branch (Causal.head -> Branch0 {..})) = let initial = Set.fromList $ - (snd <$> R.toList termNamespace) ++ + (Names.referentToReference . snd <$> R.toList termNamespace) ++ (snd <$> R.toList typeNamespace) ++ - (map snd (R.toList editedTerms) >>= TermEdit.references) ++ + (Names.referentToReference <$> + (map snd (R.toList editedTerms) >>= TermEdit.referents)) ++ (map snd (R.toList editedTypes) >>= TypeEdit.references) in transitiveClosure (dependencies ops) initial @@ -461,7 +455,7 @@ transitiveClosure1 f a = transitiveClosure f (Set.singleton a) transitiveClosure1' :: Ord a => (a -> Set a) -> a -> Set a transitiveClosure1' f a = runIdentity $ transitiveClosure1 (pure.f) a -deprecateTerm :: Reference -> Branch -> Branch +deprecateTerm :: Referent -> Branch -> Branch deprecateTerm old (Branch b) = Branch $ Causal.step go b where go b = b { editedTerms = R.insert old TermEdit.Deprecate (editedTerms b) , termNamespace = R.deleteRan old (termNamespace b) @@ -482,16 +476,16 @@ instance Hashable Branch0 where H.tokens termNamespace ++ H.tokens typeNamespace ++ H.tokens editedTerms ++ H.tokens editedTypes -resolveTerm :: Name -> Branch -> Set Reference +resolveTerm :: Name -> Branch -> Set Referent resolveTerm n (Branch (Causal.head -> b)) = R.lookupDom n (termNamespace b) -resolveTermUniquely :: Name -> Branch -> Maybe Reference +resolveTermUniquely :: Name -> Branch -> Maybe Referent resolveTermUniquely n b = case resolveTerm n b of s | Set.size s == 1 -> Set.lookupMin s - _ -> Nothing + _ -> Nothing -addTermName :: Reference -> Name -> Branch -> Branch +addTermName :: Referent -> Name -> Branch -> Branch addTermName r new (Branch b) = Branch $ Causal.step go b where go b = b { termNamespace = R.insert new r (termNamespace b) } @@ -499,19 +493,6 @@ addTypeName :: Reference -> Name -> Branch -> Branch addTypeName r new (Branch b) = Branch $ Causal.step go b where go b = b { typeNamespace = R.insert new r (typeNamespace b) } -addName :: Monad m => ReferenceOps m -> Reference -> Name -> Branch -> m Branch -addName ops r new b = - termOrTypeOp ops r (pure $ addTermName r new b) (pure $ addTypeName r new b) - -termOrTypeOp :: Monad m => ReferenceOps m -> Reference - -> m b -> m b -> m b -termOrTypeOp ops r ifTerm ifType = do - isTerm <- isTerm ops r - isType <- isType ops r - if isTerm then ifTerm - else if isType then ifType - else fail $ "malformed reference: " ++ show r - renameType :: Name -> Name -> Branch -> Branch renameType old new (Branch b) = Branch $ Causal.stepIf (R.memberDom old . typeNamespace) go b where @@ -529,8 +510,7 @@ toNames :: Branch -> Names toNames b = case head b of Branch0 {..} -> Names terms patterns types where - termRefs = fmap Names.Ref . Map.fromList $ R.toList termNamespace + termRefs = Map.fromList $ R.toList termNamespace patterns = Map.fromList $ R.toList patternNamespace types = Map.fromList $ R.toList typeNamespace terms = termRefs - diff --git a/parser-typechecker/src/Unison/Codebase/Serialization/V0.hs b/parser-typechecker/src/Unison/Codebase/Serialization/V0.hs index c4955a59a..97e91592c 100644 --- a/parser-typechecker/src/Unison/Codebase/Serialization/V0.hs +++ b/parser-typechecker/src/Unison/Codebase/Serialization/V0.hs @@ -457,7 +457,7 @@ getCausal getA = getWord8 >>= \case putTermEdit :: MonadPut m => TermEdit -> m () putTermEdit (TermEdit.Replace r typing) = - putWord8 1 *> putReference r *> case typing of + putWord8 1 *> putReferent r *> case typing of TermEdit.Same -> putWord8 1 TermEdit.Subtype -> putWord8 2 TermEdit.Different -> putWord8 3 @@ -465,7 +465,7 @@ putTermEdit TermEdit.Deprecate = putWord8 2 getTermEdit :: MonadGet m => m TermEdit getTermEdit = getWord8 >>= \case - 1 -> TermEdit.Replace <$> getReference <*> (getWord8 >>= \case + 1 -> TermEdit.Replace <$> getReferent <*> (getWord8 >>= \case 1 -> pure TermEdit.Same 2 -> pure TermEdit.Subtype 3 -> pure TermEdit.Different @@ -486,18 +486,18 @@ getTypeEdit = getWord8 >>= \case putBranch :: MonadPut m => Branch -> m () putBranch (Branch b) = putCausal b $ \Branch0 {..} -> do - putRelation termNamespace putText putReference + putRelation termNamespace putText putReferent putRelation patternNamespace putText (putPair' putReference putLength) putRelation typeNamespace putText putReference - putRelation editedTerms putReference putTermEdit + putRelation editedTerms putReferent putTermEdit putRelation editedTypes putReference putTypeEdit getBranch :: MonadGet m => m Branch getBranch = Branch <$> getCausal - (Branch0 <$> getRelation getText getReference + (Branch0 <$> getRelation getText getReferent <*> getRelation getText (getPair getReference getLength) <*> getRelation getText getReference - <*> getRelation getReference getTermEdit + <*> getRelation getReferent getTermEdit <*> getRelation getReference getTypeEdit) putDataDeclaration :: (MonadPut m, Ord v) diff --git a/parser-typechecker/src/Unison/Codebase/TermEdit.hs b/parser-typechecker/src/Unison/Codebase/TermEdit.hs index bdf944a37..268fb5b88 100644 --- a/parser-typechecker/src/Unison/Codebase/TermEdit.hs +++ b/parser-typechecker/src/Unison/Codebase/TermEdit.hs @@ -1,15 +1,15 @@ module Unison.Codebase.TermEdit where -import Unison.Reference (Reference) import Unison.Hashable (Hashable) import qualified Unison.Hashable as H +import Unison.Names (Referent) -data TermEdit = Replace Reference Typing | Deprecate +data TermEdit = Replace Referent Typing | Deprecate deriving (Eq, Ord, Show) -references :: TermEdit -> [Reference] -references (Replace r _) = [r] -references Deprecate = [] +referents :: TermEdit -> [Referent] +referents (Replace r _) = [r] +referents Deprecate = [] -- Replacements with the Same type can be automatically propagated. -- Replacements with a Subtype can be automatically propagated but may result in dependents getting more general types, so requires re-inference. @@ -26,6 +26,6 @@ instance Hashable TermEdit where tokens (Replace r t) = [H.Tag 0] ++ H.tokens r ++ H.tokens t tokens Deprecate = [H.Tag 1] -toReference :: TermEdit -> Maybe Reference +toReference :: TermEdit -> Maybe Referent toReference (Replace r _) = Just r toReference Deprecate = Nothing diff --git a/parser-typechecker/src/Unison/Names.hs b/parser-typechecker/src/Unison/Names.hs index 73f642595..fdbd4819c 100644 --- a/parser-typechecker/src/Unison/Names.hs +++ b/parser-typechecker/src/Unison/Names.hs @@ -1,18 +1,21 @@ -{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} module Unison.Names where -import Data.Bifunctor ( first ) +import Data.Bifunctor (first) import Data.List (foldl') import Data.Map (Map) import qualified Data.Map as Map import Data.Text (Text) import qualified Data.Text as Text -import Unison.Reference (Reference, pattern Builtin) +import Data.Word (Word64) +import Unison.Hashable (Hashable) +import qualified Unison.Hashable as H +import Unison.Reference (pattern Builtin, Reference) import Unison.Term (AnnotatedTerm, AnnotatedTerm2) import qualified Unison.Term as Term import Unison.Type (AnnotatedType) @@ -26,21 +29,33 @@ unqualified :: Name -> Name unqualified = last . Text.splitOn "." data Names = Names - { termNames :: Map Name Referent + { termNames :: Map Name Referent , patternNames :: Map Name (Reference, Int) - , typeNames :: Map Name Reference + , typeNames :: Map Name Reference } -- | The referent of a name data Referent = Ref Reference | Req Reference Int | Con Reference Int deriving (Show, Ord, Eq) +instance Hashable Referent where + tokens (Ref r) = [H.Tag 0] ++ H.tokens r + tokens (Req r i) = [H.Tag 1] ++ H.tokens r ++ H.tokens (fromIntegral i :: Word64) + tokens (Con r i) = [H.Tag 2] ++ H.tokens r ++ H.tokens (fromIntegral i :: Word64) + referentToTerm :: Ord v => a -> Referent -> AnnotatedTerm2 vt at ap v a referentToTerm a = \case Ref r -> Term.ref a r Req r i -> Term.request a r i Con r i -> Term.constructor a r i +termToReferent :: AnnotatedTerm2 vt at ap v a -> Maybe Referent +termToReferent t = case t of + Term.Ref' r -> Just $ Ref r + Term.Request' r i -> Just $ Req r i + Term.Constructor' r i -> Just $ Con r i + _ -> Nothing + referentToReference :: Referent -> Reference referentToReference = \case Ref r -> r diff --git a/parser-typechecker/src/Unison/PrettyPrintEnv.hs b/parser-typechecker/src/Unison/PrettyPrintEnv.hs index be3fe11de..edd94a6ce 100644 --- a/parser-typechecker/src/Unison/PrettyPrintEnv.hs +++ b/parser-typechecker/src/Unison/PrettyPrintEnv.hs @@ -7,7 +7,7 @@ import Data.Map (Map) import Unison.Reference (Reference) import qualified Data.Map as Map import qualified Data.Text as Text -import Unison.Names (Name,Names) +import Unison.Names (Name,Names,Referent) import qualified Unison.Names as Names type Histogram = Map Name Word @@ -15,9 +15,10 @@ type Histogram = Map Name Word -- Maps terms, types, constructors and constructor patterns to a histogram of names. data PrettyPrintEnv = PrettyPrintEnv { -- names for terms - terms :: Reference -> Histogram, + 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 @@ -27,7 +28,7 @@ fromNames :: Names -> PrettyPrintEnv fromNames ns = let terms = Map.fromList - [ (r, n) | (n, Names.Ref r) <- Map.toList (Names.termNames 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 @@ -43,7 +44,8 @@ fromNames ns = hist m k = maybe mempty (\n -> Map.fromList [(n, 1)]) $ Map.lookup k m in PrettyPrintEnv (hist terms) - (curry . hist $ constructors `Map.union` requests) + (curry $ hist constructors) + (curry $ hist requests) (curry $ hist patterns) (hist types) @@ -52,11 +54,12 @@ fromNames ns = instance Semigroup PrettyPrintEnv where (<>) = mappend instance Monoid PrettyPrintEnv where - mempty = PrettyPrintEnv (const mempty) (\_ _ -> mempty) (\_ _ -> mempty) (const mempty) + mempty = PrettyPrintEnv (const mempty) (\_ _ -> mempty) (\_ _ -> 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)) @@ -64,6 +67,7 @@ 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) @@ -83,26 +87,28 @@ fromTypeNames types = let toH (Just t) = Map.fromList [(t, 1)] in mempty { types = \r -> toH $ Map.lookup r m } -fromTermNames :: [(Reference,Name)] -> PrettyPrintEnv +fromTermNames :: [(Referent,Name)] -> PrettyPrintEnv fromTermNames tms = let m = Map.fromList tms toH Nothing = mempty toH (Just t) = Map.fromList [(t, 1)] in mempty { terms = \r -> toH $ Map.lookup r m } -fromConstructorNames :: [((Reference,Int), Name)] -> PrettyPrintEnv -fromConstructorNames ctors = let - m = Map.fromList ctors +fromConstructorNames :: [((Reference,Int), Name)] -> [((Reference,Int), Name)] -> PrettyPrintEnv +fromConstructorNames ctors reqs = let + cs = Map.fromList ctors + rs = Map.fromList reqs toH Nothing = mempty toH (Just t) = Map.fromList [(t, 1)] - in mempty { constructors = \r i -> toH $ Map.lookup (r,i) m - , patterns = \r i -> toH $ Map.lookup (r,i) m } + in mempty { constructors = \r i -> toH $ Map.lookup (r,i) cs + , requests = \r i -> toH $ Map.lookup (r,i) rs + , patterns = \r i -> toH $ Map.lookup (r,i) (cs `Map.union` rs) } -- These functions pick out the most common name and fall back -- to showing the `Reference` if no names are available -termName :: PrettyPrintEnv -> Reference -> Name -termName env r = pickName r (terms env r) +termName :: PrettyPrintEnv -> Referent -> Name +termName env r = pickNameReferent r (terms env r) typeName :: PrettyPrintEnv -> Reference -> Name typeName env r = pickName r (types env r) @@ -110,14 +116,22 @@ typeName env r = pickName r (types env r) constructorName :: PrettyPrintEnv -> Reference -> Int -> Name constructorName env r cid = pickNameCid r cid (constructors env r cid) +requestName :: PrettyPrintEnv -> Reference -> Int -> Name +requestName env r cid = pickNameCid r cid (requests env r cid) + patternName :: PrettyPrintEnv -> Reference -> Int -> Name -patternName env r cid = pickNameCid r cid (constructors env r cid) +patternName env r cid = pickNameCid r cid (patterns env r cid) pickName :: Reference -> Histogram -> Name pickName r h = case argmax snd (Map.toList h) of Nothing -> Text.pack (show r) Just (name,_) -> name +pickNameReferent :: Referent -> Histogram -> Name +pickNameReferent r h = case argmax snd (Map.toList h) of + Nothing -> Text.pack (show r) + Just (name,_) -> name + pickNameCid :: Reference -> Int -> Histogram -> Name pickNameCid r cid h = case argmax snd (Map.toList h) of Nothing -> Text.pack (show r) <> "#" <> Text.pack (show cid) diff --git a/parser-typechecker/src/Unison/PrintError.hs b/parser-typechecker/src/Unison/PrintError.hs index 0491f50f4..425ac1167 100644 --- a/parser-typechecker/src/Unison/PrintError.hs +++ b/parser-typechecker/src/Unison/PrintError.hs @@ -35,6 +35,7 @@ import qualified Unison.DataDeclaration as DD import Unison.Kind (Kind) import qualified Unison.Kind as Kind import qualified Unison.Lexer as L +import qualified Unison.Names as Names import Unison.Parser (Ann (..), Annotated, ann) import qualified Unison.Parser as Parser import qualified Unison.Reference as R @@ -780,7 +781,7 @@ renderKind :: Kind -> AnnotatedText a renderKind Kind.Star = "*" renderKind (Kind.Arrow k1 k2) = renderKind k1 <> " -> " <> renderKind k2 -showTermRef :: IsString s => Env -> R.Reference -> s +showTermRef :: IsString s => Env -> Names.Referent -> s showTermRef env r = fromString . Text.unpack $ PPE.termName env r showTypeRef :: IsString s => Env -> R.Reference -> s diff --git a/parser-typechecker/src/Unison/TermPrinter.hs b/parser-typechecker/src/Unison/TermPrinter.hs index de4e8c1bc..a045f1825 100755 --- a/parser-typechecker/src/Unison/TermPrinter.hs +++ b/parser-typechecker/src/Unison/TermPrinter.hs @@ -12,6 +12,7 @@ import Data.Vector() import Unison.ABT (pattern AbsN') import qualified Unison.Blank as Blank import Unison.Lexer (symbolyId0) +import qualified Unison.Names as Names import Unison.PatternP (Pattern) import qualified Unison.PatternP as Pattern import Unison.Term @@ -89,7 +90,7 @@ pretty :: Var v => PrettyPrintEnv -> Int -> AnnotatedTerm v a -> PrettyPrint Str -- `Maybe Int` identifies which constructor. pretty n p term = specialCases term $ \case Var' v -> l $ varName v - Ref' r -> l $ Text.unpack (PrettyPrintEnv.termName n r) + Ref' r -> l $ Text.unpack (PrettyPrintEnv.termName n (Names.Ref r)) Ann' tm t -> parenNest (p >= 0) $ pretty n 10 tm <> b" " <> (PP.Nest " " $ PP.Group (l": " <> TypePrinter.pretty n 0 t)) Int' i -> (if i >= 0 then l"+" else Empty) <> (l $ show i) @@ -104,7 +105,8 @@ pretty n p term = specialCases term $ \case Boolean' b -> if b then l"true" else l"false" Text' s -> l $ show s Blank' id -> l"_" <> (l $ fromMaybe "" (Blank.nameb id)) - RequestOrCtor' ref i -> l (Text.unpack (PrettyPrintEnv.constructorName n ref i)) + Constructor' ref i -> l (Text.unpack (PrettyPrintEnv.constructorName n ref i)) + Request' ref i -> l (Text.unpack (PrettyPrintEnv.requestName n ref i)) Handle' h body -> parenNest (p >= 2) $ l"handle" <> b" " <> pretty n 2 h <> b" " <> l"in" <> b" " <> PP.Nest " " (PP.Group (pretty n 2 body)) @@ -163,7 +165,7 @@ pretty n p term = specialCases term $ \case -- function names. So we produce "x + y" and "foo x y" but not "x `foo` y". binaryOpsPred :: Var v => AnnotatedTerm v a -> Bool binaryOpsPred = \case - Ref' r | isSymbolic (PrettyPrintEnv.termName n r) -> True + Ref' r | isSymbolic (PrettyPrintEnv.termName n (Names.Ref r)) -> True Var' v | isSymbolic (Var.name v) -> True _ -> False @@ -205,7 +207,7 @@ prettyPattern n p vs patt = case patt of Pattern.Constructor _ Type.UnitRef 0 [] -> (l"()", vs) Pattern.Constructor _ ref i pats -> let (pats_printed, tail_vs) = patterns vs pats - in (parenNest (p >= 10) $ l (Text.unpack (PrettyPrintEnv.constructorName n ref i)) <> pats_printed, tail_vs) + in (parenNest (p >= 10) $ l (Text.unpack (PrettyPrintEnv.patternName n ref i)) <> pats_printed, tail_vs) Pattern.As _ pat -> let (v : tail_vs) = vs (printed, eventual_tail) = prettyPattern n 11 tail_vs pat in (parenNest (p >= 11) $ ((l $ varName v) <> l"@" <> printed), eventual_tail) diff --git a/parser-typechecker/src/Unison/UnisonFile.hs b/parser-typechecker/src/Unison/UnisonFile.hs index 1095b60dd..a8852cdb1 100644 --- a/parser-typechecker/src/Unison/UnisonFile.hs +++ b/parser-typechecker/src/Unison/UnisonFile.hs @@ -9,7 +9,7 @@ import Control.Monad (join) import Data.Bifunctor (second) import Data.Map (Map) import qualified Data.Map as Map -import Data.Maybe (catMaybes) +import Data.Maybe (catMaybes, fromMaybe) import qualified Data.Set as Set import Data.Set (Set) import qualified Data.Text as Text @@ -17,7 +17,7 @@ import Unison.DataDeclaration (DataDeclaration') import Unison.DataDeclaration (EffectDeclaration' (..)) import Unison.DataDeclaration (hashDecls, toDataDecl, withEffectDecl) import qualified Unison.DataDeclaration as DD -import Unison.Names (Names) +import Unison.Names (Names, Referent) import qualified Unison.Names as Names import Unison.Reference (Reference) import Unison.Term (AnnotatedTerm) @@ -111,17 +111,23 @@ typecheckedUnisonFile ds es cs = TypecheckedUnisonFile ds es (removeWatches cs) filterDefs = filter (\(v, _, _) -> Text.take 1 (Var.name v) /= "_") hashConstructors - :: Var v => TypecheckedUnisonFile v a -> Map v (Reference, AnnotatedTerm v ()) + :: forall v a. Var v => TypecheckedUnisonFile v a -> Map v Referent hashConstructors file = let ctors1 = Map.elems (dataDeclarations' file) >>= \(ref, dd) -> [ (v, Term.constructor () ref i) | (v, i) <- DD.constructorVars dd `zip` [0 ..] ] ctors2 = Map.elems (effectDeclarations' file) >>= \(ref, dd) -> - [ (v, Term.constructor () ref i) + [ (v, Term.request () ref i) | (v, i) <- DD.constructorVars (DD.toDataDecl dd) `zip` [0 ..] ] - in Term.hashComponents (Map.fromList $ ctors1 ++ ctors2) + hashedComponents :: Map v (Reference, AnnotatedTerm v ()) + hashedComponents = Term.hashComponents (Map.fromList $ ctors1 ++ ctors2) + in + fromMaybe (error "Constructor wasn't a constructor") + . Names.termToReferent + . snd + <$> hashedComponents hashTerms :: Var v