mirror of
https://github.com/unisonweb/unison.git
synced 2024-10-04 21:57:25 +03:00
Branch.termNamespace maps Name to Referent
This commit is contained in:
Arya Irani
parent
62ed12a80b
commit
1a6b7cd3ff
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user