mirror of
https://github.com/unisonweb/unison.git
synced 2024-10-05 14:17:33 +03:00
Merge pull request #316 from unisonweb/topic/hashqualified-name
Support for hash-qualified names in `list` and `view`
This commit is contained in:
Paul Chiusano
GitHub
commit
10b1af16e2
2
.gitignore
vendored
2
.gitignore
vendored
@ -1,5 +1,5 @@
|
||||
# Unison
|
||||
.unison/
|
||||
.unison*/
|
||||
.unisonHistory
|
||||
|
||||
# Haskell
|
||||
|
||||
@ -3,9 +3,11 @@
|
||||
{-# LANGUAGE Rank2Types #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module Unison.Builtin where
|
||||
|
||||
import Control.Arrow ( first )
|
||||
import Control.Applicative ( liftA2 )
|
||||
import qualified Data.Map as Map
|
||||
import Data.Set ( Set )
|
||||
import qualified Data.Set as Set
|
||||
@ -30,9 +32,9 @@ import qualified Unison.TypeParser as TypeParser
|
||||
import qualified Unison.Util.ColorText as Color
|
||||
import Unison.Var ( Var )
|
||||
import qualified Unison.Var as Var
|
||||
import Unison.Names ( Names
|
||||
, Name
|
||||
)
|
||||
import Unison.Name ( Name )
|
||||
import qualified Unison.Name as Name
|
||||
import Unison.Names ( Names )
|
||||
import qualified Unison.Names as Names
|
||||
import qualified Unison.Typechecker.TypeLookup as TL
|
||||
import qualified Unison.Util.Relation as Rel
|
||||
@ -101,13 +103,13 @@ builtinTerms =
|
||||
(r, typ) <- Map.toList builtins0 ]
|
||||
|
||||
builtinTypesV :: Var v => [(v, R.Reference)]
|
||||
builtinTypesV = first (Var.named) <$> builtinTypes
|
||||
builtinTypesV = first (Name.toVar) <$> builtinTypes
|
||||
|
||||
builtinTypeNames :: Set Name
|
||||
builtinTypeNames = Set.fromList (map fst builtinTypes)
|
||||
|
||||
builtinTypes :: [(Name, R.Reference)]
|
||||
builtinTypes = (,) <*> R.Builtin <$>
|
||||
builtinTypes = liftA2 (,) Name.unsafeFromText R.Builtin <$>
|
||||
["Int", "Nat", "Float", "Boolean", "Sequence", "Text", "Stream", "Effect"]
|
||||
|
||||
-- | parse some builtin data types, and resolve their free variables using
|
||||
|
||||
@ -28,8 +28,6 @@ import Data.Maybe ( catMaybes
|
||||
)
|
||||
import Data.Set ( Set )
|
||||
import qualified Data.Set as Set
|
||||
import Data.String ( fromString )
|
||||
import qualified Data.Text as Text
|
||||
import Data.Text ( Text )
|
||||
import Data.Traversable ( for )
|
||||
import Text.EditDistance ( defaultEditCosts
|
||||
@ -42,7 +40,10 @@ import qualified Unison.Codebase.Branch as Branch
|
||||
import qualified Unison.Codebase.TermEdit as TermEdit
|
||||
import Unison.Codebase.TermEdit ( TermEdit )
|
||||
import qualified Unison.DataDeclaration as DD
|
||||
import Unison.Names ( Name )
|
||||
import Unison.HashQualified ( HashQualified )
|
||||
import qualified Unison.HashQualified as HQ
|
||||
import Unison.Name ( Name )
|
||||
import qualified Unison.Name as Name
|
||||
import Unison.Parser ( Ann )
|
||||
import qualified Unison.PrettyPrintEnv as PPE
|
||||
import Unison.Reference ( Reference )
|
||||
@ -75,6 +76,7 @@ type DataDeclaration v a = DD.DataDeclaration' v a
|
||||
type EffectDeclaration v a = DD.EffectDeclaration' v a
|
||||
type Term v a = Term.AnnotatedTerm v a
|
||||
type Type v a = Type.AnnotatedType v a
|
||||
type BranchName = Text
|
||||
|
||||
data Codebase m v a =
|
||||
Codebase { getTerm :: Reference.Id -> m (Maybe (Term v a))
|
||||
@ -83,12 +85,12 @@ data Codebase m v a =
|
||||
|
||||
, getTypeDeclaration :: Reference.Id -> m (Maybe (Decl v a))
|
||||
, putTypeDeclarationImpl :: Reference.Id -> Decl v a -> m ()
|
||||
, branches :: m [Name]
|
||||
, getBranch :: Name -> m (Maybe Branch)
|
||||
, branches :: m [BranchName]
|
||||
, getBranch :: BranchName -> m (Maybe Branch)
|
||||
-- thought: this merges the given branch with the existing branch
|
||||
-- or creates a new branch if there's no branch with that name
|
||||
, mergeBranch :: Name -> Branch -> m Branch
|
||||
, branchUpdates :: m (m (), m (Set Name))
|
||||
, mergeBranch :: BranchName -> Branch -> m Branch
|
||||
, branchUpdates :: m (m (), m (Set BranchName))
|
||||
|
||||
, dependentsImpl :: Reference -> m (Set Reference.Id)
|
||||
, builtinLoc :: a
|
||||
@ -126,19 +128,18 @@ typecheckingEnvironment code t = do
|
||||
Right d -> (Map.insert r d datas, effects)
|
||||
pure $ TL.TypeLookup termTypes datas effects
|
||||
|
||||
fuzzyFindTerms' :: Branch -> [String] -> [(Text, Referent)]
|
||||
fuzzyFindTerms' :: Branch -> [String] -> [(HashQualified, Referent)]
|
||||
fuzzyFindTerms' (Branch.head -> branch) query =
|
||||
let
|
||||
termNames = Text.unpack <$> toList (Branch.allTermNames branch)
|
||||
matchingTerms :: [String]
|
||||
terms = Branch.allTerms branch
|
||||
termNames = [(HQ.toString n, (n,r))
|
||||
| r <- toList terms
|
||||
, n <- toList (Branch.hashNamesForTerm r branch)]
|
||||
matchingTerms :: [(String,(HashQualified,Referent))]
|
||||
matchingTerms = if null query
|
||||
then termNames
|
||||
else query >>= \q -> sortedApproximateMatches q termNames
|
||||
refsForName :: String -> [Referent]
|
||||
refsForName (Text.pack -> name) = Set.toList $ Branch.termsNamed name branch
|
||||
makePair (Text.pack -> name) r =
|
||||
(Branch.hashQualifiedTermName branch name r, r)
|
||||
in matchingTerms >>= \name -> makePair name <$> refsForName name
|
||||
else query >>= \q -> sortedApproximateMatches' q termNames
|
||||
in snd <$> matchingTerms
|
||||
|
||||
fuzzyFindTermTypes
|
||||
:: forall m v a
|
||||
@ -146,7 +147,7 @@ fuzzyFindTermTypes
|
||||
=> Codebase m v a
|
||||
-> Branch
|
||||
-> [String]
|
||||
-> m [(Text, Referent, Maybe (Type v a))]
|
||||
-> m [(HashQualified, Referent, Maybe (Type v a))]
|
||||
fuzzyFindTermTypes codebase branch query =
|
||||
let found = fuzzyFindTerms' branch query
|
||||
tripleForRef name ref = (name, ref, ) <$> case ref of
|
||||
@ -155,17 +156,16 @@ fuzzyFindTermTypes codebase branch query =
|
||||
Referent.Con r cid -> getTypeOfConstructor codebase r cid
|
||||
in traverse (uncurry tripleForRef) found
|
||||
|
||||
fuzzyFindTypes' :: Branch -> [String] -> [(Text, Reference)]
|
||||
fuzzyFindTypes' :: Branch -> [String] -> [(HashQualified, Reference)]
|
||||
fuzzyFindTypes' (Branch.head -> branch) query =
|
||||
let
|
||||
typeNames =
|
||||
Text.unpack <$> toList (Branch.allTypeNames branch)
|
||||
typeNames = toList (Branch.allTypeNames branch)
|
||||
matchingTypes = if null query
|
||||
then typeNames
|
||||
else query >>= \q -> sortedApproximateMatches q typeNames
|
||||
refsForName (Text.pack -> name) = Set.toList $ Branch.typesNamed name branch
|
||||
makePair (Text.pack -> name) r =
|
||||
(Branch.hashQualifiedTypeName branch name r, r)
|
||||
else query >>= \q -> asStrings (sortedApproximateMatches q) typeNames
|
||||
asStrings f names = Name.fromString <$> f (Name.toString <$> names)
|
||||
refsForName name = Set.toList $ Branch.typesNamed name branch
|
||||
makePair name r = (Branch.hashQualifiedTypeName branch name r, r)
|
||||
in matchingTypes >>= \name -> makePair name <$> refsForName name
|
||||
|
||||
prettyTypeSource :: (Monad m, Var v) => Codebase m v a -> Name -> Reference -> Branch -> m (Maybe (Pretty ColorText))
|
||||
@ -176,18 +176,20 @@ listReferencesMatching
|
||||
:: (Var v, Monad m) => Codebase m v a -> Branch -> [String] -> m String
|
||||
listReferencesMatching code (Branch.head -> b) query = do
|
||||
let
|
||||
termNames = Text.unpack <$> toList (Branch.allTermNames b)
|
||||
typeNames = Text.unpack <$> toList (Branch.allTypeNames b)
|
||||
termNames = toList (Branch.allTermNames b)
|
||||
typeNames = toList (Branch.allTypeNames b)
|
||||
matchingTerms = if null query
|
||||
then termNames
|
||||
else query >>= \q -> sortedApproximateMatches q termNames
|
||||
else query >>= \q -> asStrings (sortedApproximateMatches q) termNames
|
||||
matchingTypes = if null query
|
||||
then typeNames
|
||||
else query >>= \q -> sortedApproximateMatches q typeNames
|
||||
else query >>= \q -> asStrings (sortedApproximateMatches q) typeNames
|
||||
matchingTypeRefs = matchingTypes
|
||||
>>= \name -> Set.toList (Branch.typesNamed (Text.pack name) b)
|
||||
>>= \name -> Set.toList (Branch.typesNamed name b)
|
||||
matchingTermRefs = matchingTerms
|
||||
>>= \name -> Set.toList (Branch.termsNamed (Text.pack name) b)
|
||||
>>= \name -> Set.toList (Branch.termsNamed name b)
|
||||
asStrings f names = Name.fromString <$> f (Name.toString <$> names)
|
||||
|
||||
listReferences code
|
||||
b
|
||||
(matchingTypeRefs ++ [ r | Ref r <- matchingTermRefs ])
|
||||
@ -195,7 +197,7 @@ listReferencesMatching code (Branch.head -> b) query = do
|
||||
listReferences
|
||||
:: (Var v, Monad m) => Codebase m v a -> Branch0 -> [Reference] -> m String
|
||||
listReferences code branch refs = do
|
||||
let ppe = Branch.prettyPrintEnv1 branch
|
||||
let ppe = Branch.prettyPrintEnv branch
|
||||
terms0 <- forM refs $ \r -> do
|
||||
otyp <- getTypeOfTerm code r
|
||||
pure $ (PPE.termName ppe (Referent.Ref r), otyp)
|
||||
@ -245,7 +247,7 @@ initialize c = do
|
||||
prettyBinding
|
||||
:: (Var.Var v, Monad m)
|
||||
=> Codebase m v a
|
||||
-> Name
|
||||
-> HashQualified
|
||||
-> Referent
|
||||
-> Branch0
|
||||
-> m (Maybe (Pretty String))
|
||||
@ -256,56 +258,26 @@ prettyBinding cb name r0@(Referent.Ref r1@(Reference.DerivedId r)) b =
|
||||
go Nothing = pure Nothing
|
||||
go (Just tm) =
|
||||
let
|
||||
-- We boost the `(r0,name)` association since if this is a recursive
|
||||
-- We force the `(r0,name)` association since if this is a recursive
|
||||
-- fn whose body also mentions `r`, want name to be the same as the binding.
|
||||
ppEnv = Branch.prettyPrintEnv [b]
|
||||
`mappend` PPE.scale 10 (PPE.fromTermNames [(r0, name)])
|
||||
ppEnv = PPE.assignTermName r0 name $ Branch.prettyPrintEnv b
|
||||
in case tm of
|
||||
Term.Ann' _ _ ->
|
||||
pure $ Just (TermPrinter.prettyBinding ppEnv (Var.named name) tm)
|
||||
pure $ Just (TermPrinter.prettyBinding ppEnv name tm)
|
||||
_ -> do
|
||||
Just typ <- getTypeOfTerm cb r1
|
||||
pure . Just $ TermPrinter.prettyBinding
|
||||
ppEnv
|
||||
(Var.named name)
|
||||
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,Referent)] -> Branch0 -> m (Pretty String)
|
||||
=> Codebase m v a -> [(HashQualified,Referent)] -> Branch0 -> m (Pretty String)
|
||||
prettyBindings cb tms b = do
|
||||
ds <- catMaybes <$> (forM tms $ \(name,r) -> prettyBinding cb name r b)
|
||||
pure $ PP.linesSpaced ds
|
||||
|
||||
-- Search for and display bindings matching the given query
|
||||
prettyBindingsQ
|
||||
:: (Var.Var v, Monad m)
|
||||
=> Codebase m v a
|
||||
-> String
|
||||
-> Branch0
|
||||
-> m (Pretty String)
|
||||
prettyBindingsQ cb query b =
|
||||
let possible = Branch.allTermNames b
|
||||
matches =
|
||||
sortedApproximateMatches query (Text.unpack <$> toList possible)
|
||||
str = fromString
|
||||
bs =
|
||||
[ (name, r)
|
||||
| name <- Text.pack <$> matches
|
||||
, r <- take 1 (toList $ Branch.termsNamed name b)
|
||||
]
|
||||
go pp = if length matches > 5
|
||||
then PP.linesSpaced
|
||||
[ pp
|
||||
, "... "
|
||||
<> str (show (length matches - 5))
|
||||
<> " more (use `> list "
|
||||
<> str query
|
||||
<> "` to see all matches)"
|
||||
]
|
||||
else pp
|
||||
in go <$> prettyBindings cb (take 5 bs) b
|
||||
|
||||
prettyListingQ
|
||||
:: (Var.Var v, Monad m)
|
||||
=> Codebase m v a
|
||||
@ -373,7 +345,7 @@ makeSelfContained
|
||||
-> m (UF.UnisonFile v a)
|
||||
makeSelfContained code b (UF.UnisonFile datas0 effects0 tm) = do
|
||||
deps <- foldM (transitiveDependencies code) Set.empty (Term.dependencies tm)
|
||||
let pp = Branch.prettyPrintEnv1 b
|
||||
let pp = Branch.prettyPrintEnv b
|
||||
termName r = PPE.termName pp (Referent.Ref r)
|
||||
typeName r = PPE.typeName pp r
|
||||
decls <- fmap catMaybes . forM (toList deps) $ \case
|
||||
@ -381,18 +353,18 @@ makeSelfContained code b (UF.UnisonFile datas0 effects0 tm) = do
|
||||
_ -> pure Nothing
|
||||
termsByRef <- fmap catMaybes . forM (toList deps) $ \case
|
||||
r@(Reference.DerivedId rid) ->
|
||||
fmap (r, Var.named (termName r), ) <$> getTerm code rid
|
||||
fmap (r, HQ.toVar (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 $ termName r))
|
||||
Just (Term.var (ABT.annotation t) (HQ.toVar $ termName r))
|
||||
go _ = Nothing
|
||||
datas = Map.fromList
|
||||
[ (v, (r, dd)) | (r, Right dd) <- decls, v <- [Var.named (typeName r)] ]
|
||||
[ (v, (r, dd)) | (r, Right dd) <- decls, v <- [HQ.toVar (typeName r)] ]
|
||||
effects = Map.fromList
|
||||
[ (v, (r, ed)) | (r, Left ed) <- decls, v <- [Var.named (typeName r)] ]
|
||||
[ (v, (r, ed)) | (r, Left ed) <- decls, v <- [HQ.toVar (typeName r)] ]
|
||||
bindings = [ ((ABT.annotation t, v), unref t) | (_, v, t) <- termsByRef ]
|
||||
unrefBindings bs = [ (av, unref t) | (av, t) <- bs ]
|
||||
tm' = case tm of
|
||||
@ -423,7 +395,30 @@ sortedApproximateMatches q possible = trim (sortOn fst matches)
|
||||
trim ((_, h) : _) | h == q = [h]
|
||||
trim ms = map snd $ takeWhile (\(n, _) -> n - 7 < nq `div` 4) ms
|
||||
|
||||
branchExists :: Functor m => Codebase m v a -> Name -> m Bool
|
||||
sortedApproximateMatches' :: String -> [(String,a)] -> [(String,a)]
|
||||
sortedApproximateMatches' q possible = trim (sortOn fst matches)
|
||||
where
|
||||
nq = length q
|
||||
score (s,_)
|
||||
| s == q = 0 :: Int
|
||||
| -- exact match is top choice
|
||||
map toLower q == map toLower s = 1
|
||||
| -- ignore case
|
||||
q `isSuffixOf` s = 2
|
||||
| -- matching suffix is pretty good
|
||||
q `isInfixOf` s = 3
|
||||
| -- a match somewhere
|
||||
q `isPrefixOf` s = 4
|
||||
| -- ...
|
||||
map toLower q `isInfixOf` map toLower s = 5
|
||||
| q `isSubsequenceOf` s = 6
|
||||
| otherwise = 7 + editDistance (map toLower q) (map toLower s)
|
||||
editDistance q s = levenshteinDistance defaultEditCosts q s
|
||||
matches = map (\s -> (score s, s)) possible
|
||||
trim ((_, (h,a)) : _) | h == q = [(h,a)]
|
||||
trim ms = map snd $ takeWhile (\(n, _) -> n - 7 < nq `div` 4) ms
|
||||
|
||||
branchExists :: Functor m => Codebase m v a -> BranchName -> m Bool
|
||||
branchExists codebase name = elem name <$> branches codebase
|
||||
|
||||
builtinBranch :: Branch
|
||||
@ -459,7 +454,7 @@ isTerm code = fmap isJust . getTypeOfTerm code
|
||||
|
||||
isType :: Applicative m => Codebase m v a -> Reference -> m Bool
|
||||
isType c r = case r of
|
||||
Reference.Builtin b -> pure (b `Set.member` Builtin.builtinTypeNames)
|
||||
Reference.Builtin b -> pure (Name.unsafeFromText b `Set.member` Builtin.builtinTypeNames)
|
||||
Reference.DerivedId r -> isJust <$> getTypeDeclaration c r
|
||||
_ -> error "impossible"
|
||||
|
||||
@ -497,7 +492,7 @@ unhashComponent
|
||||
-> m (Maybe (Map v (Reference, Term v a, Type v a)))
|
||||
unhashComponent code b ref = do
|
||||
let component = Reference.members $ Reference.componentFor ref
|
||||
ppe = Branch.prettyPrintEnv1 b
|
||||
ppe = Branch.prettyPrintEnv b
|
||||
isTerm <- isTerm code ref
|
||||
isType <- isType code ref
|
||||
if isTerm then do
|
||||
@ -510,7 +505,7 @@ unhashComponent code b ref = do
|
||||
Reference.DerivedId id -> do
|
||||
mtm <- getTerm code id
|
||||
tm <- maybe (fail $ "Missing term with id " <> show id) pure mtm
|
||||
pure (Var.named $ PPE.termName ppe (Referent.Ref termRef), (termRef, tm, tp))
|
||||
pure (HQ.toVar $ PPE.termName ppe (Referent.Ref termRef), (termRef, tm, tp))
|
||||
_ -> fail $ "Cannot unhashComponent for a builtin: " ++ show termRef
|
||||
unhash m =
|
||||
let f (ref,_oldTm,oldTyp) (_ref,newTm) = (ref,newTm,oldTyp)
|
||||
|
||||
@ -19,8 +19,6 @@ import Data.Map (Map)
|
||||
import qualified Data.Map as Map
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Text as Text
|
||||
import Data.Text (Text)
|
||||
import Prelude hiding (head,subtract)
|
||||
import Unison.Codebase.Causal (Causal)
|
||||
import qualified Unison.Codebase.Causal as Causal
|
||||
@ -32,10 +30,13 @@ import qualified Unison.DataDeclaration as DD
|
||||
import Unison.Hash (Hash)
|
||||
import Unison.Hashable (Hashable)
|
||||
import qualified Unison.Hashable as H
|
||||
import Unison.Names (Name, Names (..))
|
||||
import Unison.HashQualified (HashQualified)
|
||||
import qualified Unison.HashQualified as HashQualified
|
||||
import Unison.Name (Name)
|
||||
import Unison.Names (Names (..))
|
||||
import qualified Unison.Name as Name
|
||||
import qualified Unison.Names as Names
|
||||
import Unison.Reference (Reference)
|
||||
import qualified Unison.Reference as Reference
|
||||
import Unison.Referent (Referent)
|
||||
import qualified Unison.Referent as Referent
|
||||
import qualified Unison.UnisonFile as UF
|
||||
@ -45,7 +46,6 @@ import Unison.Util.TransitiveClosure (transitiveClosure)
|
||||
import Unison.PrettyPrintEnv (PrettyPrintEnv)
|
||||
import qualified Unison.PrettyPrintEnv as PPE
|
||||
import Unison.Var (Var)
|
||||
import qualified Unison.Var as Var
|
||||
|
||||
-- todo:
|
||||
-- probably should refactor Reference to include info about whether it
|
||||
@ -261,15 +261,22 @@ instance Monoid Branch0 where
|
||||
mempty = Branch0 mempty mempty R.empty R.empty
|
||||
mappend = (<>)
|
||||
|
||||
allNames :: Branch0 -> Set Name
|
||||
allNames = Set.union <$> allTermNames <*> allTypeNames
|
||||
allNamesHashQualified :: Branch0 -> Set HashQualified
|
||||
allNamesHashQualified b =
|
||||
Set.union (allTermsHashQualified b) (allTypesHashQualified b)
|
||||
|
||||
allTermNames :: Branch0 -> Set Name
|
||||
allTermNames = R.dom . termNamespace
|
||||
|
||||
allTermsHashQualified :: Branch0 -> Set HashQualified
|
||||
allTermsHashQualified b = foldMap (\r -> hashNamesForTerm r b) (allTerms b)
|
||||
|
||||
allTypeNames :: Branch0 -> Set Name
|
||||
allTypeNames b0 = R.dom (typeNamespace b0)
|
||||
|
||||
allTypesHashQualified :: Branch0 -> Set HashQualified
|
||||
allTypesHashQualified b = foldMap (\r -> hashNamesForType r b) (allTypes b)
|
||||
|
||||
hasTermNamed :: Name -> Branch0 -> Bool
|
||||
hasTermNamed n b = not . null $ termsNamed n b
|
||||
|
||||
@ -286,7 +293,10 @@ typesNamed :: Name -> Branch0 -> Set Reference
|
||||
typesNamed name = R.lookupDom name . typeNamespace
|
||||
|
||||
namesForTerm :: Referent -> Branch0 -> Set Name
|
||||
namesForTerm ref b = let
|
||||
namesForTerm ref = R.lookupRan ref . termNamespace
|
||||
|
||||
hashNamesForTerm :: Referent -> Branch0 -> Set HashQualified
|
||||
hashNamesForTerm ref b = let
|
||||
ns = (termNamespace b) :: Relation Name Referent
|
||||
hashLen = numHashChars b
|
||||
names = (R.lookupRan ref ns) :: Set Name
|
||||
@ -296,7 +306,10 @@ namesForTerm ref b = let
|
||||
in Set.map f names
|
||||
|
||||
namesForType :: Reference -> Branch0 -> Set Name
|
||||
namesForType ref b = let
|
||||
namesForType ref = R.lookupRan ref . typeNamespace
|
||||
|
||||
hashNamesForType :: Reference -> Branch0 -> Set HashQualified
|
||||
hashNamesForType ref b = let
|
||||
ns = (typeNamespace b) :: Relation Name Reference
|
||||
hashLen = numHashChars b
|
||||
names = (R.lookupRan ref ns) :: Set Name
|
||||
@ -305,60 +318,66 @@ namesForType ref b = let
|
||||
$ hashQualifyTypeName hashLen n (R.lookupDom n references)
|
||||
in Set.map f names
|
||||
|
||||
hashQualifyTermName :: Int -> Name -> Set Referent -> Map Referent Text
|
||||
hashQualifyTermName :: Int -> Name -> Set Referent -> Map Referent HashQualified
|
||||
hashQualifyTermName numHashChars n rs =
|
||||
if Set.size rs < 2 then Map.fromList [(r, n) | r <- toList rs ]
|
||||
else Map.fromList [ (r, n <> Text.pack (Referent.showShort numHashChars r))
|
||||
if Set.size rs < 2
|
||||
then Map.fromList [(r, HashQualified.fromName n) | r <- toList rs ]
|
||||
else Map.fromList [ (r, HashQualified.forReferent r numHashChars n)
|
||||
| r <- toList rs ]
|
||||
|
||||
hashQualifyTypeName :: Int -> Name -> Set Reference -> Map Reference Text
|
||||
hashQualifyTypeName :: Int -> Name -> Set Reference -> Map Reference HashQualified
|
||||
hashQualifyTypeName numHashChars n rs =
|
||||
if Set.size rs < 2 then Map.fromList [(r, n) | r <- toList rs ]
|
||||
else Map.fromList [ (r, n <> Text.pack (Reference.showShort numHashChars r))
|
||||
if Set.size rs < 2
|
||||
then Map.fromList [(r, HashQualified.fromName n) | r <- toList rs ]
|
||||
else Map.fromList [ (r, HashQualified.forReference r numHashChars n)
|
||||
| r <- toList rs ]
|
||||
|
||||
-- Get the appropriately hash-qualified version of a name for term.
|
||||
-- Should be the same as the input name if the branch is unconflicted.
|
||||
hashQualifiedTermName :: Branch0 -> Name -> Referent -> Text
|
||||
hashQualifiedTermName :: Branch0 -> Name -> Referent -> HashQualified
|
||||
hashQualifiedTermName b n r =
|
||||
if (> 1) . length . R.lookupDom n . termNamespace $ b then
|
||||
-- name is conflicted
|
||||
n <> Text.pack (Referent.showShort (numHashChars b) r)
|
||||
else n
|
||||
HashQualified.forReferent r (numHashChars b) n
|
||||
else HashQualified.fromName n
|
||||
|
||||
hashQualifiedTypeName :: Branch0 -> Name -> Reference -> Text
|
||||
hashQualifiedTypeName :: Branch0 -> Name -> Reference -> HashQualified
|
||||
hashQualifiedTypeName b n r =
|
||||
if (> 1) . length . R.lookupDom n . typeNamespace $ b then
|
||||
-- name is conflicted
|
||||
n <> Text.pack (Reference.showShort (numHashChars b) r)
|
||||
else n
|
||||
HashQualified.forReference r (numHashChars b) n
|
||||
else HashQualified.fromName n
|
||||
|
||||
oldNamesForTerm :: Int -> Referent -> Branch0 -> Set Name
|
||||
oldNamesForTerm :: Int -> Referent -> Branch0 -> Set HashQualified
|
||||
oldNamesForTerm numHashChars ref
|
||||
= Set.map (<> Text.pack (Referent.showShort numHashChars ref))
|
||||
= Set.map (HashQualified.forReferent ref numHashChars)
|
||||
. R.lookupRan ref
|
||||
. (view $ oldNamespaceL . terms)
|
||||
|
||||
oldNamesForType :: Int -> Reference -> Branch0 -> Set Name
|
||||
oldNamesForType :: Int -> Reference -> Branch0 -> Set HashQualified
|
||||
oldNamesForType numHashChars ref
|
||||
= Set.map (<> Text.pack (Reference.showShort numHashChars ref))
|
||||
= Set.map (HashQualified.forReference ref numHashChars)
|
||||
. R.lookupRan ref
|
||||
. (view $ oldNamespaceL . types)
|
||||
|
||||
numHashChars :: Branch0 -> Int
|
||||
numHashChars = const 3 -- todo: use trie to find depth of branching
|
||||
|
||||
prettyPrintEnv1 :: Branch0 -> PrettyPrintEnv
|
||||
prettyPrintEnv1 b = PPE.PrettyPrintEnv terms types where
|
||||
-- We must choose a canonical name for each referent in the branch.
|
||||
-- In the future we might like a way for the user to choose a preferred name
|
||||
-- (i.e. just `unionLeft` the user preferences before the arbitrary choice)
|
||||
prettyPrintEnv :: Branch0 -> PrettyPrintEnv
|
||||
prettyPrintEnv b = PPE.PrettyPrintEnv terms types where
|
||||
hashLen = numHashChars b
|
||||
or :: Set a -> Set a -> Set a
|
||||
or s1 s2 = if Set.null s1 then s2 else s1
|
||||
terms r = multiset $ namesForTerm r b `or` oldNamesForTerm hashLen r b
|
||||
types r = multiset $ namesForType r b `or` oldNamesForType hashLen r b
|
||||
multiset ks = Map.fromList [ (k, 1) | k <- Set.toList ks ]
|
||||
terms r =
|
||||
Set.lookupMin $ hashNamesForTerm r b `or` oldNamesForTerm hashLen r b
|
||||
types r =
|
||||
Set.lookupMin $ hashNamesForType r b `or` oldNamesForType hashLen r b
|
||||
|
||||
prettyPrintEnv :: [Branch0] -> PrettyPrintEnv
|
||||
prettyPrintEnv = foldMap prettyPrintEnv1
|
||||
-- prettyPrintEnv :: [Branch0] -> PrettyPrintEnv
|
||||
-- prettyPrintEnv = foldMap prettyPrintEnv1
|
||||
|
||||
before :: Branch -> Branch -> Bool
|
||||
before b b2 = unbranch b `Causal.before` unbranch b2
|
||||
@ -547,7 +566,7 @@ fromTypecheckedFile
|
||||
:: forall v a . Var v => UF.TypecheckedUnisonFile v a -> Branch0
|
||||
fromTypecheckedFile file =
|
||||
let
|
||||
toName = Var.name
|
||||
toName = Name.unsafeFromVar
|
||||
hashedTerms = UF.hashTerms file
|
||||
ctors :: [(v, Referent)]
|
||||
ctors = Map.toList $ UF.hashConstructors file
|
||||
@ -590,8 +609,8 @@ intersectWithFile branch file =
|
||||
>>= (>>= (\(v, _, _) -> if Set.member v termNames then [v] else []))
|
||||
)
|
||||
where
|
||||
typeNames = Set.map (Var.named) $ allTypeNames branch
|
||||
termNames = Set.map (Var.named) $ allTermNames branch
|
||||
typeNames = Set.map (Name.toVar) $ allTypeNames branch
|
||||
termNames = Set.map (Name.toVar) $ allTermNames branch
|
||||
|
||||
|
||||
modify :: (Branch0 -> Branch0) -> Branch -> Branch
|
||||
|
||||
@ -1,538 +0,0 @@
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE DoAndIfThenElse #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module Unison.Codebase.CommandLine (main) where
|
||||
|
||||
import Data.Bifunctor ( second )
|
||||
import System.Random ( randomRIO )
|
||||
import Control.Concurrent ( forkIO )
|
||||
import Control.Exception ( catch
|
||||
, finally
|
||||
)
|
||||
import Control.Monad ( forM_
|
||||
, forever
|
||||
, liftM2
|
||||
, void
|
||||
, when
|
||||
)
|
||||
import Control.Monad.STM ( STM
|
||||
, atomically
|
||||
)
|
||||
import qualified Data.Char as Char
|
||||
import Data.Foldable ( toList
|
||||
, traverse_
|
||||
)
|
||||
import Data.IORef ( IORef
|
||||
, newIORef
|
||||
, writeIORef
|
||||
, readIORef
|
||||
)
|
||||
import Data.List ( find
|
||||
, isSuffixOf
|
||||
, sort
|
||||
)
|
||||
import Data.Set ( Set )
|
||||
import qualified Data.Set as Set
|
||||
import Data.String ( fromString )
|
||||
import Data.Strings ( strPadLeft )
|
||||
import Data.Text ( Text
|
||||
, pack
|
||||
, unpack
|
||||
)
|
||||
import qualified Data.Text.IO
|
||||
import qualified System.Console.ANSI as Console
|
||||
import System.FilePath ( FilePath )
|
||||
import qualified Text.Read as Read
|
||||
import qualified Unison.Reference as Reference
|
||||
import System.IO.Error ( isEOFError )
|
||||
import qualified Unison.Builtin as B
|
||||
import Unison.Codebase ( Codebase )
|
||||
import qualified Unison.Codebase as Codebase
|
||||
import Unison.Codebase.Branch ( Branch )
|
||||
import qualified Unison.Codebase.Branch as Branch
|
||||
import Unison.Names ( Name )
|
||||
import Unison.Codebase.Runtime ( Runtime )
|
||||
import qualified Unison.Codebase.Runtime as RT
|
||||
import qualified Unison.Codebase.Watch as Watch
|
||||
import Unison.FileParsers ( parseAndSynthesizeFile )
|
||||
import qualified Unison.Parser as Parser
|
||||
import qualified Unison.PrintError as PrintError
|
||||
import Unison.PrintError ( prettyParseError
|
||||
, prettyTypecheckedFile
|
||||
, renderNoteAsANSI
|
||||
)
|
||||
import Unison.Result ( pattern Result )
|
||||
import qualified Unison.Result as Result
|
||||
import qualified Unison.UnisonFile as UF
|
||||
import qualified Unison.Util.ColorText as Color
|
||||
import qualified Unison.Util.Menu as Menu
|
||||
import Unison.Util.Monoid
|
||||
import qualified Unison.Util.Pretty as PP
|
||||
import Unison.Util.TQueue ( TQueue )
|
||||
import qualified Unison.Util.TQueue as TQueue
|
||||
import Unison.Var ( Var )
|
||||
import qualified Unison.Var as Var
|
||||
import qualified Data.Map as Map
|
||||
import Unison.Parser ( Ann )
|
||||
import qualified Data.Text as Text
|
||||
import Unison.Names ( Names )
|
||||
import qualified Unison.Term as Term
|
||||
|
||||
data Event
|
||||
= UnisonFileChanged FilePath Text
|
||||
| UnisonBranchChanged (Set Name)
|
||||
| EOF
|
||||
|
||||
allow :: FilePath -> Bool
|
||||
allow = liftM2 (||) (".u" `isSuffixOf`) (".uu" `isSuffixOf`)
|
||||
|
||||
data CreateCancel = Create | Cancel deriving Show
|
||||
|
||||
main
|
||||
:: forall v
|
||||
. Var v
|
||||
=> FilePath
|
||||
-> Name
|
||||
-> Maybe FilePath
|
||||
-> IO (Runtime v)
|
||||
-> Codebase IO v Ann
|
||||
-> IO ()
|
||||
main dir currentBranchName initialFile startRuntime codebase = do
|
||||
queue <- TQueue.newIO
|
||||
lineQueue <- TQueue.newIO
|
||||
runtime <- startRuntime
|
||||
lastTypechecked <- newIORef
|
||||
(Nothing, UF.typecheckedUnisonFile0, mempty)
|
||||
let takeActualLine = atomically (takeLine lineQueue)
|
||||
|
||||
-- load initial unison file if specified
|
||||
case initialFile of
|
||||
Just file | allow file -> do
|
||||
text <- Data.Text.IO.readFile file
|
||||
atomically . TQueue.enqueue queue $ UnisonFileChanged file text
|
||||
_ -> pure ()
|
||||
|
||||
-- enqueue stdin into lineQueue
|
||||
void
|
||||
. forkIO
|
||||
. (`catch` eofHandler queue)
|
||||
. forever
|
||||
$ getChar
|
||||
>>= atomically
|
||||
. TQueue.enqueue lineQueue
|
||||
|
||||
-- watch for .u file changes
|
||||
void . forkIO $ do
|
||||
(_, watcher) <- Watch.watchDirectory dir allow
|
||||
forever $ do
|
||||
(filePath, text) <- watcher
|
||||
atomically . TQueue.enqueue queue $ UnisonFileChanged filePath text
|
||||
|
||||
-- watch for external branch changes
|
||||
(cancelExternalBranchUpdates, externalBranchUpdates) <- Codebase.branchUpdates
|
||||
codebase
|
||||
void . forkIO . forever $ do
|
||||
updatedBranches <- externalBranchUpdates
|
||||
atomically . TQueue.enqueue queue . UnisonBranchChanged $ updatedBranches
|
||||
|
||||
-- load current branch from disk
|
||||
branch <- Codebase.getBranch codebase currentBranchName
|
||||
(`finally` (RT.terminate runtime *> cancelExternalBranchUpdates))
|
||||
$ case branch of
|
||||
Nothing -> do
|
||||
selectBranch codebase currentBranchName takeActualLine >>= \case
|
||||
Just (name, branch) ->
|
||||
go0 branch name queue lineQueue lastTypechecked runtime
|
||||
Nothing -> putStrLn "Exiting."
|
||||
Just b ->
|
||||
go0 b currentBranchName queue lineQueue lastTypechecked runtime
|
||||
where
|
||||
eofHandler queue e =
|
||||
if isEOFError e then (atomically . TQueue.enqueue queue) EOF else ioError e
|
||||
go0
|
||||
:: Branch
|
||||
-> Name
|
||||
-> TQueue Event
|
||||
-> TQueue Char
|
||||
-> IORef
|
||||
( Maybe FilePath
|
||||
, UF.TypecheckedUnisonFile v Parser.Ann
|
||||
, PrintError.Env
|
||||
)
|
||||
-> Runtime v
|
||||
-> IO ()
|
||||
go0 branch branchName queue lineQueue lastTypechecked runtime = go
|
||||
branch
|
||||
branchName
|
||||
where
|
||||
clearLastTypechecked =
|
||||
writeIORef lastTypechecked (Nothing, UF.typecheckedUnisonFile0, mempty)
|
||||
-- print prompt and whatever input was on it / at it
|
||||
printPrompt :: Name -> IO ()
|
||||
printPrompt branchName = do
|
||||
incompleteLine <- atomically . peekIncompleteLine $ lineQueue
|
||||
putStr $ "\r" ++ unpack branchName ++ "> " ++ incompleteLine
|
||||
|
||||
handleUnisonFile :: Runtime v -> Names -> FilePath -> Text -> IO ()
|
||||
handleUnisonFile runtime names filePath src = do
|
||||
Result notes r <- Result.getResult $ parseAndSynthesizeFile
|
||||
(pure . const B.typeLookup <> Codebase.typeLookupForDependencies codebase)
|
||||
names
|
||||
filePath
|
||||
src
|
||||
case r of
|
||||
Nothing -> do -- parsing failed
|
||||
Console.setTitle "Unison \128721"
|
||||
forM_ notes $ \case
|
||||
Result.Parsing err -> do
|
||||
putStrLn . Color.toANSI $ prettyParseError (unpack src) err
|
||||
clearLastTypechecked
|
||||
err ->
|
||||
error
|
||||
$ "I was expecting a parsing error here but got:\n"
|
||||
++ show err
|
||||
|
||||
Just (errorEnv, r) -> case r of
|
||||
Nothing -> do -- typechecking failed
|
||||
Console.setTitle "Unison \128721"
|
||||
let showNote notes = intercalateMap
|
||||
"\n\n"
|
||||
(renderNoteAsANSI errorEnv (unpack src))
|
||||
(filter notInfo notes)
|
||||
notInfo (Result.TypeInfo _) = False
|
||||
notInfo _ = True
|
||||
putStrLn . showNote . toList $ notes
|
||||
clearLastTypechecked
|
||||
Just unisonFile -> do
|
||||
Console.setTitle "Unison ✅"
|
||||
let emoticons = "🌸🌺🌹🌻🌼🌷🌵🌴🍄🌲"
|
||||
n <- randomRIO (0, length emoticons - 1)
|
||||
let uf = UF.discardTerm unisonFile
|
||||
defs = prettyTypecheckedFile uf errorEnv
|
||||
prettyDefs = Color.toANSI defs
|
||||
when (not $ null defs) . putStrLn
|
||||
$ "✅ "
|
||||
++ [emoticons !! n]
|
||||
++ " Found and typechecked the following definitions in "
|
||||
++ filePath
|
||||
++ ":\n"
|
||||
writeIORef lastTypechecked (Just filePath, uf, errorEnv)
|
||||
putStrLn prettyDefs
|
||||
putStrLn
|
||||
"👀 Now evaluating any watch expressions (lines starting with `>`) ...\n"
|
||||
selfContainedFile <- Codebase.makeSelfContained codebase (Branch.head branch) $ UF.discardTypes' unisonFile
|
||||
(watchExpressions, _term) <-
|
||||
RT.evaluate runtime selfContainedFile codebase
|
||||
uncurry (Watch.watchPrinter names) `traverse_` watchExpressions
|
||||
|
||||
go :: Branch -> Name -> IO ()
|
||||
go branch name = do
|
||||
printPrompt name
|
||||
|
||||
-- wait for new lines from user or asynchronous events from filesystem
|
||||
TQueue.raceIO (TQueue.peek queue) (awaitCompleteLine lineQueue) >>= \case
|
||||
Right _ -> processLine branch name
|
||||
Left _ -> atomically (TQueue.dequeue queue) >>= \case
|
||||
EOF -> putStrLn "^D"
|
||||
UnisonFileChanged filePath text -> do
|
||||
Console.setTitle "Unison"
|
||||
Console.clearScreen
|
||||
Console.setCursorPosition 0 0
|
||||
let names = Branch.toNames branch
|
||||
handleUnisonFile runtime names filePath text
|
||||
go branch name
|
||||
UnisonBranchChanged branches -> if Set.member name branches
|
||||
then do
|
||||
b' <- Codebase.getBranch codebase name
|
||||
case b' of
|
||||
Just b' -> do
|
||||
when (branch /= b') $ do
|
||||
putStrLn "I've merged some external changes to the branch."
|
||||
putStrLn
|
||||
$ "TODO: tell the user what changed as a result of the merge"
|
||||
go b' name
|
||||
Nothing -> do
|
||||
putStrLn
|
||||
$ "The current branch was deleted by some external process, "
|
||||
++ "so I'm going to re-save what I have in memory."
|
||||
branch' <- mergeBranchAndShowDiff codebase name branch
|
||||
go branch' name
|
||||
else go branch name
|
||||
|
||||
-- Looks at `lastTypechecked` for matching definitions and lets the user
|
||||
-- add them to the codebase. Present the user with a menu if args doesn't
|
||||
-- match what's in lastTypechecked.
|
||||
addDefinitions :: Branch -> Name -> [String] -> IO ()
|
||||
addDefinitions branch name args = case args of
|
||||
_ -> readIORef lastTypechecked >>= \(filePath, typecheckedFile, env) ->
|
||||
case filePath of
|
||||
Nothing -> do
|
||||
putStrLn
|
||||
$ "Nothing to do. Editing a .u file in "
|
||||
<> dir
|
||||
<> " will tell me about new definitions."
|
||||
go branch name
|
||||
Just _ -> do
|
||||
let branchUpdate = Branch.fromTypecheckedFile typecheckedFile
|
||||
collisions = Branch.nameCollisions branchUpdate (Branch.head branch)
|
||||
-- todo: collisions should really be collisions `Branch.subtract` branch,
|
||||
-- since if the names have a matching hash that's fine
|
||||
if collisions /= mempty
|
||||
then do
|
||||
putStrLn
|
||||
$ "The following names collided with existing definitions:\n"
|
||||
putStrLn $ intercalateMap
|
||||
" "
|
||||
Text.unpack
|
||||
(toList $ Branch.allNames collisions)
|
||||
putStrLn
|
||||
"\nUse the `> edit` command to have these definitions replace the existing ones."
|
||||
go branch name
|
||||
else do
|
||||
-- todo: this should probably just be a function in Codebase,
|
||||
-- something like
|
||||
-- addFile :: Codebase -> TypecheckedUnisonFile -> m ()
|
||||
let hashedTerms = UF.hashTerms typecheckedFile
|
||||
putStrLn $ "Adding the following definitions:"
|
||||
putStrLn ""
|
||||
putStrLn $ Color.toANSI
|
||||
(prettyTypecheckedFile typecheckedFile env)
|
||||
putStrLn ""
|
||||
let
|
||||
allTypeDecls =
|
||||
(second Left <$> UF.effectDeclarations' typecheckedFile)
|
||||
`Map.union` ( second Right
|
||||
<$> UF.dataDeclarations' typecheckedFile
|
||||
)
|
||||
|
||||
forM_ (Map.toList allTypeDecls)
|
||||
$ \(v, (r@(Reference.DerivedId id), dd)) -> do
|
||||
decl <- Codebase.getTypeDeclaration codebase id
|
||||
case decl of
|
||||
Nothing -> do
|
||||
Codebase.putTypeDeclaration codebase id dd
|
||||
Just _ ->
|
||||
-- todo - can treat this as adding an alias
|
||||
-- (same hash, but different name in this branch)
|
||||
putStrLn
|
||||
$ Var.nameStr v
|
||||
++ " already exists with hash "
|
||||
++ show r
|
||||
++ ", skipping."
|
||||
forM_ (Map.toList hashedTerms)
|
||||
$ \(v, (r@(Reference.DerivedId id), tm, typ)) -> do
|
||||
o <- Codebase.getTerm codebase id
|
||||
case o of
|
||||
Just _ ->
|
||||
-- todo - can treat this as adding an alias
|
||||
-- (same hash, but different name in this branch)
|
||||
putStrLn
|
||||
$ Var.nameStr v
|
||||
++ " already exists with hash "
|
||||
++ show r
|
||||
++ ", skipping."
|
||||
Nothing ->
|
||||
-- Discard all line/column info when adding to the codebase
|
||||
Codebase.putTerm
|
||||
codebase
|
||||
id
|
||||
(Term.amap (const Parser.External) tm)
|
||||
typ
|
||||
|
||||
branch <- mergeBranchAndShowDiff
|
||||
codebase
|
||||
name
|
||||
(Branch.append branchUpdate branch)
|
||||
|
||||
let emoticons = "🌉🏙🌃🌁🌅🎆🌄🌠🌇"
|
||||
n <- randomRIO (0, length emoticons - 1)
|
||||
putStrLn
|
||||
$ (emoticons !! n)
|
||||
: " All done. You can view or edit any definition via `> view <name>`."
|
||||
putStrLn ""
|
||||
clearLastTypechecked
|
||||
go branch name
|
||||
|
||||
viewDefinitions :: Branch -> Name -> [String] -> IO ()
|
||||
viewDefinitions branch name args = do
|
||||
prettys <- traverse (\q -> Codebase.prettyBindingsQ codebase q (Branch.head branch))
|
||||
args
|
||||
putStrLn . PP.render 80 $ PP.linesSpaced prettys
|
||||
go branch name
|
||||
|
||||
processLine :: Branch -> Name -> IO ()
|
||||
processLine branch name = do
|
||||
let takeActualLine = atomically $ takeLine lineQueue
|
||||
line <- takeActualLine
|
||||
case words line of
|
||||
"add" : args -> addDefinitions branch name args
|
||||
"view" : args -> viewDefinitions branch name args
|
||||
ls : args
|
||||
| ls == "list" || -- todo: more comprehensive way of allowing command abbreviations
|
||||
ls == "ls" ||
|
||||
ls == "l"
|
||||
-> do
|
||||
out <- Codebase.listReferencesMatching codebase branch args
|
||||
putStrLn out
|
||||
putStrLn ""
|
||||
go branch name
|
||||
|
||||
["branch"] -> do
|
||||
branches <- sort <$> Codebase.branches codebase
|
||||
forM_ branches $ \name' -> if name' == name
|
||||
then putStrLn $ " * " ++ unpack name'
|
||||
else putStrLn $ " " ++ unpack name'
|
||||
-- idea: could instead prompt user and read directly from lineQueue to handle
|
||||
go branch name
|
||||
|
||||
["branch", name'] -> do
|
||||
branch' <- selectBranch codebase (pack name') takeActualLine
|
||||
case branch' of
|
||||
Just (name, branch) -> go branch name
|
||||
Nothing -> putStrLn "Ok, nevermind." *> go branch name
|
||||
|
||||
["fork", newName0] -> do
|
||||
let newName = pack newName0
|
||||
branchExists <- Codebase.branchExists codebase newName
|
||||
if branchExists
|
||||
then do
|
||||
putStrLn $ "Sorry, a branch by that name already exists."
|
||||
go branch name
|
||||
else do
|
||||
branch' <- mergeBranchAndShowDiff codebase newName branch
|
||||
go branch' newName
|
||||
|
||||
["merge", from] -> do
|
||||
branch' <- Codebase.getBranch codebase $ pack from
|
||||
case branch' of
|
||||
Nothing -> do
|
||||
putStrLn
|
||||
$ "Sorry, I can't find a branch by that name to merge from."
|
||||
go branch name
|
||||
Just branch' -> do
|
||||
branch'' <- mergeBranchAndShowDiff codebase name branch'
|
||||
putStrLn $ "Flawless victory!"
|
||||
go branch'' name
|
||||
|
||||
-- rename a term/type/... in the current branch
|
||||
["rename", from, to]
|
||||
-> let
|
||||
terms = Branch.termsNamed (pack from) (Branch.head branch)
|
||||
types = Branch.typesNamed (pack from) (Branch.head branch)
|
||||
renameTerm branch = do
|
||||
let branch' = Branch.modify (Branch.renameTerm (pack from) (pack to)) branch
|
||||
mergeBranchAndShowDiff codebase name branch'
|
||||
renameType branch = do
|
||||
let branch' = Branch.modify (Branch.renameType (pack from) (pack to)) branch
|
||||
mergeBranchAndShowDiff codebase name branch'
|
||||
go' b = go b name
|
||||
in
|
||||
case (toList terms, toList types) of
|
||||
([], []) -> putStrLn "I couldn't find anything by that name." >> go' branch
|
||||
([_term], [] ) -> renameTerm branch >>= go'
|
||||
([] , [_typ]) -> renameType branch >>= go'
|
||||
([_term], [_typ]) -> do
|
||||
putStrLn
|
||||
"Do you want to rename the [term], [type], [both], or [neither]?"
|
||||
putStr ">> "
|
||||
(atomically . fmap words . takeLine) lineQueue >>= \case
|
||||
["term"] -> renameTerm branch >>= go'
|
||||
["type"] -> renameType branch >>= go'
|
||||
["both"] -> renameTerm branch >>= renameType >>= go'
|
||||
_ -> go' branch
|
||||
(_terms, _types) -> do
|
||||
-- idea: print out _terms and _types, so user can view them
|
||||
putStrLn
|
||||
$ "There's more than one thing called "
|
||||
++ from
|
||||
++ "."
|
||||
putStrLn
|
||||
$ "Use `> <command to resolve conflicts> unname "
|
||||
++ from
|
||||
++ "` to resolve conflicts, then try again."
|
||||
go' branch
|
||||
[] -> go branch name
|
||||
x ->
|
||||
putStrLn ("I don't know how to " ++ unwords x ++ ".")
|
||||
*> go branch name
|
||||
-- should never block
|
||||
peekIncompleteLine :: TQueue Char -> STM String
|
||||
peekIncompleteLine q = TQueue.tryPeekWhile (/= '\n') q
|
||||
|
||||
-- block until a full line is available
|
||||
takeLine :: TQueue Char -> STM String
|
||||
takeLine q = do
|
||||
line <- TQueue.takeWhile (/= '\n') q
|
||||
ch <- TQueue.dequeue q
|
||||
if (ch /= '\n') then error "unpossibility in takeLine" else pure line
|
||||
|
||||
-- blocks until a line ending in '\n' is available
|
||||
awaitCompleteLine :: TQueue Char -> STM ()
|
||||
awaitCompleteLine ch = void $ TQueue.peekWhile (/= '\n') ch
|
||||
|
||||
-- let the user pick from a list of labeled `a`s
|
||||
-- todo: rewrite this to let them toggle stuff
|
||||
_multipleChoice :: [(String, a)] -> TQueue Char -> IO [a]
|
||||
_multipleChoice as lineQueue = do
|
||||
let render ((s, _), index) = putStrLn $ strPadLeft ' ' 5 ("[" ++ show index ++ "] ") ++ s
|
||||
traverse_ render (as `zip` [(1::Int)..])
|
||||
putStrLn "Please enter your selection as a space separated list of numbers."
|
||||
putStr ">> "
|
||||
numbers <- (atomically . fmap words . takeLine) lineQueue
|
||||
case traverse Read.readMaybe numbers of
|
||||
Nothing ->
|
||||
putStrLn "Sorry, I couldn't understand at least one of those numbers."
|
||||
>> _multipleChoice as lineQueue
|
||||
Just numbers -> case find (\i -> i < 1 || i > length as) numbers of
|
||||
Just i ->
|
||||
(putStrLn $ "You entered the number " ++ show i ++ " which wasn't one of the choices.")
|
||||
>> _multipleChoice as lineQueue
|
||||
Nothing -> pure $ snd . (as !!) . (+ (-1)) <$> numbers
|
||||
|
||||
-- Merges `branch` into any the branch `name`, creating it if necessary.
|
||||
mergeBranchAndShowDiff :: Monad m => Codebase m v a -> Name -> Branch -> m Branch
|
||||
mergeBranchAndShowDiff codebase targetName sourceBranch = do
|
||||
branch' <- Codebase.mergeBranch codebase targetName sourceBranch
|
||||
-- when (branch' /= branch) $
|
||||
-- putStrLn $ "Some extra stuff appeared right when you forked, "
|
||||
-- ++ "and I went ahead and smashed it all together for you!"
|
||||
pure branch'
|
||||
|
||||
foo :: Text -> (String, Text)
|
||||
foo name = (unpack name, name)
|
||||
|
||||
selectBranch
|
||||
:: Codebase IO v a -> Name -> IO String -> IO (Maybe (Name, Branch))
|
||||
selectBranch codebase name takeLine = do
|
||||
let branchMenu caption branches = Menu.menu1
|
||||
takeLine -- console
|
||||
caption -- caption
|
||||
(fromString . unpack) -- render
|
||||
(fromString . fmap Char.toLower . show) -- renderMeta
|
||||
(foo <$> branches) -- groups
|
||||
[("create", Create), ("cancel", Cancel)] -- metas
|
||||
Nothing -- initial
|
||||
branch <- Codebase.getBranch codebase name
|
||||
case branch of
|
||||
-- if branch named `name` exists, load it,
|
||||
Just branch -> pure . Just $ (name, branch)
|
||||
-- otherwise,
|
||||
-- list branches that do exist, plus option to create, plus option to cancel
|
||||
Nothing -> do
|
||||
let caption =
|
||||
fromString
|
||||
$ "The branch "
|
||||
++ show name
|
||||
++ " doesn't exist. "
|
||||
++ "Do you want to create it, or pick a different one?"
|
||||
branches <- Codebase.branches codebase
|
||||
choice <- branchMenu caption branches
|
||||
case choice of
|
||||
Just (Left Cancel) -> pure Nothing
|
||||
Just (Left Create) -> do
|
||||
branch <- mergeBranchAndShowDiff codebase name Codebase.builtinBranch
|
||||
pure $ Just (name, branch)
|
||||
Just (Right name) -> selectBranch codebase name takeLine
|
||||
Nothing -> pure Nothing
|
||||
@ -51,7 +51,14 @@ import qualified Unison.Codebase.Editor.Actions as Actions
|
||||
import Unison.Codebase.Runtime (Runtime)
|
||||
import qualified Unison.Codebase.Runtime as Runtime
|
||||
import qualified Unison.Codebase.Watch as Watch
|
||||
import qualified Unison.HashQualified as HQ
|
||||
import Unison.Name (Name)
|
||||
import qualified Unison.Name as Name
|
||||
import qualified Unison.Names as Names
|
||||
import Unison.NamePrinter (prettyName,
|
||||
prettyHashQualified,
|
||||
styleHashQualified
|
||||
)
|
||||
import Unison.Parser (Ann)
|
||||
import qualified Unison.PrettyPrintEnv as PPE
|
||||
import Unison.PrintError (prettyParseError,
|
||||
@ -86,11 +93,11 @@ notifyUser dir o = case o of
|
||||
MissingThing r -> missing n r
|
||||
BuiltinThing -> builtin n
|
||||
RegularThing tm -> P.map fromString $
|
||||
TermPrinter.prettyBinding ppe (Var.named n) tm
|
||||
TermPrinter.prettyBinding ppe n tm
|
||||
prettyTypes = map go2 types
|
||||
builtin n = P.wrap $ "--" <> P.text n <> " is built-in."
|
||||
builtin n = P.wrap $ "--" <> prettyHashQualified n <> " is built-in."
|
||||
missing n r = P.wrap (
|
||||
"-- The name " <> P.text n <> " is assigned to the "
|
||||
"-- The name " <> prettyHashQualified n <> " is assigned to the "
|
||||
<> "reference " <> fromString (show r ++ ",")
|
||||
<> "which is missing from the codebase.")
|
||||
<> P.newline
|
||||
@ -159,7 +166,7 @@ notifyUser dir o = case o of
|
||||
$ "I don't know of any "
|
||||
<> fromString (Names.renderNameTarget nameTarget)
|
||||
<> " named "
|
||||
<> P.red (P.text name)
|
||||
<> P.red (prettyName name)
|
||||
<> " in the branch "
|
||||
<> P.blue (P.text branchName)
|
||||
<> "."
|
||||
@ -170,7 +177,7 @@ notifyUser dir o = case o of
|
||||
$ "There's already a "
|
||||
<> fromString (Names.renderNameTarget nameTarget)
|
||||
<> " named "
|
||||
<> P.red (P.text name)
|
||||
<> P.red (prettyName name)
|
||||
<> " in the branch "
|
||||
<> P.blue (P.text branchName)
|
||||
<> "."
|
||||
@ -179,7 +186,7 @@ notifyUser dir o = case o of
|
||||
. warn
|
||||
. P.wrap
|
||||
$ "The name "
|
||||
<> P.red (P.text name)
|
||||
<> P.red (prettyName name)
|
||||
<> " refers to more than one "
|
||||
<> fromString (Names.renderNameTarget nameTarget)
|
||||
<> " in the branch "
|
||||
@ -203,7 +210,7 @@ notifyUser dir o = case o of
|
||||
else " " <> P.text n
|
||||
in intercalateMap "\n" go (sort branches)
|
||||
ListOfDefinitions branch terms types ->
|
||||
let ppe = Branch.prettyPrintEnv1 (Branch.head branch)
|
||||
let ppe = Branch.prettyPrintEnv (Branch.head branch)
|
||||
sigs0 = (\(name, _, typ) -> (name, typ)) <$> terms
|
||||
sigs = [(name,t) | (name, Just t) <- sigs0 ]
|
||||
impossible = terms >>= \case
|
||||
@ -235,14 +242,14 @@ notifyUser dir o = case o of
|
||||
termTypesFromFile =
|
||||
Map.fromList [ (v,t) | (v,_,t) <- join (UF.topLevelComponents file) ]
|
||||
ppe =
|
||||
Branch.prettyPrintEnv1 (Branch.head branch) `PPE.unionLeft`
|
||||
Branch.prettyPrintEnv1 (Branch.fromTypecheckedFile file)
|
||||
Branch.prettyPrintEnv (Branch.head branch) `PPE.unionLeft`
|
||||
Branch.prettyPrintEnv (Branch.fromTypecheckedFile file)
|
||||
filterTermTypes vs =
|
||||
[ (Var.name v,t) | v <- toList vs
|
||||
[ (HQ.fromVar v,t) | v <- toList vs
|
||||
, t <- maybe (error $ "There wasn't a type for " ++ show v ++ " in termTypesFromFile!") pure (Map.lookup v termTypesFromFile)]
|
||||
prettyDeclHeader v = case UF.getDecl' file v of
|
||||
Just (Left _) -> TypePrinter.prettyEffectHeader (Var.name v)
|
||||
Just (Right _) -> TypePrinter.prettyDataHeader (Var.name v)
|
||||
Just (Left _) -> TypePrinter.prettyEffectHeader (HQ.fromVar v)
|
||||
Just (Right _) -> TypePrinter.prettyDataHeader (HQ.fromVar v)
|
||||
Nothing -> error "Wat."
|
||||
addMsg = if not (null addedTypes && null addedTerms)
|
||||
then Just . P.okCallout $
|
||||
@ -323,8 +330,8 @@ notifyUser dir o = case o of
|
||||
Just (sampleName0, sampleExistingName0) =
|
||||
(f . Branch.typeCollisions) (E.needsAlias s) <|>
|
||||
(f . Branch.termCollisions) (E.needsAlias s)
|
||||
sampleNewName' = P.group (P.text sampleName0 <> "`")
|
||||
sampleOldName = P.text . head . toList $ sampleExistingName0 in
|
||||
sampleNewName' = P.group (prettyName sampleName0 <> "`")
|
||||
sampleOldName = prettyName . head . toList $ sampleExistingName0 in
|
||||
|
||||
P.wrap ("I skipped these definitions because they already" <> P.bold "exist with other names:") <> "\n\n" <>
|
||||
P.indentN 2 (
|
||||
@ -332,16 +339,17 @@ notifyUser dir o = case o of
|
||||
P.align
|
||||
-- ("type Optional", "aka " ++ commas existingNames)
|
||||
-- todo: something is wrong here: only one oldName is being shown, instead of all
|
||||
[(prettyDeclHeader $ Var.named newName,
|
||||
"aka " <> P.commas (P.text <$> toList oldNames)) |
|
||||
[(prettyDeclHeader $ Name.toVar newName,
|
||||
"aka " <> P.commas (prettyName <$> toList oldNames)) |
|
||||
(newName, oldNames) <-
|
||||
Map.toList . R.domain . Branch.typeCollisions $ (E.needsAlias s) ],
|
||||
TypePrinter.prettySignatures' ppe
|
||||
TypePrinter.prettySignaturesAlt' ppe
|
||||
-- foo, foo2, fasdf : a -> b -> c
|
||||
[ (intercalateMap ", " id (name : toList oldNames), typ)
|
||||
-- note: this shit vvvv is not a Name.
|
||||
[ (name : fmap HQ.fromName (toList oldNames), typ)
|
||||
| (newName, oldNames) <-
|
||||
Map.toList . R.domain . Branch.termCollisions $ (E.needsAlias s)
|
||||
, (name, typ) <- filterTermTypes [Var.named newName]
|
||||
, (name, typ) <- filterTermTypes [Name.toVar newName]
|
||||
]
|
||||
])
|
||||
<> "\n\n"
|
||||
@ -354,17 +362,17 @@ notifyUser dir o = case o of
|
||||
P.wrap ("I can't update these terms because the" <> P.bold "names are currently assigned to constructors:") <> "\n\n" <>
|
||||
P.indentN 2
|
||||
(P.column2
|
||||
[ (P.text $ Var.name v
|
||||
, "is a constructor for " <>
|
||||
P.text (PPE.typeName ppe (Referent.toReference r)))
|
||||
[ (P.text $ Var.name v, "is a constructor for " <> go r)
|
||||
| (v, r) <- Map.toList termExistingCtorCollisions ]
|
||||
)
|
||||
<> "\n\n"
|
||||
<> tip "You can `rename` these constructors to free up the names for your new definitions."
|
||||
else Nothing
|
||||
where
|
||||
go r = prettyHashQualified (PPE.typeName ppe (Referent.toReference r))
|
||||
ctorExistingTermCollisions = E.constructorExistingTermCollisions s
|
||||
commaRefs rs = P.wrap $ P.commas (map go rs) where
|
||||
go r = P.text (PPE.termName ppe r)
|
||||
go r = prettyHashQualified (PPE.termName ppe r)
|
||||
ctorExistingTermMsg =
|
||||
if not (null ctorExistingTermCollisions)
|
||||
then Just . P.warnCallout $
|
||||
@ -409,10 +417,10 @@ notifyUser dir o = case o of
|
||||
types = R.dom $ Branch.typeNamespace branch
|
||||
when (not $ null terms) $ do
|
||||
putStrLn "🙅 These terms have conflicts: "
|
||||
traverse_ (\x -> putStrLn (" " ++ Text.unpack x)) terms
|
||||
traverse_ (\x -> putStrLn (" " ++ Name.toString x)) terms
|
||||
when (not $ null types) $ do
|
||||
putStrLn "🙅 These types have conflicts: "
|
||||
traverse_ (\x -> putStrLn (" " ++ Text.unpack x)) types
|
||||
traverse_ (\x -> putStrLn (" " ++ Name.toString x)) types
|
||||
-- TODO: Present conflicting TermEdits and TypeEdits
|
||||
-- if we ever allow users to edit hashes directly.
|
||||
FileChangeEvent _sourceName _src -> pure ()
|
||||
@ -437,7 +445,7 @@ notifyUser dir o = case o of
|
||||
<> "..."
|
||||
]
|
||||
TodoOutput branch todo ->
|
||||
let ppe = Branch.prettyPrintEnv1 (Branch.head branch) in
|
||||
let ppe = Branch.prettyPrintEnv (Branch.head branch) in
|
||||
if E.todoScore todo == 0 && E.todoConflicts todo == mempty
|
||||
then putPrettyLn . P.okCallout $ "No conflicts or edits in progress."
|
||||
else do
|
||||
@ -483,6 +491,7 @@ notifyUser dir o = case o of
|
||||
])
|
||||
|
||||
where
|
||||
renderNameConflicts :: Set.Set Name -> Set.Set Name -> [P.Pretty CT.ColorText]
|
||||
renderNameConflicts conflictedTypeNames conflictedTermNames =
|
||||
if null allNames then []
|
||||
else [
|
||||
@ -490,15 +499,15 @@ notifyUser dir o = case o of
|
||||
if Set.null conflictedTypeNames then []
|
||||
else [
|
||||
P.wrap ("These" <> P.bold "types have conflicting definitions:")
|
||||
`P.hang` P.commas (P.blue . P.text <$> toList conflictedTypeNames)
|
||||
`P.hang` P.commas (P.blue . prettyName <$> toList conflictedTypeNames)
|
||||
],
|
||||
if Set.null conflictedTermNames then []
|
||||
else [
|
||||
P.wrap ("These" <> P.bold "terms have conflicting definitions:")
|
||||
`P.hang` P.commas (P.blue . P.text <$> toList conflictedTermNames)
|
||||
`P.hang` P.commas (P.blue . prettyName <$> toList conflictedTermNames)
|
||||
],
|
||||
[tip $ "This occurs when merging branches that both indepenently introduce the same name. Use "
|
||||
<> P.group ("`view " <> P.sep " " (P.text <$> take 3 allNames) <> "`")
|
||||
<> P.group ("`view " <> P.sep " " (prettyName <$> take 3 allNames) <> "`")
|
||||
<> "to see the conflicting defintions, then use `rename`"
|
||||
<> "and/or `replace` to resolve the conflicts."]
|
||||
]
|
||||
@ -516,21 +525,21 @@ notifyUser dir o = case o of
|
||||
<> "to pick a replacement." -- todo: eventually something with `edit`
|
||||
]]
|
||||
where
|
||||
name (Left (r,_)) = P.name P.bold (PPE.typeName ppe r)
|
||||
name (Right (r,_)) = P.name P.bold (PPE.termName ppe (Referent.Ref r))
|
||||
name (Left (r,_)) = styleHashQualified P.bold (PPE.typeName ppe r)
|
||||
name (Right (r,_)) = styleHashQualified P.bold (PPE.termName ppe (Referent.Ref r))
|
||||
formatTypeEdits es = P.wrap $ mconcat [
|
||||
"was",
|
||||
if TypeEdit.Deprecate `elem` es
|
||||
then "deprecated and also replaced with"
|
||||
else "replaced with",
|
||||
P.oxfordCommas [ P.name P.bold (PPE.typeName ppe r) | TypeEdit.Replace r <- toList es ]
|
||||
P.oxfordCommas [ styleHashQualified P.bold (PPE.typeName ppe r) | TypeEdit.Replace r <- toList es ]
|
||||
]
|
||||
formatTermEdits es = P.wrap $ mconcat [
|
||||
"was",
|
||||
if TermEdit.Deprecate `elem` es
|
||||
then "deprecated and also replaced with"
|
||||
else "replaced with",
|
||||
P.oxfordCommas [ P.name P.bold (PPE.termName ppe (Referent.Ref r)) | TermEdit.Replace r _ <- toList es ]
|
||||
P.oxfordCommas [ styleHashQualified P.bold (PPE.termName ppe (Referent.Ref r)) | TermEdit.Replace r _ <- toList es ]
|
||||
]
|
||||
formatConflict e@(Left (_, edits)) =
|
||||
"The type " <> name e <> formatTypeEdits (toList edits)
|
||||
@ -551,41 +560,41 @@ notifyUser dir o = case o of
|
||||
when (not . Set.null $ E.changedSuccessfully r) . putPrettyLn . P.okCallout $
|
||||
P.wrap $ "I" <> pastTenseCmd <> "the"
|
||||
<> ns (E.changedSuccessfully r)
|
||||
<> P.blue (P.text oldName)
|
||||
<> "to" <> P.green (P.text (newName <> "."))
|
||||
<> P.blue (prettyName oldName)
|
||||
<> "to" <> P.group (P.green (prettyName newName) <> ".")
|
||||
when (not . Set.null $ E.oldNameConflicted r) . putPrettyLn . P.warnCallout $
|
||||
(P.wrap $ "I couldn't" <> cmd <> "the"
|
||||
<> ns (E.oldNameConflicted r)
|
||||
<> P.blue (P.text oldName)
|
||||
<> "to" <> P.green (P.text newName)
|
||||
<> P.blue (prettyName oldName)
|
||||
<> "to" <> P.green (prettyName newName)
|
||||
<> "because of conflicts.")
|
||||
<> "\n\n"
|
||||
<> tip "Use `todo` to view more information on conflicts and remaining work."
|
||||
when (not . Set.null $ E.newNameAlreadyExists r) . putPrettyLn . P.warnCallout $
|
||||
(P.wrap $ "I couldn't" <> cmd <> P.blue (P.text oldName)
|
||||
<> "to" <> P.green (P.text newName)
|
||||
(P.wrap $ "I couldn't" <> cmd <> P.blue (prettyName oldName)
|
||||
<> "to" <> P.green (prettyName newName)
|
||||
<> "because the "
|
||||
<> ns (E.newNameAlreadyExists r)
|
||||
<> "already exist(s).")
|
||||
<> "\n\n"
|
||||
<> tip
|
||||
("Use" <> P.group ("`rename " <> P.text newName <> " <newname>`") <>
|
||||
"to make" <> P.text newName <> "available.")
|
||||
("Use" <> P.group ("`rename " <> prettyName newName <> " <newname>`") <>
|
||||
"to make" <> prettyName newName <> "available.")
|
||||
where
|
||||
ns targets = P.oxfordCommas $
|
||||
map (fromString . Names.renderNameTarget) (toList targets)
|
||||
|
||||
formatMissingStuff :: (Show a, Show b)
|
||||
=> [(Names.Name, a)] -> [(Names.Name, b)] -> [P.Pretty P.ColorText]
|
||||
formatMissingStuff :: (Show tm, Show typ)
|
||||
=> [(HQ.HashQualified, tm)] -> [(HQ.HashQualified, typ)] -> [P.Pretty P.ColorText]
|
||||
formatMissingStuff terms types = catMaybes [
|
||||
(if null terms then Nothing else Just . P.fatalCallout $
|
||||
P.wrap "The following terms have a missing or corrupted type signature:"
|
||||
<> "\n\n"
|
||||
<> P.column2 [ (P.text name, fromString (show ref)) | (name, ref) <- terms ]),
|
||||
<> P.column2 [ (prettyHashQualified name, fromString (show ref)) | (name, ref) <- terms ]),
|
||||
(if null types then Nothing else Just . P.fatalCallout $
|
||||
P.wrap "The following types weren't found in the codebase:"
|
||||
<> "\n\n"
|
||||
<> P.column2 [ (P.text name, fromString (show ref)) | (name, ref) <- types ])
|
||||
<> P.column2 [ (prettyHashQualified name, fromString (show ref)) | (name, ref) <- types ])
|
||||
]
|
||||
|
||||
allow :: FilePath -> Bool
|
||||
@ -692,7 +701,7 @@ validInputs = validPatterns
|
||||
let bs = Text.unpack <$> branches
|
||||
pure $ autoComplete q bs
|
||||
definitionQueryArg = ArgumentType "definition query" $ \q _ b -> do
|
||||
let names = Text.unpack <$> toList (Branch.allNames (Branch.head b))
|
||||
let names = HQ.toString <$> toList (Branch.allNamesHashQualified (Branch.head b))
|
||||
pure $ autoComplete q names
|
||||
noCompletions = ArgumentType "a word" $ \_ _ _ -> pure []
|
||||
quit = InputPattern
|
||||
@ -809,8 +818,8 @@ validInputs = validPatterns
|
||||
(\case
|
||||
[oldName, newName] -> Right $ RenameUnconflictedI
|
||||
allTargets
|
||||
(Text.pack oldName)
|
||||
(Text.pack newName)
|
||||
(fromString oldName)
|
||||
(fromString newName)
|
||||
_ -> Left . P.warnCallout $ P.wrap
|
||||
"`rename` takes two arguments, like `rename oldname newname`."
|
||||
)
|
||||
@ -822,8 +831,8 @@ validInputs = validPatterns
|
||||
(\case
|
||||
[oldName, newName] -> Right $ RenameUnconflictedI
|
||||
allTargets
|
||||
(Text.pack oldName)
|
||||
(Text.pack newName)
|
||||
(fromString oldName)
|
||||
(fromString newName)
|
||||
_ -> Left . P.warnCallout $ P.wrap
|
||||
"`rename` takes two arguments, like `rename oldname newname`."
|
||||
)
|
||||
@ -837,8 +846,8 @@ validInputs = validPatterns
|
||||
(\case
|
||||
[oldName, newName] -> Right $ AliasUnconflictedI
|
||||
allTargets
|
||||
(Text.pack oldName)
|
||||
(Text.pack newName)
|
||||
(fromString oldName)
|
||||
(fromString newName)
|
||||
_ -> Left . warn $ P.wrap
|
||||
"`alias` takes two arguments, like `alias oldname newname`."
|
||||
)
|
||||
|
||||
@ -34,8 +34,10 @@ import Unison.Codebase.Branch ( Branch
|
||||
import qualified Unison.Codebase.Branch as Branch
|
||||
import qualified Unison.DataDeclaration as DD
|
||||
import Unison.FileParsers ( parseAndSynthesizeFile )
|
||||
import Unison.Names ( Name
|
||||
, Names
|
||||
import Unison.HashQualified ( HashQualified )
|
||||
import Unison.Name ( Name )
|
||||
import qualified Unison.Name as Name
|
||||
import Unison.Names ( Names
|
||||
, NameTarget
|
||||
)
|
||||
import qualified Unison.Names as Names
|
||||
@ -64,13 +66,12 @@ import qualified Unison.UnisonFile as UF
|
||||
import Unison.Util.Free ( Free )
|
||||
import qualified Unison.Util.Free as Free
|
||||
import Unison.Var ( Var )
|
||||
import qualified Unison.Var as Var
|
||||
|
||||
data Event
|
||||
= UnisonFileChanged SourceName Text
|
||||
| UnisonBranchChanged (Set Name)
|
||||
| UnisonBranchChanged (Set BranchName)
|
||||
|
||||
type BranchName = Name
|
||||
type BranchName = Text
|
||||
type Source = Text -- "id x = x\nconst a b = a"
|
||||
type SourceName = Text -- "foo.u" or "buffer 7"
|
||||
type TypecheckingResult v =
|
||||
@ -181,8 +182,8 @@ data Output v
|
||||
| BranchAlreadyExists BranchName
|
||||
| ListOfBranches BranchName [BranchName]
|
||||
| ListOfDefinitions Branch
|
||||
[(Name, Referent, Maybe (Type v Ann))]
|
||||
[(Name, Reference, DisplayThing (Decl v Ann))]
|
||||
[(HashQualified, Referent, Maybe (Type v Ann))]
|
||||
[(HashQualified, Reference, DisplayThing (Decl v Ann))]
|
||||
| SlurpOutput (SlurpResult v)
|
||||
-- Original source, followed by the errors:
|
||||
| ParseErrors Text [Parser.Err v]
|
||||
@ -203,11 +204,11 @@ data TodoOutput v a
|
||||
= TodoOutput_ {
|
||||
todoScore :: Int,
|
||||
todoFrontier ::
|
||||
( [(Name, Reference, Maybe (Type v a))]
|
||||
, [(Name, Reference, DisplayThing (Decl v a))]),
|
||||
( [(HashQualified, Reference, Maybe (Type v a))]
|
||||
, [(HashQualified, Reference, DisplayThing (Decl v a))]),
|
||||
todoFrontierDependents ::
|
||||
( [(Score, Name, Reference, Maybe (Type v a))]
|
||||
, [(Score, Name, Reference, DisplayThing (Decl v a))]),
|
||||
( [(Score, HashQualified, Reference, Maybe (Type v a))]
|
||||
, [(Score, HashQualified, Reference, DisplayThing (Decl v a))]),
|
||||
todoConflicts :: Branch0
|
||||
} deriving (Show)
|
||||
|
||||
@ -305,12 +306,12 @@ data Command i v a where
|
||||
-- Return a list of terms whose names match the given queries.
|
||||
SearchTerms :: Branch
|
||||
-> [String]
|
||||
-> Command i v [(Name, Referent, Maybe (Type v Ann))]
|
||||
-> Command i v [(HashQualified, Referent, Maybe (Type v Ann))]
|
||||
|
||||
-- Return a list of types whose names match the given queries.
|
||||
SearchTypes :: Branch
|
||||
-> [String]
|
||||
-> Command i v [(Name, Reference)] -- todo: can add Kind later
|
||||
-> Command i v [(HashQualified, Reference)] -- todo: can add Kind later
|
||||
|
||||
LoadTerm :: Reference.Id -> Command i v (Maybe (Term v Ann))
|
||||
|
||||
@ -397,11 +398,11 @@ outcomes okToUpdate b file = let
|
||||
_otherwise -> (r0, CouldntUpdateConflicted) -- come back to this
|
||||
|
||||
outcomes0terms = map termOutcome (Map.toList $ UF.hashTerms file)
|
||||
termOutcome (v, (r, _, _)) = outcome0 (Var.name v) (Right r) []
|
||||
termOutcome (v, (r, _, _)) = outcome0 (Name.unsafeFromVar v) (Right r) []
|
||||
outcomes0types
|
||||
= map typeOutcome (Map.toList . fmap (second Right) $ UF.dataDeclarations' file)
|
||||
++ map typeOutcome (Map.toList . fmap (second Left) $ UF.effectDeclarations' file)
|
||||
typeOutcome (v, (r, dd)) = outcome0 (Var.name v) (Left r) $ ctorNames v r dd
|
||||
typeOutcome (v, (r, dd)) = outcome0 (Name.unsafeFromVar v) (Left r) $ ctorNames v r dd
|
||||
ctorNames v r (Left e) = Map.keys $ Names.termNames (DD.effectDeclToNames v r e)
|
||||
ctorNames v r (Right dd) = Map.keys $ Names.termNames (DD.dataDeclToNames v r dd)
|
||||
outcomes0 = outcomes0terms ++ outcomes0types
|
||||
@ -487,14 +488,15 @@ fileToBranch handleCollisions codebase branch uf = do
|
||||
, Branch.fromDeclaration v r dd <> b )
|
||||
Right r ->
|
||||
( result { adds = adds result <> SlurpComponent mempty (Set.singleton v) }
|
||||
, Branch.addTermName (Referent.Ref r) (Var.name v) b )
|
||||
, Branch.addTermName (Referent.Ref r) (Name.unsafeFromVar v) b )
|
||||
Updated -> do
|
||||
let result' = result { updates = updates result <> sc r v }
|
||||
name = Name.unsafeFromVar v
|
||||
case r of
|
||||
Left (r', dd) -> case toList (Branch.typesNamed (Var.name v) b0) of
|
||||
Left (r', dd) -> case toList (Branch.typesNamed name b0) of
|
||||
[r0] -> pure (result', Branch.fromDeclaration v r' dd <> Branch.replaceType r0 r' b)
|
||||
_ -> error "Panic. Tried to replace a type that's conflicted."
|
||||
Right r' -> case toList (Branch.termsNamed (Var.name v) b0) of
|
||||
Right r' -> case toList (Branch.termsNamed name b0) of
|
||||
[Referent.Ref r0] -> do
|
||||
Just type1 <- Codebase.getTypeOfTerm codebase r0
|
||||
let Just (_, _, type2) = Map.lookup r' termsByRef
|
||||
@ -502,7 +504,7 @@ fileToBranch handleCollisions codebase branch uf = do
|
||||
if Typechecker.isEqual type1 type2 then TermEdit.Same
|
||||
else if Typechecker.isSubtype type2 type1 then TermEdit.Subtype
|
||||
else TermEdit.Different
|
||||
pure (result', Branch.addTermName (Referent.Ref r') (Var.name v) $
|
||||
pure (result', Branch.addTermName (Referent.Ref r') name $
|
||||
Branch.replaceTerm r0 r' typing b)
|
||||
_ -> error $ "Panic. Tried to replace a term that's conflicted." ++ show v
|
||||
AlreadyExists -> pure (result { duplicates = duplicates result <> sc r v }, b)
|
||||
@ -510,15 +512,16 @@ fileToBranch handleCollisions codebase branch uf = do
|
||||
CouldntUpdateConflicted ->
|
||||
pure (result { conflicts = conflicts result <> sc r v }, b)
|
||||
RequiresAlias ns -> let
|
||||
name = Name.unsafeFromVar v
|
||||
rcs = case r of
|
||||
Left _ -> Branch.RefCollisions mempty (R.fromList $ (Var.name v,) <$> ns)
|
||||
Right _ -> Branch.RefCollisions (R.fromList $ (Var.name v,) <$> ns) mempty
|
||||
Left _ -> Branch.RefCollisions mempty (R.fromList $ (name,) <$> ns)
|
||||
Right _ -> Branch.RefCollisions (R.fromList $ (name,) <$> ns) mempty
|
||||
in pure (result { needsAlias = needsAlias result <> rcs }, b)
|
||||
TermExistingConstructorCollision ->
|
||||
pure (result {
|
||||
termExistingConstructorCollisions =
|
||||
termExistingConstructorCollisions result <>
|
||||
pick (toList $ Branch.constructorsNamed (Var.name v) b0) }, b)
|
||||
pick (toList $ Branch.constructorsNamed (Name.unsafeFromVar v) b0) }, b)
|
||||
where
|
||||
pick [] = error "Panic. Incorrectly determined a conflict."
|
||||
pick (h:_) = Map.fromList [(v, h)]
|
||||
@ -649,7 +652,7 @@ doTodo code b = do
|
||||
f <- Codebase.frontier code b
|
||||
let dirty = R.dom f
|
||||
frontier = R.ran f
|
||||
ppe = Branch.prettyPrintEnv1 b
|
||||
ppe = Branch.prettyPrintEnv b
|
||||
(frontierTerms, frontierTypes) <- loadDefinitions code frontier
|
||||
(dirtyTerms, dirtyTypes) <- loadDefinitions code dirty
|
||||
-- todo: something more intelligent here?
|
||||
@ -688,4 +691,3 @@ loadDefinitions code refs = do
|
||||
Just d -> pure (r, RegularThing d)
|
||||
_ -> error $ "unpossible " ++ show r
|
||||
pure (terms, types)
|
||||
|
||||
|
||||
@ -49,9 +49,8 @@ import Unison.Codebase.Editor ( Command(..)
|
||||
, collateReferences
|
||||
)
|
||||
import qualified Unison.Codebase.Editor as Editor
|
||||
import Unison.Names ( Name
|
||||
, NameTarget
|
||||
)
|
||||
import Unison.Name ( Name )
|
||||
import Unison.Names ( NameTarget )
|
||||
import qualified Unison.Names as Names
|
||||
import Unison.Parser ( Ann )
|
||||
import qualified Unison.PrettyPrintEnv as PPE
|
||||
@ -181,7 +180,7 @@ loop s = Free.unfold' (evalStateT (maybe (Left ()) Right <$> runMaybeT (go *> ge
|
||||
PPE.fromTermNames [ (r, n) | (n, r, _) <- terms ]
|
||||
`PPE.unionLeft` PPE.fromTypeNames (swap <$> types)
|
||||
`PPE.unionLeft` Branch.prettyPrintEnv
|
||||
[Branch.head $ currentBranch']
|
||||
(Branch.head currentBranch')
|
||||
loc = case outputLoc of
|
||||
Editor.ConsoleLocation -> Nothing
|
||||
Editor.FileLocation path -> Just path
|
||||
@ -411,4 +410,3 @@ updateBranch
|
||||
:: Action i v () -> BranchName -> (Branch -> Branch) -> Action i v ()
|
||||
updateBranch success branchName f =
|
||||
withBranch branchName $ \b -> merging branchName (f b) success
|
||||
|
||||
|
||||
@ -2,6 +2,7 @@
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
|
||||
module Unison.Codebase.FileCodebase where
|
||||
|
||||
@ -50,10 +51,12 @@ import Text.Read ( readMaybe )
|
||||
import qualified Unison.Builtin as Builtin
|
||||
import Unison.Codebase ( Codebase(Codebase)
|
||||
, Err(InvalidBranchFile)
|
||||
, BranchName
|
||||
)
|
||||
import Unison.Codebase.Branch ( Branch )
|
||||
import qualified Unison.Codebase.Branch as Branch
|
||||
import Unison.Names ( Name )
|
||||
import qualified Unison.Name as Name
|
||||
import Unison.Name ( Name )
|
||||
import qualified Unison.Codebase.Serialization as S
|
||||
import qualified Unison.Codebase.Serialization.V0
|
||||
as V0
|
||||
@ -130,17 +133,19 @@ termDir, declDir:: FilePath -> Reference.Id -> FilePath
|
||||
termDir path r = path </> "terms" </> componentId r
|
||||
declDir path r = path </> "types" </> componentId r
|
||||
|
||||
encodeName :: Name -> FilePath
|
||||
encodeName = Hash.base58s . Hash.fromBytes . encodeUtf8
|
||||
encodeBuiltinName :: Name -> FilePath
|
||||
encodeBuiltinName = Hash.base58s . Hash.fromBytes . encodeUtf8 . Name.toText
|
||||
|
||||
decodeName :: FilePath -> Maybe Name
|
||||
decodeName p = decodeUtf8 . Hash.toBytes <$> Hash.fromBase58 (Text.pack p)
|
||||
decodeBuiltinName :: FilePath -> Maybe Name
|
||||
decodeBuiltinName p =
|
||||
Name.unsafeFromText . decodeUtf8 . Hash.toBytes <$>
|
||||
Hash.fromBase58 (Text.pack p)
|
||||
|
||||
builtinTermDir, builtinTypeDir :: FilePath -> Name -> FilePath
|
||||
builtinTermDir path name =
|
||||
path </> "terms" </> "_builtin" </> encodeName name
|
||||
path </> "terms" </> "_builtin" </> encodeBuiltinName name
|
||||
builtinTypeDir path name =
|
||||
path </> "types" </> "_builtin" </> encodeName name
|
||||
path </> "types" </> "_builtin" </> encodeBuiltinName name
|
||||
|
||||
termPath, typePath, declPath :: FilePath -> Reference.Id -> FilePath
|
||||
termPath path r = termDir path r </> "compiled.ub"
|
||||
@ -220,7 +225,7 @@ codebase1 builtinTypeAnnotation (S.Format getV putV) (S.Format getA putA) path
|
||||
|
||||
-- delete any leftover branch files "before" this one,
|
||||
-- and write this one if it doesn't already exist.
|
||||
overwriteBranch :: Name -> Branch -> IO ()
|
||||
overwriteBranch :: BranchName -> Branch -> IO ()
|
||||
overwriteBranch name branch = do
|
||||
let newBranchHash = Hash.base58s . Branch.toHash $ branch
|
||||
(match, nonmatch) <-
|
||||
@ -256,7 +261,7 @@ codebase1 builtinTypeAnnotation (S.Format getV putV) (S.Format getA putA) path
|
||||
else pure Set.empty
|
||||
where
|
||||
dir = case r of
|
||||
Reference.Builtin name ->
|
||||
Reference.Builtin (Name.unsafeFromText -> name) ->
|
||||
pure $ (if Builtin.isBuiltinTerm name
|
||||
then builtinTermDir
|
||||
else builtinTypeDir
|
||||
@ -268,7 +273,7 @@ codebase1 builtinTypeAnnotation (S.Format getV putV) (S.Format getA putA) path
|
||||
pure $ (if b then termDir else declDir) path id
|
||||
_ -> error "impossible: these patterns should be enough"
|
||||
|
||||
branchUpdates :: IO (IO (), IO (Set Name))
|
||||
branchUpdates :: IO (IO (), IO (Set BranchName))
|
||||
branchUpdates = do
|
||||
branchFileChanges <- TQueue.newIO
|
||||
(cancelWatch, watcher) <- Watch.watchDirectory' (branchesPath path)
|
||||
@ -300,5 +305,5 @@ codebase1 builtinTypeAnnotation (S.Format getV putV) (S.Format getA putA) path
|
||||
dependents
|
||||
builtinTypeAnnotation
|
||||
|
||||
ubfPathToName :: FilePath -> Name
|
||||
ubfPathToName :: FilePath -> BranchName
|
||||
ubfPathToName = Text.pack . takeFileName . takeDirectory
|
||||
|
||||
@ -52,6 +52,8 @@ import qualified Unison.Codebase.TypeEdit as TypeEdit
|
||||
import qualified Unison.Codebase.Serialization as S
|
||||
import qualified Unison.Hash as Hash
|
||||
import qualified Unison.Kind as Kind
|
||||
import Unison.Name (Name)
|
||||
import qualified Unison.Name as Name
|
||||
import qualified Unison.Reference as Reference
|
||||
import Unison.Referent (Referent)
|
||||
import qualified Unison.Referent as Referent
|
||||
@ -487,18 +489,24 @@ getTypeEdit = getWord8 >>= \case
|
||||
|
||||
putBranch :: MonadPut m => Branch -> m ()
|
||||
putBranch (Branch b) = putCausal b $ \b -> do
|
||||
putRelation (Branch.termNamespace b) putText putReferent
|
||||
putRelation (Branch.typeNamespace b) putText putReference
|
||||
putRelation (Branch.oldTermNamespace b) putText putReferent
|
||||
putRelation (Branch.oldTypeNamespace b) putText putReference
|
||||
putRelation (Branch.termNamespace b) putName putReferent
|
||||
putRelation (Branch.typeNamespace b) putName putReference
|
||||
putRelation (Branch.oldTermNamespace b) putName putReferent
|
||||
putRelation (Branch.oldTypeNamespace b) putName putReference
|
||||
putRelation (Branch.editedTerms b) putReference putTermEdit
|
||||
putRelation (Branch.editedTypes b) putReference putTypeEdit
|
||||
|
||||
putName :: MonadPut m => Name -> m ()
|
||||
putName = putText . Name.toText
|
||||
|
||||
getName :: MonadGet m => m Name
|
||||
getName = Name.unsafeFromText <$> getText
|
||||
|
||||
getNamespace :: MonadGet m => m Branch.Namespace
|
||||
getNamespace =
|
||||
Branch.Namespace
|
||||
<$> getRelation getText getReferent
|
||||
<*> getRelation getText getReference
|
||||
<$> getRelation getName getReferent
|
||||
<*> getRelation getName getReference
|
||||
|
||||
getBranch :: MonadGet m => m Branch
|
||||
getBranch = Branch <$> getCausal
|
||||
|
||||
@ -19,6 +19,7 @@ import Prelude.Extras (Show1)
|
||||
import qualified Unison.ABT as ABT
|
||||
import Unison.Hashable (Accumulate, Hashable1)
|
||||
import qualified Unison.Hashable as Hashable
|
||||
import qualified Unison.Name as Name
|
||||
import Unison.Reference (Reference)
|
||||
import qualified Unison.Reference as Reference
|
||||
import Unison.Referent (Referent)
|
||||
@ -114,7 +115,7 @@ toNames0
|
||||
-> Names
|
||||
toNames0 typeSymbol r f dd =
|
||||
let names (ctor, i) =
|
||||
let name = Var.qualifiedName ctor in Names.fromTerms [(name, f r i)]
|
||||
let name = Name.unsafeFromVar ctor in Names.fromTerms [(name, f r i)]
|
||||
in foldMap names (constructorVars dd `zip` [0 ..])
|
||||
<> Names.fromTypesV [(typeSymbol, r)]
|
||||
|
||||
@ -258,4 +259,3 @@ bindDecls decls refs = sortCtors . bindBuiltins refs <$> decls
|
||||
sortCtors dd =
|
||||
DataDeclaration (annotation dd) (bound dd) (sortOn hash3 $ constructors' dd)
|
||||
hash3 (_, _, typ) = ABT.hash typ :: Hash
|
||||
|
||||
|
||||
@ -23,7 +23,8 @@ import qualified Unison.Blank as Blank
|
||||
import qualified Unison.Codecs as Codecs
|
||||
import Unison.DataDeclaration (DataDeclaration',
|
||||
EffectDeclaration')
|
||||
import Unison.Names (Name, Names)
|
||||
import qualified Unison.Name as Name
|
||||
import Unison.Names (Names)
|
||||
import qualified Unison.Names as Names
|
||||
import Unison.Parser (Ann (Intrinsic))
|
||||
import qualified Unison.Parsers as Parsers
|
||||
@ -50,6 +51,7 @@ type EffectDeclaration v = EffectDeclaration' v Ann
|
||||
type UnisonFile v = UF.UnisonFile v Ann
|
||||
type NamedReference v = Typechecker.NamedReference v Ann
|
||||
type Result' v = Result (Seq (Note v Ann))
|
||||
type Name = Text
|
||||
|
||||
-- move to Unison.Util.List
|
||||
-- prefers earlier copies
|
||||
@ -117,9 +119,10 @@ synthesizeFile preexistingTypes preexistingNames unisonFile = do
|
||||
where
|
||||
fqnsByShortName :: Map Name [Typechecker.NamedReference v Ann]
|
||||
fqnsByShortName = Map.fromListWith mappend
|
||||
[ (Names.unqualified name,
|
||||
[ (Names.unqualified' name,
|
||||
[Typechecker.NamedReference name typ (Right r)]) |
|
||||
(name, r) <- Map.toList $ Names.termNames allTheNames,
|
||||
(name', r) <- Map.toList $ Names.termNames allTheNames,
|
||||
let name = Name.toText name',
|
||||
typ <- Foldable.toList $ TL.typeOfReferent lookupTypes r ]
|
||||
Result notes mayType =
|
||||
evalStateT (Typechecker.synthesizeAndResolve env0) tdnrTerm
|
||||
|
||||
81
parser-typechecker/src/Unison/HashQualified.hs
Normal file
81
parser-typechecker/src/Unison/HashQualified.hs
Normal file
@ -0,0 +1,81 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Unison.HashQualified where
|
||||
|
||||
import Data.String (IsString, fromString)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import Unison.Name (Name)
|
||||
import qualified Unison.Name as Name
|
||||
import Unison.Reference (Reference)
|
||||
import qualified Unison.Reference as Reference
|
||||
import Unison.Referent (Referent)
|
||||
import qualified Unison.Referent as Referent
|
||||
import Unison.Var (Var)
|
||||
import qualified Unison.Var as Var
|
||||
|
||||
data HashQualified
|
||||
-- todo: Let HashOnly take Reference instead of Text?
|
||||
-- This requires being able to parse a Reference in
|
||||
= NameOnly Name | HashOnly Referent | HashQualified Name Text
|
||||
deriving (Eq, Ord)
|
||||
|
||||
toName :: HashQualified -> Maybe Name
|
||||
toName = \case
|
||||
NameOnly name -> Just name
|
||||
HashQualified name _ -> Just name
|
||||
HashOnly _ -> Nothing
|
||||
|
||||
hashSeparator :: Text
|
||||
hashSeparator = "#"
|
||||
|
||||
toString :: HashQualified -> String
|
||||
toString = Text.unpack . toText
|
||||
|
||||
fromString :: String -> HashQualified
|
||||
fromString = fromText . Text.pack
|
||||
|
||||
-- parses possibly-hash-qualified into structured type
|
||||
fromText :: Text -> HashQualified
|
||||
fromText t =
|
||||
case Text.breakOn hashSeparator t of
|
||||
("", "") -> error "don't give me that"
|
||||
(name, "") -> NameOnly (Name.unsafeFromText name)
|
||||
("", hash) -> HashOnly (Referent.unsafeFromText hash)
|
||||
(name, hash) -> HashQualified (Name.unsafeFromText name) hash
|
||||
|
||||
toText :: HashQualified -> Text
|
||||
toText = \case
|
||||
NameOnly name -> Name.toText name
|
||||
HashQualified name hash -> Name.toText name <> hash
|
||||
HashOnly ref -> Text.pack (show ref)
|
||||
|
||||
forReferent :: Referent -> Int -> Name -> HashQualified
|
||||
forReferent r len n =
|
||||
HashQualified n . Text.pack $ Referent.showShort len r
|
||||
|
||||
forReference :: Reference -> Int -> Name -> HashQualified
|
||||
forReference r len n =
|
||||
HashQualified n . Text.pack $ Reference.showShort len r
|
||||
|
||||
fromReferent :: Referent -> HashQualified
|
||||
fromReferent = HashOnly
|
||||
|
||||
fromReference :: Reference -> HashQualified
|
||||
fromReference = HashOnly . Referent.Ref
|
||||
|
||||
fromName :: Name -> HashQualified
|
||||
fromName n = NameOnly n
|
||||
|
||||
fromVar :: Var v => v -> HashQualified
|
||||
fromVar = fromText . Var.name
|
||||
|
||||
toVar :: Var v => HashQualified -> v
|
||||
toVar = Var.named . toText
|
||||
|
||||
instance IsString HashQualified where
|
||||
fromString = fromText . Text.pack
|
||||
|
||||
instance Show HashQualified where
|
||||
show = Text.unpack . toText
|
||||
33
parser-typechecker/src/Unison/Name.hs
Normal file
33
parser-typechecker/src/Unison/Name.hs
Normal file
@ -0,0 +1,33 @@
|
||||
module Unison.Name (Name(..), unsafeFromText, toString, fromString, toVar, unsafeFromVar) where
|
||||
|
||||
import Data.String (IsString, fromString)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import qualified Unison.Hashable as H
|
||||
import Unison.Var (Var)
|
||||
import qualified Unison.Var as Var
|
||||
|
||||
newtype Name = Name { toText :: Text } deriving (Eq, Ord)
|
||||
|
||||
unsafeFromText :: Text -> Name
|
||||
unsafeFromText t =
|
||||
if Text.any (=='#') t then error $ "not a name: " <> show t
|
||||
else Name t
|
||||
|
||||
toVar :: Var v => Name -> v
|
||||
toVar (Name t) = Var.named t
|
||||
|
||||
unsafeFromVar :: Var v => v -> Name
|
||||
unsafeFromVar = unsafeFromText . Var.name
|
||||
|
||||
toString :: Name -> String
|
||||
toString = Text.unpack . toText
|
||||
|
||||
instance Show Name where
|
||||
show = toString
|
||||
|
||||
instance IsString Name where
|
||||
fromString = unsafeFromText . Text.pack
|
||||
|
||||
instance H.Hashable Name where
|
||||
tokens s = [H.Text (toText s)]
|
||||
25
parser-typechecker/src/Unison/NamePrinter.hs
Normal file
25
parser-typechecker/src/Unison/NamePrinter.hs
Normal file
@ -0,0 +1,25 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
|
||||
module Unison.NamePrinter where
|
||||
|
||||
import Data.String (IsString, fromString)
|
||||
import Unison.HashQualified (HashQualified)
|
||||
import qualified Unison.HashQualified as HQ
|
||||
import Unison.Name (Name)
|
||||
import qualified Unison.Name as Name
|
||||
import qualified Unison.Referent as Referent
|
||||
import Unison.Util.Pretty (Pretty)
|
||||
import qualified Unison.Util.Pretty as PP
|
||||
|
||||
prettyName :: IsString s => Name -> Pretty s
|
||||
prettyName = PP.text . Name.toText
|
||||
|
||||
prettyHashQualified :: IsString s => HashQualified -> Pretty s
|
||||
prettyHashQualified = PP.text . HQ.toText
|
||||
|
||||
styleHashQualified ::
|
||||
IsString s => (Pretty s -> Pretty s) -> HashQualified -> Pretty s
|
||||
styleHashQualified style = \case
|
||||
HQ.NameOnly n -> style (prettyName n)
|
||||
HQ.HashOnly r -> fromString . Referent.toString $ r
|
||||
HQ.HashQualified n h -> PP.group $ style (prettyName n) <> PP.text h
|
||||
@ -10,9 +10,12 @@ import Data.Bifunctor (first)
|
||||
import Data.List (foldl')
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as Map
|
||||
import Data.String (fromString)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import Unison.Reference (pattern Builtin, Reference)
|
||||
import qualified Unison.Name as Name
|
||||
import Unison.Name (Name)
|
||||
import qualified Unison.Referent as Referent
|
||||
import Unison.Referent (Referent)
|
||||
import Unison.Term (AnnotatedTerm)
|
||||
@ -20,12 +23,12 @@ import qualified Unison.Term as Term
|
||||
import Unison.Type (AnnotatedType)
|
||||
import qualified Unison.Type as Type
|
||||
import Unison.Var (Var)
|
||||
import qualified Unison.Var as Var
|
||||
|
||||
type Name = Text
|
||||
|
||||
unqualified :: Name -> Name
|
||||
unqualified = last . Text.splitOn "."
|
||||
unqualified = Name.unsafeFromText . unqualified' . Name.toText
|
||||
|
||||
unqualified' :: Text -> Text
|
||||
unqualified' = last . Text.splitOn "."
|
||||
|
||||
data Names = Names
|
||||
{ termNames :: Map Name Referent
|
||||
@ -54,14 +57,15 @@ lookupType ns n = Map.lookup n (typeNames ns)
|
||||
|
||||
fromBuiltins :: [Reference] -> Names
|
||||
fromBuiltins rs =
|
||||
mempty { termNames = Map.fromList [ (name, Referent.Ref r) | r@(Builtin name) <- rs ] }
|
||||
mempty { termNames = Map.fromList
|
||||
[ (Name.unsafeFromText t, Referent.Ref r) | r@(Builtin t) <- rs ] }
|
||||
|
||||
fromTerms :: [(Name, Referent)] -> Names
|
||||
fromTerms ts = mempty { termNames = Map.fromList ts }
|
||||
|
||||
fromTypesV :: Var v => [(v, Reference)] -> Names
|
||||
fromTypesV env =
|
||||
Names mempty . Map.fromList $ fmap (first $ Var.name) env
|
||||
Names mempty . Map.fromList $ fmap (first $ Name.unsafeFromVar) env
|
||||
|
||||
fromTypes :: [(Name, Reference)] -> Names
|
||||
fromTypes env = Names mempty $ Map.fromList env
|
||||
@ -72,7 +76,7 @@ filterTypes f (Names {..}) = Names termNames m2
|
||||
m2 = Map.fromList $ [(k,v) | (k,v) <- Map.toList typeNames, f k]
|
||||
|
||||
patternNameds :: Names -> String -> Maybe (Reference, Int)
|
||||
patternNameds ns s = patternNamed ns (Text.pack s)
|
||||
patternNameds ns s = patternNamed ns (fromString s)
|
||||
|
||||
patternNamed :: Names -> Name -> Maybe (Reference, Int)
|
||||
patternNamed ns n = Map.lookup n (termNames ns) >>= \case
|
||||
@ -83,16 +87,16 @@ patternNamed ns n = Map.lookup n (termNames ns) >>= \case
|
||||
bindType :: Var v => Names -> AnnotatedType v a -> AnnotatedType v a
|
||||
bindType ns t = Type.bindBuiltins typeNames' t
|
||||
where
|
||||
typeNames' = [ (Var.named v, r) | (v, r) <- Map.toList $ typeNames ns ]
|
||||
typeNames' = [ (Name.toVar v, r) | (v, r) <- Map.toList $ typeNames ns ]
|
||||
|
||||
bindTerm
|
||||
:: forall v a . Var v => Names -> AnnotatedTerm v a -> AnnotatedTerm v a
|
||||
bindTerm ns e = Term.bindBuiltins termBuiltins typeBuiltins e
|
||||
where
|
||||
termBuiltins =
|
||||
[ (Var.named v, Term.fromReferent() e) | (v, e) <- Map.toList (termNames ns) ]
|
||||
[ (Name.toVar v, Term.fromReferent() e) | (v, e) <- Map.toList (termNames ns) ]
|
||||
typeBuiltins :: [(v, Reference)]
|
||||
typeBuiltins = [ (Var.named v, t) | (v, t) <- Map.toList (typeNames ns) ]
|
||||
typeBuiltins = [ (Name.toVar v, t) | (v, t) <- Map.toList (typeNames ns) ]
|
||||
|
||||
-- Given a mapping from name to qualified name, update a `PEnv`,
|
||||
-- so for instance if the input has [(Some, Optional.Some)],
|
||||
@ -105,7 +109,7 @@ importing shortToLongName0 (Names {..}) = let
|
||||
Nothing -> m
|
||||
Just v -> Map.insert shortname v m
|
||||
shortToLongName = [
|
||||
(Var.name v, Var.name v2) | (v,v2) <- shortToLongName0 ]
|
||||
(Name.unsafeFromVar v, Name.unsafeFromVar v2) | (v,v2) <- shortToLongName0 ]
|
||||
terms' = foldl' go termNames shortToLongName
|
||||
types' = foldl' go typeNames shortToLongName
|
||||
in Names terms' types'
|
||||
|
||||
@ -2,24 +2,22 @@
|
||||
|
||||
module Unison.PrettyPrintEnv where
|
||||
|
||||
import Data.List (foldl')
|
||||
import Data.Map (Map)
|
||||
import Control.Applicative ((<|>))
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Unison.Reference (Reference)
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Text as Text
|
||||
import Unison.Names (Name,Names)
|
||||
import Unison.HashQualified (HashQualified)
|
||||
import qualified Unison.HashQualified as HQ
|
||||
import Unison.Names (Names)
|
||||
import qualified Unison.Names as Names
|
||||
import Unison.Referent (Referent)
|
||||
import qualified Unison.Referent as Referent
|
||||
|
||||
type Histogram = Map Name Word
|
||||
|
||||
-- Maps terms, types, constructors and constructor patterns to a histogram of names.
|
||||
data PrettyPrintEnv = PrettyPrintEnv {
|
||||
-- names for terms, constructors, and requests
|
||||
terms :: Referent -> Histogram,
|
||||
terms :: Referent -> Maybe HashQualified,
|
||||
-- names for types
|
||||
types :: Reference -> Histogram }
|
||||
types :: Reference -> Maybe HashQualified }
|
||||
|
||||
instance Show PrettyPrintEnv where
|
||||
show _ = "PrettyPrintEnv"
|
||||
@ -27,114 +25,39 @@ instance Show PrettyPrintEnv where
|
||||
fromNames :: Names -> PrettyPrintEnv
|
||||
fromNames ns =
|
||||
let terms =
|
||||
Map.fromList [ (r, n) | (n, r) <- Map.toList (Names.termNames ns) ]
|
||||
Map.fromList [ (r, HQ.fromName n) | (n, r) <- 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) (hist types)
|
||||
|
||||
-- The monoid sums corresponding histograms
|
||||
|
||||
instance Semigroup PrettyPrintEnv where (<>) = mappend
|
||||
|
||||
instance Monoid PrettyPrintEnv where
|
||||
mempty = PrettyPrintEnv (const mempty) (const mempty)
|
||||
mappend e1 e2 =
|
||||
PrettyPrintEnv
|
||||
(\r -> Map.unionWith (+) (terms e1 r) (terms e2 r))
|
||||
(\r -> Map.unionWith (+) (types e1 r) (types e2 r))
|
||||
Map.fromList [ (r, HQ.fromName n) | (n, r) <- Map.toList (Names.typeNames ns) ]
|
||||
in PrettyPrintEnv (`Map.lookup` terms) (`Map.lookup` types)
|
||||
|
||||
-- Left-biased union of environments
|
||||
unionLeft :: PrettyPrintEnv -> PrettyPrintEnv -> PrettyPrintEnv
|
||||
unionLeft e1 e2 = PrettyPrintEnv
|
||||
(\r -> prefer (terms e1 r) (terms e2 r))
|
||||
(\r -> prefer (types e1 r) (types e2 r))
|
||||
where prefer h1 h2 = if sum (Map.elems h1) > 0 then h1 else h2
|
||||
(\r -> terms e1 r <|> terms e2 r)
|
||||
(\r -> types e1 r <|> types e2 r)
|
||||
|
||||
adjust :: (Word -> Word) -> PrettyPrintEnv -> PrettyPrintEnv
|
||||
adjust by e = PrettyPrintEnv
|
||||
(\r -> by <$> terms e r)
|
||||
(\r -> by <$> types e r)
|
||||
assignTermName :: Referent -> HashQualified -> PrettyPrintEnv -> PrettyPrintEnv
|
||||
assignTermName r name = (fromTermNames [(r,name)] `unionLeft`)
|
||||
|
||||
scale :: Word -> PrettyPrintEnv -> PrettyPrintEnv
|
||||
scale by = adjust (by *)
|
||||
|
||||
incrementBy :: Word -> PrettyPrintEnv -> PrettyPrintEnv
|
||||
incrementBy by = adjust (by +)
|
||||
|
||||
weightedSum :: [(Word,PrettyPrintEnv)] -> PrettyPrintEnv
|
||||
weightedSum envs = mconcat (uncurry scale <$> envs)
|
||||
|
||||
fromTypeNames :: [(Reference,Name)] -> PrettyPrintEnv
|
||||
fromTypeNames :: [(Reference,HashQualified)] -> PrettyPrintEnv
|
||||
fromTypeNames types = let
|
||||
m = Map.fromList types
|
||||
toH Nothing = mempty
|
||||
toH (Just t) = Map.fromList [(t, 1)]
|
||||
in mempty { types = \r -> toH $ Map.lookup r m }
|
||||
in PrettyPrintEnv (const Nothing) (`Map.lookup` m)
|
||||
|
||||
fromTermNames :: [(Referent,Name)] -> PrettyPrintEnv
|
||||
fromTermNames :: [(Referent,HashQualified)] -> 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 }
|
||||
in PrettyPrintEnv (`Map.lookup` m) (const Nothing)
|
||||
|
||||
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 { terms = \r -> case r of
|
||||
Referent.Con r i -> toH $ Map.lookup (r,i) cs
|
||||
Referent.Req r i -> toH $ Map.lookup (r,i) rs
|
||||
_ -> mempty }
|
||||
termName :: PrettyPrintEnv -> Referent -> HashQualified
|
||||
termName env r = fromMaybe (HQ.fromReferent r) (terms env r)
|
||||
|
||||
-- These functions pick out the most common name and fall back
|
||||
-- to showing the `Reference` if no names are available
|
||||
typeName :: PrettyPrintEnv -> Reference -> HashQualified
|
||||
typeName env r = fromMaybe (HQ.fromReferent (Referent.Ref r)) (types 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)
|
||||
|
||||
constructorName :: PrettyPrintEnv -> Reference -> Int -> Name
|
||||
constructorName env r cid = pickNameCid r cid (terms env (Referent.Con r cid))
|
||||
|
||||
requestName :: PrettyPrintEnv -> Reference -> Int -> Name
|
||||
requestName env r cid = pickNameCid r cid (terms env (Referent.Req r cid))
|
||||
|
||||
patternName :: PrettyPrintEnv -> Reference -> Int -> Name
|
||||
patternName env r cid = pickNameCid r cid histo
|
||||
where
|
||||
histo = Map.unionWith (+)
|
||||
(terms env (Referent.Con r cid))
|
||||
(terms env (Referent.Req 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 -> case r of
|
||||
Referent.Ref r -> Text.pack (show r)
|
||||
Referent.Con r i -> Text.pack (show r <> "#" <> show i)
|
||||
Referent.Req r i -> Text.pack (show r <> "#" <> show i)
|
||||
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)
|
||||
Just (name,_) -> name
|
||||
|
||||
-- this fn should really exist someplace else
|
||||
argmax :: (Foldable f, Ord b) => (a -> b) -> f a -> Maybe a
|
||||
argmax by as = fst <$> foldl' go Nothing as where
|
||||
go Nothing a = Just (a, by a)
|
||||
go cur@(Just (_,b)) a2 =
|
||||
let b2 = by a2
|
||||
in if b2 > b then Just (a2,b2) else cur
|
||||
patternName :: PrettyPrintEnv -> Reference -> Int -> HashQualified
|
||||
patternName env r cid = fromMaybe (HQ.fromReferent (Referent.Con r cid)) $
|
||||
terms env (Referent.Con r cid) <|> terms env (Referent.Req r cid)
|
||||
-- arbitrarily pick Con because it is only used to determine how to render
|
||||
-- the referent as text. We haven't chosen any rendering distinction between
|
||||
-- Req and Con.
|
||||
|
||||
@ -32,6 +32,7 @@ import Data.Void (Void)
|
||||
import qualified Text.Megaparsec as P
|
||||
import qualified Unison.ABT as ABT
|
||||
import qualified Unison.DataDeclaration as DD
|
||||
import qualified Unison.HashQualified as HQ
|
||||
import Unison.Kind (Kind)
|
||||
import qualified Unison.Kind as Kind
|
||||
import qualified Unison.Lexer as L
|
||||
@ -702,7 +703,7 @@ renderTerm :: (IsString s, Var v) => Env -> C.Term v loc -> s
|
||||
renderTerm _ (ABT.Var' v) | Settings.demoHideVarNumber =
|
||||
fromString (Text.unpack $ Var.name v)
|
||||
renderTerm env (Term.Ref' r) =
|
||||
fromString (Text.unpack $ PPE.termName env (Referent.Ref r))
|
||||
fromString (HQ.toString $ PPE.termName env (Referent.Ref r))
|
||||
renderTerm _ e =
|
||||
let s = show e
|
||||
in -- todo: pretty print
|
||||
@ -783,14 +784,14 @@ renderKind Kind.Star = "*"
|
||||
renderKind (Kind.Arrow k1 k2) = renderKind k1 <> " -> " <> renderKind k2
|
||||
|
||||
showTermRef :: IsString s => Env -> Referent -> s
|
||||
showTermRef env r = fromString . Text.unpack $ PPE.termName env r
|
||||
showTermRef env r = fromString . HQ.toString $ PPE.termName env r
|
||||
|
||||
showTypeRef :: IsString s => Env -> R.Reference -> s
|
||||
showTypeRef env r = fromString . Text.unpack $ PPE.typeName env r
|
||||
showTypeRef env r = fromString . HQ.toString $ PPE.typeName env r
|
||||
|
||||
-- todo: do something different/better if cid not found
|
||||
showConstructor :: IsString s => Env -> R.Reference -> Int -> s
|
||||
showConstructor env r cid = fromString . Text.unpack $
|
||||
showConstructor env r cid = fromString . HQ.toString $
|
||||
PPE.patternName env r cid
|
||||
|
||||
styleInOverallType
|
||||
|
||||
@ -1,5 +1,7 @@
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
|
||||
|
||||
module Unison.Reference
|
||||
(Reference(DerivedPrivate_),
|
||||
@ -13,23 +15,24 @@ module Unison.Reference
|
||||
hashComponents,
|
||||
groupByComponent,
|
||||
componentFor,
|
||||
unsafeFromText,
|
||||
showShort) where
|
||||
|
||||
import GHC.Generics
|
||||
import Data.Maybe (fromJust)
|
||||
import Unison.Hashable as Hashable
|
||||
import qualified Data.Text as Text
|
||||
import qualified Unison.Hash as H
|
||||
import Data.Word (Word64)
|
||||
import Control.Monad (join)
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
import Data.Set (Set)
|
||||
import Data.List
|
||||
import Data.Foldable (toList)
|
||||
import Data.Text (Text)
|
||||
import qualified Unison.ABT as ABT
|
||||
import qualified Unison.Var as Var
|
||||
import Control.Monad (join)
|
||||
import Data.Foldable (toList)
|
||||
import Data.List
|
||||
import qualified Data.Map as Map
|
||||
import Data.Maybe (fromJust)
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as Set
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import Data.Word (Word64)
|
||||
import GHC.Generics
|
||||
import qualified Unison.ABT as ABT
|
||||
import qualified Unison.Hash as H
|
||||
import Unison.Hashable as Hashable
|
||||
import qualified Unison.Var as Var
|
||||
|
||||
data Reference
|
||||
= Builtin_ Text.Text
|
||||
@ -43,7 +46,7 @@ data Id = Id H.Hash Pos Size deriving (Eq,Ord,Generic)
|
||||
|
||||
instance Show Id where
|
||||
show (Id h 0 1) = show h
|
||||
show (Id h i _) = show h <> "-" <> show i
|
||||
show (Id h i n) = show h <> "-" <> show i <> "-" <> show n
|
||||
|
||||
pattern Builtin t = Builtin_ t
|
||||
pattern Derived h n i = DerivedPrivate_ (Id h n i)
|
||||
@ -67,6 +70,20 @@ derivedBase58 b58 i n = DerivedPrivate_ (Id (fromJust h) i n)
|
||||
where
|
||||
h = H.fromBase58 b58
|
||||
|
||||
-- Parses Asdf##Foo as Builtin Foo
|
||||
-- Parses Asdf#abc123-1-2 as Derived 'abc123' 1 2
|
||||
unsafeFromText :: Text -> Reference
|
||||
unsafeFromText t = case Text.split (=='#') t of
|
||||
[_, "", b] -> Builtin b
|
||||
[_, h] -> case Text.split (=='-') h of
|
||||
[hash] -> derivedBase58 hash 0 1
|
||||
[hash, pos, size] -> derivedBase58 hash (read . Text.unpack $ pos)
|
||||
(read . Text.unpack $ size)
|
||||
_ -> bail
|
||||
_ -> bail
|
||||
where bail = error . Text.unpack $ "couldn't parse a Reference from " <> t
|
||||
|
||||
|
||||
hashComponents ::
|
||||
(Functor f, Hashable1 f, Foldable f, Eq v, Var.Var v)
|
||||
=> (Reference -> ABT.Term f v ())
|
||||
@ -99,8 +116,8 @@ showShort _ (Builtin_ t) = "##" <> Text.unpack t
|
||||
showShort numHashChars (DerivedPrivate_ id) = "#" <> take numHashChars (show id)
|
||||
|
||||
instance Show Reference where
|
||||
show (Builtin_ t) = Text.unpack t
|
||||
show (DerivedPrivate_ id) = "#" <> show id
|
||||
show (Builtin_ t) = "##" <> Text.unpack t
|
||||
show (DerivedPrivate_ id) = "#" <> show id
|
||||
|
||||
instance Hashable.Hashable Reference where
|
||||
tokens (Builtin_ txt) = [Hashable.Tag 0, Hashable.Text txt]
|
||||
|
||||
@ -1,12 +1,16 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
|
||||
module Unison.Referent where
|
||||
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import Data.Word (Word64)
|
||||
import Unison.Hashable (Hashable)
|
||||
import qualified Unison.Hashable as H
|
||||
import Unison.Reference (Reference)
|
||||
import qualified Unison.Reference as R
|
||||
import Data.Word (Word64)
|
||||
|
||||
data Referent = Ref Reference | Req Reference Int | Con Reference Int
|
||||
deriving (Show, Ord, Eq)
|
||||
@ -16,14 +20,21 @@ data Referent = Ref Reference | Req Reference Int | Con Reference Int
|
||||
|
||||
showShort :: Int -> Referent -> String
|
||||
showShort numHashChars r = case r of
|
||||
Ref r -> R.showShort numHashChars r
|
||||
Ref r -> R.showShort numHashChars r
|
||||
Con r cid -> R.showShort numHashChars r <> "#" <> show cid
|
||||
Req r cid -> R.showShort numHashChars r <> "#" <> show cid
|
||||
|
||||
toString :: Referent -> String
|
||||
toString = \case
|
||||
Ref r -> show r
|
||||
Con r cid -> show r <> "#" <> show cid
|
||||
Req r cid -> show r <> "#" <> show cid
|
||||
|
||||
|
||||
isConstructor :: Referent -> Bool
|
||||
isConstructor (Con _ _) = True
|
||||
isConstructor (Req _ _) = True
|
||||
isConstructor _ = False
|
||||
isConstructor _ = False
|
||||
|
||||
toReference :: Referent -> Reference
|
||||
toReference = \case
|
||||
@ -37,6 +48,22 @@ toTypeReference = \case
|
||||
Con r _i -> Just r
|
||||
_ -> Nothing
|
||||
|
||||
-- Parses Asdf##Foo as Builtin Foo
|
||||
-- Parses Asdf#abc123-1-2 as Derived 'abc123' 1 2
|
||||
unsafeFromText :: Text -> Referent
|
||||
unsafeFromText t = case Text.split (=='#') t of
|
||||
[_, "", b] -> Ref $ R.Builtin b
|
||||
[_, h] -> Ref $ case Text.split (=='-') h of
|
||||
[hash] -> R.derivedBase58 hash 0 1
|
||||
[hash, pos, size] -> R.derivedBase58 hash (read . Text.unpack $ pos)
|
||||
(read . Text.unpack $ size)
|
||||
_ -> bail
|
||||
[_, _h, _cid] -> error . Text.unpack $
|
||||
"todo: how can we parse a Referent as Con vs Req? " <> t
|
||||
_ -> bail
|
||||
where bail = error . Text.unpack $ "couldn't parse a Referent from " <> t
|
||||
|
||||
|
||||
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)
|
||||
|
||||
@ -15,7 +15,7 @@ import Control.Monad.Writer ( WriterT(..)
|
||||
)
|
||||
import Data.Maybe
|
||||
import Data.Sequence ( Seq )
|
||||
import Unison.Names ( Name )
|
||||
import Unison.Name ( Name )
|
||||
import qualified Unison.Parser as Parser
|
||||
import Unison.Paths ( Path )
|
||||
import Unison.Term ( AnnotatedTerm )
|
||||
|
||||
@ -6,7 +6,6 @@ module Unison.TermPrinter where
|
||||
|
||||
import Control.Monad (join)
|
||||
import Data.List
|
||||
import qualified Data.Text as Text
|
||||
import Data.Foldable ( fold
|
||||
)
|
||||
import Data.Maybe ( fromMaybe
|
||||
@ -16,7 +15,11 @@ import Data.Vector ( )
|
||||
import Text.Read ( readMaybe )
|
||||
import Unison.ABT ( pattern AbsN' )
|
||||
import qualified Unison.Blank as Blank
|
||||
import qualified Unison.HashQualified as HQ
|
||||
import Unison.Lexer ( symbolyId )
|
||||
import Unison.Name ( Name )
|
||||
import qualified Unison.Name as Name
|
||||
import Unison.NamePrinter ( prettyHashQualified )
|
||||
import Unison.PatternP ( Pattern )
|
||||
import qualified Unison.PatternP as Pattern
|
||||
import qualified Unison.Referent as Referent
|
||||
@ -121,9 +124,10 @@ pretty
|
||||
-> Pretty String
|
||||
pretty n AmbientContext { precedence = p, blockContext = bc, infixContext = ic } term
|
||||
= specialCases term $ \case
|
||||
Var' v -> parenIfInfix (Var.nameStr v) ic . PP.text $ Var.name v
|
||||
Ref' r -> parenIfInfix name ic $ l $ name
|
||||
where name = Text.unpack (PrettyPrintEnv.termName n (Referent.Ref r))
|
||||
Var' v -> parenIfInfix name ic . prettyHashQualified $ name
|
||||
where name = HQ.fromVar v
|
||||
Ref' r -> parenIfInfix name ic . prettyHashQualified $ name
|
||||
where name = PrettyPrintEnv.termName n (Referent.Ref r)
|
||||
Ann' tm t ->
|
||||
paren (p >= 0)
|
||||
$ pretty n (ac 10 Normal) tm
|
||||
@ -142,8 +146,9 @@ pretty n AmbientContext { precedence = p, blockContext = bc, infixContext = ic }
|
||||
Text' s -> l $ show s
|
||||
Blank' id -> l "_" <> (l $ fromMaybe "" (Blank.nameb id))
|
||||
Constructor' ref i ->
|
||||
l (Text.unpack (PrettyPrintEnv.constructorName n ref i))
|
||||
Request' ref i -> l (Text.unpack (PrettyPrintEnv.requestName n ref i))
|
||||
prettyHashQualified $ PrettyPrintEnv.termName n (Referent.Con ref i)
|
||||
Request' ref i ->
|
||||
prettyHashQualified $ PrettyPrintEnv.termName n (Referent.Req ref i)
|
||||
Handle' h body ->
|
||||
paren (p >= 2)
|
||||
$ ("handle" `PP.hang` pretty n (ac 2 Normal) h)
|
||||
@ -214,6 +219,7 @@ pretty n AmbientContext { precedence = p, blockContext = bc, infixContext = ic }
|
||||
varList vs = sepList' (PP.text . Var.name) PP.softbreak vs
|
||||
commaList = sepList ("," <> PP.softbreak)
|
||||
|
||||
printLet :: Var v => BlockContext -> [(v, AnnotatedTerm v a)] -> AnnotatedTerm v a -> Pretty String
|
||||
printLet sc bs e =
|
||||
paren ((sc /= Block) && p >= 12)
|
||||
$ letIntro
|
||||
@ -222,7 +228,7 @@ pretty n AmbientContext { precedence = p, blockContext = bc, infixContext = ic }
|
||||
where
|
||||
printBinding (v, binding) = if isBlank $ Var.nameStr v
|
||||
then pretty n (ac (-1) Normal) binding
|
||||
else prettyBinding n v binding
|
||||
else prettyBinding n (HQ.fromVar v) binding
|
||||
letIntro = case sc of
|
||||
Block -> id
|
||||
Normal -> \x -> "let" `PP.hang` x
|
||||
@ -246,7 +252,7 @@ pretty n AmbientContext { precedence = p, blockContext = bc, infixContext = ic }
|
||||
binaryOpsPred :: Var v => AnnotatedTerm v a -> Bool
|
||||
binaryOpsPred = \case
|
||||
Ref' r | isSymbolic (PrettyPrintEnv.termName n (Referent.Ref r)) -> True
|
||||
Var' v | isSymbolic (Var.name v) -> True
|
||||
Var' v | isSymbolic (HQ.fromVar v) -> True
|
||||
_ -> False
|
||||
|
||||
nonForcePred :: AnnotatedTerm v a -> Bool
|
||||
@ -308,11 +314,11 @@ prettyPattern n p vs patt = case patt of
|
||||
let (pats_printed, tail_vs) = patterns vs pats
|
||||
in (PP.parenthesizeCommas pats_printed, tail_vs)
|
||||
Pattern.Constructor _ ref i [] ->
|
||||
(PP.text (PrettyPrintEnv.patternName n ref i), vs)
|
||||
(prettyHashQualified (PrettyPrintEnv.patternName n ref i), vs)
|
||||
Pattern.Constructor _ ref i pats ->
|
||||
let (pats_printed, tail_vs) = patternsSep PP.softbreak vs pats
|
||||
in ( paren (p >= 10)
|
||||
$ PP.text (PrettyPrintEnv.patternName n ref i)
|
||||
$ prettyHashQualified (PrettyPrintEnv.patternName n ref i)
|
||||
`PP.hang` pats_printed
|
||||
, tail_vs)
|
||||
Pattern.As _ pat ->
|
||||
@ -325,7 +331,7 @@ prettyPattern n p vs patt = case patt of
|
||||
Pattern.EffectBind _ ref i pats k_pat ->
|
||||
let (pats_printed , tail_vs ) = patternsSep PP.softbreak vs pats
|
||||
(k_pat_printed, eventual_tail) = prettyPattern n 0 tail_vs k_pat
|
||||
in ("{" <> l (Text.unpack (PrettyPrintEnv.patternName n ref i))
|
||||
in ("{" <> prettyHashQualified (PrettyPrintEnv.patternName n ref i)
|
||||
<> (intercalateMap " " id [pats_printed, "->", k_pat_printed]) <>
|
||||
"}"
|
||||
, eventual_tail)
|
||||
@ -355,15 +361,15 @@ a + b = ...
|
||||
|
||||
-}
|
||||
prettyBinding
|
||||
:: Var v => PrettyPrintEnv -> v -> AnnotatedTerm v a -> Pretty String
|
||||
prettyBinding n v term = go (symbolic && isBinary term) term where
|
||||
:: Var v => PrettyPrintEnv -> HQ.HashQualified -> AnnotatedTerm v a -> Pretty String
|
||||
prettyBinding env v term = go (symbolic && isBinary term) term where
|
||||
go infix' = \case
|
||||
Ann' tm tp -> PP.lines [
|
||||
PP.group (renderName v <> PP.hang " :" (TypePrinter.pretty n (-1) tp)),
|
||||
PP.group (prettyBinding n v tm) ]
|
||||
PP.group (renderName v <> PP.hang " :" (TypePrinter.pretty env (-1) tp)),
|
||||
PP.group (prettyBinding env v tm) ]
|
||||
LamsNamedOpt' vs body -> PP.group $
|
||||
PP.group (defnLhs v vs <> " =") `PP.hang`
|
||||
pretty n (ac (-1) Block) body
|
||||
pretty env (ac (-1) Block) body
|
||||
where
|
||||
t -> l "error: " <> l (show t)
|
||||
where
|
||||
@ -371,21 +377,21 @@ prettyBinding n v term = go (symbolic && isBinary term) term where
|
||||
then case vs of
|
||||
x : y : _ ->
|
||||
PP.sep " " [PP.text (Var.name x),
|
||||
PP.text (Var.name v),
|
||||
prettyHashQualified v,
|
||||
PP.text (Var.name y)]
|
||||
_ -> l "error"
|
||||
else if null vs then renderName v
|
||||
else renderName v `PP.hang` args vs
|
||||
args vs = PP.spacedMap (PP.text . Var.name) vs
|
||||
renderName v = parenIfInfix (Var.nameStr v) NonInfix $ l (Var.nameStr v)
|
||||
symbolic = isSymbolic (Var.name v)
|
||||
renderName n = parenIfInfix n NonInfix $ prettyHashQualified n
|
||||
symbolic = isSymbolic v
|
||||
isBinary = \case
|
||||
Ann' tm _ -> isBinary tm
|
||||
LamsNamedOpt' vs _ -> length vs == 2
|
||||
_ -> False -- unhittable
|
||||
|
||||
prettyBinding'
|
||||
:: Var v => Int -> PrettyPrintEnv -> v -> AnnotatedTerm v a -> String
|
||||
:: Var v => Int -> PrettyPrintEnv -> HQ.HashQualified -> AnnotatedTerm v a -> String
|
||||
prettyBinding' width n v t = PP.render width $ prettyBinding n v t
|
||||
|
||||
paren :: Bool -> Pretty String -> Pretty String
|
||||
@ -393,9 +399,9 @@ paren True s = PP.group $ "(" <> s <> ")"
|
||||
paren False s = PP.group s
|
||||
|
||||
parenIfInfix
|
||||
:: String -> InfixContext -> Pretty String -> Pretty String
|
||||
:: HQ.HashQualified -> InfixContext -> Pretty String -> Pretty String
|
||||
parenIfInfix name ic =
|
||||
if isSymbolic (Text.pack name) && ic == NonInfix then paren True else id
|
||||
if isSymbolic name && ic == NonInfix then paren True else id
|
||||
|
||||
l :: String -> Pretty String
|
||||
l = PP.lit
|
||||
@ -406,8 +412,13 @@ l = PP.lit
|
||||
-- When we use imports in rendering, this will need revisiting, so that we can
|
||||
-- render say 'foo.+ x y' as 'import foo ... x + y'. symbolyId doesn't match
|
||||
-- 'foo.+', only '+'.
|
||||
isSymbolic :: Text.Text -> Bool
|
||||
isSymbolic name = case symbolyId $ Text.unpack $ name of
|
||||
isSymbolic :: HQ.HashQualified -> Bool
|
||||
isSymbolic (HQ.NameOnly name) = isSymbolic' name
|
||||
isSymbolic (HQ.HashQualified name _) = isSymbolic' name
|
||||
isSymbolic (HQ.HashOnly _) = False
|
||||
|
||||
isSymbolic' :: Name -> Bool
|
||||
isSymbolic' name = case symbolyId . Name.toString $ name of
|
||||
Right _ -> True
|
||||
_ -> False
|
||||
|
||||
|
||||
@ -8,7 +8,8 @@ module Unison.TypePrinter where
|
||||
import Data.Maybe (isJust)
|
||||
import Data.String (fromString)
|
||||
import qualified Data.Text as Text
|
||||
import Unison.Names (Name)
|
||||
import Unison.HashQualified (HashQualified)
|
||||
import Unison.NamePrinter (prettyHashQualified)
|
||||
import Unison.PrettyPrintEnv (PrettyPrintEnv)
|
||||
import qualified Unison.PrettyPrintEnv as PrettyPrintEnv
|
||||
import Unison.Reference (pattern Builtin)
|
||||
@ -46,7 +47,7 @@ pretty :: Var v => PrettyPrintEnv -> Int -> AnnotatedType v a -> Pretty String
|
||||
-- application has precedence 10.
|
||||
pretty n p tp = case tp of
|
||||
Var' v -> l $ Text.unpack (Var.name v)
|
||||
Ref' r -> l $ Text.unpack (PrettyPrintEnv.typeName n r)
|
||||
Ref' r -> prettyHashQualified $ (PrettyPrintEnv.typeName n r)
|
||||
Cycle' _ _ -> l $ "error" -- TypeParser does not currently emit Cycle
|
||||
Abs' _ -> l $ "error" -- TypeParser does not currently emit Abs
|
||||
Ann' _ _ -> l $ "error" -- TypeParser does not currently emit Ann
|
||||
@ -112,24 +113,46 @@ pretty' Nothing n t = PP.render maxBound $ pretty n (-1) t
|
||||
|
||||
prettySignatures'
|
||||
:: Var v => PrettyPrintEnv
|
||||
-> [(Name, AnnotatedType v a)]
|
||||
-> [(HashQualified, AnnotatedType v a)]
|
||||
-> [Pretty ColorText]
|
||||
prettySignatures' env ts = PP.align
|
||||
[ (PP.text name, (": " <> PP.map fromString (pretty env (-1) typ)) `PP.orElse`
|
||||
[ (prettyHashQualified name, (": " <> PP.map fromString (pretty env (-1) typ)) `PP.orElse`
|
||||
(": " <> PP.indentNAfterNewline 2 (PP.map fromString (pretty env (-1) typ))))
|
||||
| (name, typ) <- ts
|
||||
]
|
||||
|
||||
prettySignaturesAlt'
|
||||
:: Var v => PrettyPrintEnv
|
||||
-> [([HashQualified], AnnotatedType v a)]
|
||||
-> [Pretty ColorText]
|
||||
prettySignaturesAlt' env ts = PP.align
|
||||
[ (PP.commas . fmap prettyHashQualified $ names, (": " <> PP.map fromString (pretty env (-1) typ)) `PP.orElse`
|
||||
(": " <> PP.indentNAfterNewline 2 (PP.map fromString (pretty env (-1) typ))))
|
||||
| (names, typ) <- ts
|
||||
]
|
||||
|
||||
-- prettySignatures'' :: Var v => PrettyPrintEnv -> [(Name, AnnotatedType v a)] -> [Pretty ColorText]
|
||||
-- prettySignatures'' env ts = prettySignatures' env (first HQ.fromName <$> ts)
|
||||
|
||||
prettySignatures
|
||||
:: Var v
|
||||
=> PrettyPrintEnv
|
||||
-> [(Name, AnnotatedType v a)]
|
||||
-> [(HashQualified, AnnotatedType v a)]
|
||||
-> Pretty ColorText
|
||||
prettySignatures env ts = PP.lines $
|
||||
PP.group <$> prettySignatures' env ts
|
||||
|
||||
prettyDataHeader :: Name -> Pretty ColorText
|
||||
prettyDataHeader name = PP.bold "type " <> PP.text name
|
||||
prettySignaturesAlt
|
||||
:: Var v
|
||||
=> PrettyPrintEnv
|
||||
-> [([HashQualified], AnnotatedType v a)]
|
||||
-> Pretty ColorText
|
||||
prettySignaturesAlt env ts = PP.lines $
|
||||
PP.group <$> prettySignaturesAlt' env ts
|
||||
|
||||
prettyEffectHeader :: Name -> Pretty ColorText
|
||||
prettyEffectHeader name = PP.bold "ability " <> PP.text name
|
||||
|
||||
prettyDataHeader :: HashQualified -> Pretty ColorText
|
||||
prettyDataHeader name = PP.bold "type " <> prettyHashQualified name
|
||||
|
||||
prettyEffectHeader :: HashQualified -> Pretty ColorText
|
||||
prettyEffectHeader name = PP.bold "ability " <> prettyHashQualified name
|
||||
|
||||
@ -32,7 +32,8 @@ import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import qualified Unison.ABT as ABT
|
||||
import qualified Unison.Blank as B
|
||||
import Unison.Names (Name)
|
||||
-- import Unison.Name (Name)
|
||||
-- import qualified Unison.Name as Name
|
||||
import Unison.Referent (Referent)
|
||||
import Unison.Result (pattern Result, Result,
|
||||
ResultT, runResultT)
|
||||
@ -47,6 +48,8 @@ import qualified Unison.Var as Var
|
||||
import qualified Unison.Typechecker.TypeLookup as TL
|
||||
-- import Debug.Trace
|
||||
|
||||
type Name = Text
|
||||
|
||||
type Term v loc = AnnotatedTerm v loc
|
||||
type Type v loc = AnnotatedType v loc
|
||||
|
||||
|
||||
@ -19,6 +19,7 @@ import Unison.DataDeclaration (DataDeclaration')
|
||||
import Unison.DataDeclaration (EffectDeclaration' (..))
|
||||
import Unison.DataDeclaration (hashDecls, toDataDecl, withEffectDecl)
|
||||
import qualified Unison.DataDeclaration as DD
|
||||
import qualified Unison.Name as Name
|
||||
import Unison.Names (Names)
|
||||
import qualified Unison.Names as Names
|
||||
import Unison.Reference (Reference)
|
||||
@ -104,7 +105,7 @@ dependencies uf ns = directReferences <>
|
||||
tm = term uf
|
||||
directReferences = Term.dependencies tm
|
||||
freeTypeVarRefs = -- we aren't doing any special resolution for types
|
||||
catMaybes (flip Map.lookup (Names.typeNames ns) . Var.name <$>
|
||||
catMaybes (flip Map.lookup (Names.typeNames ns) . Name.unsafeFromVar <$>
|
||||
Set.toList (Term.freeTypeVars tm))
|
||||
-- foreach name in Names.termNames,
|
||||
-- if the name or unqualified name is in Term.freeVars,
|
||||
@ -112,8 +113,8 @@ dependencies uf ns = directReferences <>
|
||||
freeTermVarRefs =
|
||||
[ Referent.toReference referent
|
||||
| (name, referent) <- Map.toList $ Names.termNames ns
|
||||
, Var.named name `Set.member` Term.freeVars tm
|
||||
|| Var.unqualified (Var.named name) `Set.member` Term.freeVars tm
|
||||
, Name.toVar name `Set.member` Term.freeVars tm
|
||||
|| Var.unqualified (Name.toVar name) `Set.member` Term.freeVars tm
|
||||
]
|
||||
|
||||
discardTypes :: AnnotatedTerm v a -> TypecheckedUnisonFile v a -> UnisonFile v a
|
||||
@ -220,8 +221,8 @@ environmentFor
|
||||
environmentFor names0 dataDecls0 effectDecls0 =
|
||||
let
|
||||
-- ignore builtin types that will be shadowed by user-defined data/effects
|
||||
unshadowed n = Map.notMember (Var.named n) dataDecls0
|
||||
&& Map.notMember (Var.named n) effectDecls0
|
||||
unshadowed n = Map.notMember (Name.toVar n) dataDecls0
|
||||
&& Map.notMember (Name.toVar n) effectDecls0
|
||||
names = Names.filterTypes unshadowed names0
|
||||
-- data decls and hash decls may reference each other, and thus must be hashed together
|
||||
dataDecls :: Map v (DataDeclaration' v a)
|
||||
|
||||
2
parser-typechecker/src/Unison/Util/Histogram.hs
Normal file
2
parser-typechecker/src/Unison/Util/Histogram.hs
Normal file
@ -0,0 +1,2 @@
|
||||
module Unison.Util.Histogram where
|
||||
--
|
||||
@ -9,6 +9,10 @@ intercalateMap :: (Foldable t, Monoid a) => a -> (b -> a) -> t b -> a
|
||||
intercalateMap separator renderer elements =
|
||||
mconcat $ intersperse separator (renderer <$> toList elements)
|
||||
|
||||
fromMaybe :: Monoid a => Maybe a -> a
|
||||
fromMaybe Nothing = mempty
|
||||
fromMaybe (Just a) = a
|
||||
|
||||
whenM :: Monoid a => Bool -> a -> a
|
||||
whenM True a = a
|
||||
whenM False _ = mempty
|
||||
|
||||
@ -32,7 +32,6 @@ module Unison.Util.Pretty (
|
||||
lit,
|
||||
map,
|
||||
nest,
|
||||
name,
|
||||
newline,
|
||||
numbered,
|
||||
orElse,
|
||||
@ -291,10 +290,6 @@ align' rows = alignedRows
|
||||
text :: IsString s => Text -> Pretty s
|
||||
text t = fromString (Text.unpack t)
|
||||
|
||||
name :: (Pretty ColorText -> Pretty ColorText) -> Text -> Pretty ColorText
|
||||
name style t = case Text.span (/= '#') t of
|
||||
(hd, tl) -> group $ style (text hd) <> text tl
|
||||
|
||||
hang'
|
||||
:: (LL.ListLike s Char, IsString s)
|
||||
=> Pretty s
|
||||
|
||||
@ -5,6 +5,7 @@ module Unison.Test.TermPrinter where
|
||||
import EasyTest
|
||||
import qualified Data.Text as Text
|
||||
import Unison.ABT (annotation)
|
||||
import qualified Unison.HashQualified as HQ
|
||||
import Unison.Term
|
||||
import Unison.TermPrinter
|
||||
import qualified Unison.Type as Type
|
||||
@ -69,7 +70,7 @@ tc_binding width v mtp tm expected =
|
||||
input_term (Just (tp)) = ann (annotation tp) base_term tp
|
||||
input_term Nothing = base_term
|
||||
var_v = symbol $ Text.pack v
|
||||
prettied = prettyBinding get_names var_v (input_term input_type)
|
||||
prettied = prettyBinding get_names (HQ.fromVar var_v) (input_term input_type)
|
||||
actual = if width == 0
|
||||
then PP.renderUnbroken $ prettied
|
||||
else PP.render width $ prettied
|
||||
|
||||
@ -41,7 +41,6 @@ library
|
||||
Unison.Codebase
|
||||
Unison.Codebase.Branch
|
||||
Unison.Codebase.Causal
|
||||
Unison.Codebase.CommandLine
|
||||
Unison.Codebase.CommandLine2
|
||||
Unison.Codebase.Editor
|
||||
Unison.Codebase.Editor.Actions
|
||||
@ -59,9 +58,12 @@ library
|
||||
Unison.FileParsers
|
||||
Unison.Hash
|
||||
Unison.Hashable
|
||||
Unison.HashQualified
|
||||
Unison.Kind
|
||||
Unison.Lexer
|
||||
Unison.Name
|
||||
Unison.Names
|
||||
Unison.NamePrinter
|
||||
Unison.Parser
|
||||
Unison.Parsers
|
||||
Unison.Path
|
||||
@ -95,6 +97,7 @@ library
|
||||
Unison.Util.Components
|
||||
Unison.Util.Free
|
||||
Unison.Util.Logger
|
||||
Unison.Util.Histogram
|
||||
Unison.Util.Menu
|
||||
Unison.Util.Monoid
|
||||
Unison.Util.Pretty
|
||||
@ -193,15 +196,6 @@ executable prettyprintdemo
|
||||
text,
|
||||
unison-parser-typechecker
|
||||
|
||||
executable unisonold
|
||||
main-is: Main.hs
|
||||
hs-source-dirs: unisonold
|
||||
ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-missing-pattern-synonym-signatures
|
||||
build-depends:
|
||||
base,
|
||||
safe,
|
||||
unison-parser-typechecker
|
||||
|
||||
executable tests
|
||||
main-is: Suite.hs
|
||||
ghc-options: -W -fno-warn-name-shadowing -fno-warn-missing-pattern-synonym-signatures -threaded -rtsopts -with-rtsopts=-N -v0
|
||||
|
||||
@ -1,52 +0,0 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Main where
|
||||
|
||||
import Data.Char ( toLower )
|
||||
import Safe ( headMay )
|
||||
import System.Environment ( getArgs )
|
||||
import System.IO ( BufferMode(NoBuffering)
|
||||
, hSetBuffering
|
||||
, stdout
|
||||
)
|
||||
import qualified Unison.Codebase as Codebase
|
||||
import qualified Unison.Codebase.CommandLine as CommandLine
|
||||
import qualified Unison.Codebase.FileCodebase as FileCodebase
|
||||
import Unison.Codebase.Runtime.JVM ( javaRuntime )
|
||||
import qualified Unison.Codebase.Serialization as S
|
||||
import Unison.Codebase.Serialization.V0
|
||||
( formatSymbol
|
||||
, getSymbol
|
||||
)
|
||||
import Unison.Parser ( Ann(External) )
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
args <- getArgs
|
||||
hSetBuffering stdout NoBuffering -- cool
|
||||
let codebasePath = ".unison"
|
||||
initialBranchName = "master"
|
||||
scratchFilePath = "."
|
||||
theCodebase =
|
||||
FileCodebase.codebase1 External formatSymbol formatAnn codebasePath
|
||||
launch = CommandLine.main scratchFilePath
|
||||
initialBranchName
|
||||
(headMay args)
|
||||
(javaRuntime getSymbol 42441)
|
||||
theCodebase
|
||||
exists <- FileCodebase.exists codebasePath
|
||||
case exists of
|
||||
True -> launch
|
||||
False -> do
|
||||
putStr
|
||||
"I can't find a Unison codebase here, would you like to create one? [y/n] "
|
||||
line <- getLine
|
||||
case words (map toLower line) of
|
||||
('y' : _) : _ -> do
|
||||
FileCodebase.initialize codebasePath
|
||||
Codebase.initialize theCodebase
|
||||
launch
|
||||
_ -> pure ()
|
||||
|
||||
formatAnn :: S.Format Ann
|
||||
formatAnn = S.Format (pure External) (\_ -> pure ())
|
||||
Loading…
Reference in New Issue
Block a user