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

Move name parsing/printing functions from Unison.Name to Unison.Syntax.Name

Browse Source
This commit is contained in:
Mitchell Rosen 2022-10-19 22:17:07 -04:00
parent 5245683d9e
commit ed77121949
67 changed files with 523 additions and 525 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
lib/unison-pretty-printer/src/Unison/Util/Pretty.hs
View File

@ -721,7 +721,7 @@ wrapColumn2 rows = lines (align rows)
-- Pad with enough space on the right to make all rows the same width
leftJustify ::
(Eq s, Show s, LL.ListLike s Char, IsString s) =>
(Eq s, LL.ListLike s Char, IsString s) =>
[(Pretty s, a)] ->
[(Pretty s, a)]
leftJustify rows =

4
lib/unison-pretty-printer/src/Unison/Util/SyntaxText.hs
View File

@ -1,5 +1,3 @@
{-# LANGUAGE DeriveGeneric #-}
module Unison.Util.SyntaxText where
import Unison.HashQualified (HashQualified)
@ -53,7 +51,7 @@ data Element r
| DocDelimiter
| -- the 'include' in @[include], etc
DocKeyword
deriving (Eq, Ord, Show, Functor)
deriving (Eq, Ord, Functor)
syntax :: Element r -> SyntaxText' r -> SyntaxText' r
syntax = annotate

1
parser-typechecker/package.yaml
View File

@ -78,6 +78,7 @@ dependencies:
- process
- random >= 1.2.0
- raw-strings-qq
- recover-rtti
- regex-base
- regex-tdfa
- safe

2
parser-typechecker/src/Unison/Builtin.hs
View File

@ -37,7 +37,6 @@ import qualified Unison.DataDeclaration as DD
import Unison.Hash (Hash)
import qualified Unison.Hashing.V2.Convert as H
import Unison.Name (Name)
import qualified Unison.Name as Name
import Unison.Names (Names (Names))
import Unison.NamesWithHistory (NamesWithHistory (..))
import Unison.Parser.Ann (Ann (..))
@ -45,6 +44,7 @@ import Unison.Prelude
import qualified Unison.Reference as R
import qualified Unison.Referent as Referent
import Unison.Symbol (Symbol)
import qualified Unison.Syntax.Name as Name (unsafeFromText, unsafeFromVar)
import qualified Unison.Type as Type
import qualified Unison.Typechecker.TypeLookup as TL
import qualified Unison.Util.Relation as Rel

23
parser-typechecker/src/Unison/Builtin/Decls.hs
View File

@ -1,7 +1,3 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}
module Unison.Builtin.Decls where
import Control.Lens (over, _3)
@ -10,13 +6,11 @@ import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
import Data.Sequence (Seq)
import Data.Text (Text, unpack)
import Debug.RecoverRTTI (anythingToString)
import qualified Unison.ABT as ABT
import Unison.ConstructorReference (GConstructorReference (..))
import qualified Unison.ConstructorType as CT
import Unison.DataDeclaration
( DataDeclaration (..),
Modifier (Structural, Unique),
)
import Unison.DataDeclaration (DataDeclaration (..), Modifier (Structural, Unique))
import qualified Unison.DataDeclaration as DD
import Unison.DataDeclaration.ConstructorId (ConstructorId)
import Unison.Hashing.V2.Convert (hashDataDecls)
@ -26,6 +20,7 @@ import qualified Unison.Reference as Reference
import Unison.Referent (Referent)
import qualified Unison.Referent as Referent
import Unison.Symbol (Symbol)
import qualified Unison.Syntax.Name as Name (unsafeFromVar)
import Unison.Term (Term, Term2)
import qualified Unison.Term as Term
import Unison.Type (Type)
@ -162,13 +157,13 @@ failConstructorReferent = Referent.Con (ConstructorReference testResultRef failC
builtinDataDecls :: [(Symbol, Reference.Id, DataDeclaration Symbol ())]
builtinDataDecls = rs1 ++ rs
where
rs1 = case hashDataDecls $
rs1 = case hashDataDecls Name.unsafeFromVar $
Map.fromList
[ (v "Link", link)
] of
Right a -> a
Left e -> error $ "builtinDataDecls: " <> show e
rs = case hashDataDecls $
Left e -> error $ "builtinDataDecls: " <> anythingToString e
rs = case hashDataDecls Name.unsafeFromVar $
Map.fromList
[ (v "Unit", unit),
(v "Tuple", tuple),
@ -194,7 +189,7 @@ builtinDataDecls = rs1 ++ rs
(v "io2.STMFailure", stmFailure)
] of
Right a -> a
Left e -> error $ "builtinDataDecls: " <> show e
Left e -> error $ "builtinDataDecls: " <> anythingToString e
linkRef = case rs1 of
[(_, linkRef, _)] -> linkRef
_ -> error "builtinDataDecls: Expected a single linkRef"
@ -431,9 +426,9 @@ builtinDataDecls = rs1 ++ rs
builtinEffectDecls :: [(Symbol, Reference.Id, DD.EffectDeclaration Symbol ())]
builtinEffectDecls =
case hashDataDecls $ Map.fromList [(v "Exception", exception)] of
case hashDataDecls Name.unsafeFromVar $ Map.fromList [(v "Exception", exception)] of
Right a -> over _3 DD.EffectDeclaration <$> a
Left e -> error $ "builtinEffectDecls: " <> show e
Left e -> error $ "builtinEffectDecls: " <> anythingToString e
where
v = Var.named
var name = Type.var () (v name)

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

@ -1,7 +1,4 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE PatternSynonyms #-}
-- | Find a computation of type '{IO} () in the codebase.
module Unison.Codebase.MainTerm where
@ -16,6 +13,7 @@ import qualified Unison.Parser.Ann as Parser.Ann
import Unison.Prelude
import Unison.Reference (Reference)
import qualified Unison.Referent as Referent
import qualified Unison.Syntax.HashQualified as HQ (fromString)
import Unison.Term (Term)
import qualified Unison.Term as Term
import Unison.Type (Type)

1
parser-typechecker/src/Unison/Codebase/Path.hs
View File

@ -94,6 +94,7 @@ import qualified Unison.Name as Name
import Unison.NameSegment (NameSegment (NameSegment))
import qualified Unison.NameSegment as NameSegment
import Unison.Prelude hiding (empty, toList)
import qualified Unison.Syntax.Name as Name (toString, unsafeFromText)
import Unison.Util.Monoid (intercalateMap)
-- `Foo.Bar.baz` becomes ["Foo", "Bar", "baz"]

3
parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs
View File

@ -78,6 +78,7 @@ import qualified Unison.Referent as Referent
import qualified Unison.Referent' as Referent'
import qualified Unison.Sqlite as Sqlite
import Unison.Symbol (Symbol)
import qualified Unison.Syntax.Name as Name (unsafeFromVar)
import qualified Unison.Term as Term
import Unison.Type (Type)
import qualified Unison.Type as Type
@ -663,7 +664,7 @@ migrateDeclComponent termBuffer declBuffer oldHash = fmap (either id id) . runEx
remappedReferences
& Map.elems
& Map.fromList
& Convert.hashDecls
& Convert.hashDecls Name.unsafeFromVar
& fromRight (error "unexpected resolution error")
for_ newComponent $ \(declName, newReferenceId, dd) -> do

2
parser-typechecker/src/Unison/FileParsers.hs
View File

@ -1,4 +1,3 @@
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE UnicodeSyntax #-}
@ -27,6 +26,7 @@ import Unison.Reference (Reference)
import qualified Unison.Referent as Referent
import Unison.Result (CompilerBug (..), Note (..), Result, ResultT, pattern Result)
import qualified Unison.Result as Result
import qualified Unison.Syntax.Name as Name (toText, unsafeFromVar)
import qualified Unison.Syntax.Parser as Parser
import qualified Unison.Term as Term
import qualified Unison.Type as Type

12
parser-typechecker/src/Unison/Hashing/V2/Convert.hs
View File

@ -1,5 +1,4 @@
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE ViewPatterns #-}
-- | Description: Converts V1 types to the V2 hashing types
module Unison.Hashing.V2.Convert
@ -35,6 +34,7 @@ import qualified Unison.Codebase.Causal.Type as Memory.Causal
import qualified Unison.Codebase.Patch as Memory.Patch
import qualified Unison.Codebase.TermEdit as Memory.TermEdit
import qualified Unison.Codebase.TypeEdit as Memory.TypeEdit
import Unison.Name (Name)
import qualified Unison.ConstructorReference as Memory.ConstructorReference
import qualified Unison.ConstructorType as CT
import qualified Unison.ConstructorType as Memory.ConstructorType
@ -235,11 +235,12 @@ h2mReferent getCT = \case
hashDataDecls ::
Var v =>
(v -> Name) ->
Map v (Memory.DD.DataDeclaration v a) ->
ResolutionResult v a [(v, Memory.Reference.Id, Memory.DD.DataDeclaration v a)]
hashDataDecls memDecls = do
hashDataDecls unsafeVarToName memDecls = do
let hashingDecls = fmap m2hDecl memDecls
hashingResult <- Hashing.DD.hashDecls hashingDecls
hashingResult <- Hashing.DD.hashDecls unsafeVarToName hashingDecls
pure $ map h2mDeclResult hashingResult
where
h2mDeclResult :: Ord v => (v, Hashing.Reference.Id, Hashing.DD.DataDeclaration v a) -> (v, Memory.Reference.Id, Memory.DD.DataDeclaration v a)
@ -247,16 +248,17 @@ hashDataDecls memDecls = do
hashDecls ::
Var v =>
(v -> Name) ->
Map v (Memory.DD.Decl v a) ->
ResolutionResult v a [(v, Memory.Reference.Id, Memory.DD.Decl v a)]
hashDecls memDecls = do
hashDecls unsafeVarToName memDecls = do
-- want to unwrap the decl before doing the rehashing, and then wrap it back up the same way
let howToReassemble =
memDecls <&> \case
Left {} -> CT.Effect
Right {} -> CT.Data
memDeclsAsDDs = Memory.DD.asDataDecl <$> memDecls
result <- hashDataDecls memDeclsAsDDs
result <- hashDataDecls unsafeVarToName memDeclsAsDDs
pure $
result <&> \(v, id', decl) ->
case Map.lookup v howToReassemble of

4
parser-typechecker/src/Unison/PrettyPrintEnv/FQN.hs
View File

@ -1,12 +1,10 @@
{-# LANGUAGE OverloadedStrings #-}
module Unison.PrettyPrintEnv.FQN (Imports, Prefix, Suffix, elideFQN) where
import qualified Data.Map as Map
import qualified Unison.HashQualified as HQ
import Unison.Name (Name)
import qualified Unison.Name as Name
import Unison.Prelude
import qualified Unison.Syntax.Name as Name (unsafeFromText)
-- Type aliases relating to Fully-Qualified Names, e.g. 'Acme.API.foo'
-- Used primarily by the FQN elision code - see TermPrinter.PrintAnnotation.

12
parser-typechecker/src/Unison/PrintError.hs
View File

@ -1,7 +1,4 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
module Unison.PrintError where
@ -17,6 +14,7 @@ import qualified Data.Set as Set
import Data.Set.NonEmpty (NESet)
import qualified Data.Set.NonEmpty as NES
import qualified Data.Text as Text
import Data.Void (Void)
import qualified Text.Megaparsec as P
import qualified Unison.ABT as ABT
import Unison.Builtin.Decls (pattern TupleType')
@ -1362,7 +1360,7 @@ renderParseErrors s = \case
excerpt
]
L.Opaque msg -> style ErrorSite msg
te@(P.TrivialError _errOffset unexpected _expected) ->
P.TrivialError errOffset unexpected expected ->
let (src, ranges) = case unexpected of
Just (P.Tokens (toList -> ts)) -> case ts of
[] -> (mempty, [])
@ -1370,7 +1368,11 @@ renderParseErrors s = \case
let rs = rangeForToken <$> ts
in (showSource s $ (\r -> (r, ErrorSite)) <$> rs, rs)
_ -> mempty
in [(fromString (P.parseErrorPretty te) <> src, ranges)]
-- Same error that we just pattern matched on, but with a different error component (here Void) - we need one
-- with a ShowErrorComponent instance, which our error type doesn't have.
sameErr :: P.ParseError Parser.Input Void
sameErr = P.TrivialError errOffset unexpected expected
in [(fromString (P.parseErrorPretty sameErr) <> src, ranges)]
P.FancyError _sp fancyErrors ->
(go' <$> Set.toList fancyErrors)
where

4
parser-typechecker/src/Unison/Result.hs
View File

@ -1,6 +1,3 @@
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE Rank2Types #-}
module Unison.Result where
import Control.Error.Util (note)
@ -30,7 +27,6 @@ data Note v loc
| TypeError (Context.ErrorNote v loc)
| TypeInfo (Context.InfoNote v loc)
| CompilerBug (CompilerBug v loc)
deriving (Show)
data CompilerBug v loc
= TopLevelComponentNotFound v (Term v loc)

9
parser-typechecker/src/Unison/Runtime/IOSource.hs
View File

@ -1,15 +1,14 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
module Unison.Runtime.IOSource where
import Control.Lens (view, _1)
import Control.Monad.Morph (hoist)
import Data.Foldable (toList)
import Data.List (elemIndex, genericIndex)
import qualified Data.Map as Map
import Debug.RecoverRTTI (anythingToString)
import Text.RawString.QQ (r)
import qualified Unison.Builtin as Builtin
import Unison.Codebase.CodeLookup (CodeLookup (..))
@ -45,8 +44,8 @@ typecheckedFile' =
env = Parser.ParsingEnv mempty (Names.NamesWithHistory Builtin.names0 mempty)
r = parseAndSynthesizeFile [] tl env "<IO.u builtin>" source
in case runIdentity $ Result.runResultT r of
(Nothing, notes) -> error $ "parsing failed: " <> show notes
(Just Left {}, notes) -> error $ "typechecking failed" <> show notes
(Nothing, notes) -> error $ "parsing failed: " <> anythingToString (toList notes)
(Just Left {}, notes) -> error $ "typechecking failed" <> anythingToString (toList notes)
(Just (Right file), _) -> file
typecheckedFileTerms :: Map.Map Symbol R.Reference

9
parser-typechecker/src/Unison/Syntax/DeclPrinter.hs
View File

@ -13,7 +13,6 @@ import qualified Unison.DataDeclaration as DD
import qualified Unison.HashQualified as HQ
import qualified Unison.Hashing.V2.Convert as Hashing
import Unison.Name (Name)
import qualified Unison.Name as Name
import Unison.Prelude
import Unison.PrettyPrintEnv (PrettyPrintEnv)
import qualified Unison.PrettyPrintEnv as PPE
@ -21,6 +20,7 @@ import Unison.PrettyPrintEnvDecl (PrettyPrintEnvDecl (..))
import Unison.Reference (Reference (DerivedId))
import qualified Unison.Referent as Referent
import qualified Unison.Result as Result
import qualified Unison.Syntax.HashQualified as HQ (toVar, unsafeFromString)
import Unison.Syntax.NamePrinter (styleHashQualified'')
import qualified Unison.Syntax.TypePrinter as TypePrinter
import qualified Unison.Term as Term
@ -86,8 +86,11 @@ prettyPattern ::
prettyPattern env ctorType namespace ref =
styleHashQualified''
(fmt (S.TermReference conRef))
( HQ.stripNamespace (fromMaybe "" $ Name.toText <$> HQ.toName namespace) $
PPE.termName env conRef
( let strip =
case HQ.toName namespace of
Nothing -> id
Just name -> HQ.stripNamespace name
in strip (PPE.termName env conRef)
)
where
conRef = Referent.Con ref ctorType

7
parser-typechecker/src/Unison/Syntax/FileParser.hs
View File

@ -1,7 +1,3 @@
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
module Unison.Syntax.FileParser where
import Control.Lens
@ -20,6 +16,7 @@ import qualified Unison.NamesWithHistory as NamesWithHistory
import Unison.Parser.Ann (Ann)
import Unison.Prelude
import qualified Unison.Syntax.Lexer as L
import qualified Unison.Syntax.Name as Name (toText, toVar, unsafeFromVar)
import Unison.Syntax.Parser
import qualified Unison.Syntax.TermParser as TermParser
import qualified Unison.Syntax.TypeParser as TypeParser
@ -109,7 +106,7 @@ file = do
-- `bob -> bob * 42`, `bob` will correctly refer to the lambda parameter.
-- and not the `zonk.bob` declared in the file.
resolveLocals = ABT.substsInheritAnnotation replacements
let bindNames = Term.bindSomeNames avoid curNames . resolveLocals
let bindNames = Term.bindSomeNames Name.unsafeFromVar avoid curNames . resolveLocals
where
avoid = Set.fromList (stanzas0 >>= getVars)
terms <- case List.validate (traverse bindNames) terms of

2
parser-typechecker/src/Unison/Syntax/NamePrinter.hs
View File

@ -5,12 +5,12 @@ import qualified Unison.HashQualified' as HQ'
import Unison.LabeledDependency (LabeledDependency)
import qualified Unison.LabeledDependency as LD
import Unison.Name (Name)
import qualified Unison.Name as Name
import Unison.Prelude
import Unison.Reference (Reference)
import Unison.Referent (Referent)
import Unison.ShortHash (ShortHash)
import qualified Unison.ShortHash as SH
import qualified Unison.Syntax.Name as Name (toText)
import Unison.Util.Pretty (Pretty)
import qualified Unison.Util.Pretty as PP
import qualified Unison.Util.SyntaxText as S

5
parser-typechecker/src/Unison/Syntax/TermParser.hs
View File

@ -1,8 +1,4 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
module Unison.Syntax.TermParser where
@ -37,6 +33,7 @@ import Unison.Prelude
import Unison.Reference (Reference)
import Unison.Referent (Referent)
import qualified Unison.Syntax.Lexer as L
import qualified Unison.Syntax.Name as Name (toText, toVar, unsafeFromVar)
import Unison.Syntax.Parser hiding (seq)
import qualified Unison.Syntax.Parser as Parser (seq, uniqueName)
import qualified Unison.Syntax.TypeParser as TypeParser

114
parser-typechecker/src/Unison/Syntax/TermPrinter.hs
View File

@ -1,7 +1,3 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}
module Unison.Syntax.TermPrinter where
import Control.Lens (unsnoc, (^.))
@ -36,7 +32,9 @@ import Unison.Reference (Reference)
import qualified Unison.Reference as Reference
import Unison.Referent (Referent)
import qualified Unison.Referent as Referent
import qualified Unison.Syntax.HashQualified as HQ (unsafeFromVar)
import Unison.Syntax.Lexer (showEscapeChar, symbolyId)
import qualified Unison.Syntax.Name as Name (toString, toText, unsafeFromText)
import Unison.Syntax.NamePrinter (styleHashQualified'')
import qualified Unison.Syntax.TypePrinter as TypePrinter
import Unison.Term
@ -256,19 +254,19 @@ pretty0
<> pretty0 n (ac (if isBlock x then 0 else 10) Normal im doc) x
Delay' x
| Lets' _ _ <- x ->
paren (p >= 3) $
fmt S.ControlKeyword "do" `PP.hang` pretty0 n (ac 0 Block im doc) x
paren (p >= 3) $
fmt S.ControlKeyword "do" `PP.hang` pretty0 n (ac 0 Block im doc) x
| otherwise ->
paren (p >= 11 || isBlock x && p >= 3) $
fmt S.DelayForceChar (l "'")
<> ( case x of
Lets' _ _ -> id
-- Add indentation below if we're opening parens with '(
-- This is in case the contents are a long function application
-- in which case the arguments should be indented.
_ -> PP.indentAfterNewline " "
)
(pretty0 n (ac 10 Normal im doc) x)
paren (p >= 11 || isBlock x && p >= 3) $
fmt S.DelayForceChar (l "'")
<> ( case x of
Lets' _ _ -> id
-- Add indentation below if we're opening parens with '(
-- This is in case the contents are a long function application
-- in which case the arguments should be indented.
_ -> PP.indentAfterNewline " "
)
(pretty0 n (ac 10 Normal im doc) x)
List' xs ->
PP.group $
(fmt S.DelimiterChar $ l "[") <> optSpace
@ -319,11 +317,11 @@ pretty0
-- See `isDestructuringBind` definition.
Match' scrutinee cs@[MatchCase pat guard (AbsN' vs body)]
| p < 1 && isDestructuringBind scrutinee cs ->
letIntro $
PP.lines
[ (lhs <> eq) `PP.hang` rhs,
pretty0 n (ac (-1) Block im doc) body
]
letIntro $
PP.lines
[ (lhs <> eq) `PP.hang` rhs,
pretty0 n (ac (-1) Block im doc) body
]
where
letIntro = case bc of
Block -> id
@ -363,9 +361,9 @@ pretty0
specialCases term go = case (term, binaryOpsPred) of
(DD.Doc, _)
| doc == MaybeDoc ->
if isDocLiteral term
then prettyDoc n im term
else pretty0 n (a {docContext = NoDoc}) term
if isDocLiteral term
then prettyDoc n im term
else pretty0 n (a {docContext = NoDoc}) term
(TupleTerm' [x], _) ->
let conRef = DD.pairCtorRef
name = elideFQN im $ PrettyPrintEnv.termName n conRef
@ -420,12 +418,12 @@ pretty0
_ -> case (term, nonForcePred) of
OverappliedBinaryAppPred' f a b r
| binaryOpsPred f ->
-- Special case for overapplied binary op
paren
True
( binaryApps [(f, a)] (pretty0 n (ac 3 Normal im doc) b)
`PP.hang` PP.spacedMap (pretty0 n (ac 10 Normal im doc)) r
)
-- Special case for overapplied binary op
paren
True
( binaryApps [(f, a)] (pretty0 n (ac 3 Normal im doc) b)
`PP.hang` PP.spacedMap (pretty0 n (ac 10 Normal im doc)) r
)
AppsPred' f args ->
paren (p >= 10) $
pretty0 n (ac 10 Normal im doc) f
@ -569,8 +567,8 @@ prettyPattern n c@(AmbientContext {imports = im}) p vs patt = case patt of
Pattern.Text _ t -> (fmt S.TextLiteral $ l $ show t, vs)
TuplePattern pats
| length pats /= 1 ->
let (pats_printed, tail_vs) = patterns (-1) vs pats
in (PP.parenthesizeCommas pats_printed, tail_vs)
let (pats_printed, tail_vs) = patterns (-1) vs pats
in (PP.parenthesizeCommas pats_printed, tail_vs)
Pattern.Constructor _ ref [] ->
(styleHashQualified'' (fmt $ S.TermReference conRef) name, vs)
where
@ -800,14 +798,14 @@ prettyBinding0 env a@AmbientContext {imports = im, docContext = doc} v term =
where
defnLhs v vs
| infix' = case vs of
x : y : _ ->
PP.sep
" "
[ fmt S.Var $ PP.text (Var.name x),
styleHashQualified'' (fmt $ S.HashQualifier v) $ elideFQN im v,
fmt S.Var $ PP.text (Var.name y)
]
_ -> l "error"
x : y : _ ->
PP.sep
" "
[ fmt S.Var $ PP.text (Var.name x),
styleHashQualified'' (fmt $ S.HashQualifier v) $ elideFQN im v,
fmt S.Var $ PP.text (Var.name y)
]
_ -> l "error"
| null vs = renderName v
| otherwise = renderName v `PP.hang` args vs
args = PP.spacedMap $ fmt S.Var . PP.text . Var.name
@ -1433,7 +1431,7 @@ unLetBlock t = rec t
Just (_isTop, bindings, body) -> case rec body of
Just (innerBindings, innerBody)
| dontIntersect bindings innerBindings ->
Just (bindings ++ innerBindings, innerBody)
Just (bindings ++ innerBindings, innerBody)
_ -> Just (bindings, body)
nonrec t = case unLet t of
Nothing -> Nothing
@ -1442,7 +1440,7 @@ unLetBlock t = rec t
in case rec body of
Just (innerBindings, innerBody)
| dontIntersect bindings innerBindings ->
Just (bindings ++ innerBindings, innerBody)
Just (bindings ++ innerBindings, innerBody)
_ -> Just (bindings, body)
pattern LamsNamedMatch' ::
@ -1495,7 +1493,7 @@ unLamsMatch' t = case unLamsUntilDelay' t of
| -- if `v1'` is referenced in any of the branches, we can't use lambda case
-- syntax as we need to keep the `v1'` name that was introduced
(v1 == v1') && Set.notMember v1' (Set.unions $ freeVars <$> branches) ->
Just (reverse vs, [([p], guard, body) | MatchCase p guard body <- branches])
Just (reverse vs, [([p], guard, body) | MatchCase p guard body <- branches])
-- x y z -> match (x,y,z) with (pat1, pat2, pat3) -> ...
-- becomes
-- cases pat1 pat2 pat3 -> ...`
@ -1508,7 +1506,7 @@ unLamsMatch' t = case unLamsUntilDelay' t of
all notFree (take len vs)
&& all isRightArity branches
&& len /= 0 -> -- all patterns need to match arity of scrutes
Just (reverse (drop len vs), branches')
Just (reverse (drop len vs), branches')
where
isRightArity (MatchCase (TuplePattern ps) _ _) = length ps == len
isRightArity (MatchCase {}) = False
@ -1747,7 +1745,7 @@ toDocExample' suffix ppe (Apps' (Ref' r) [Nat' n, l@(LamsNamed' vs tm)])
| nameEndsWith ppe suffix r,
ABT.freeVars l == mempty,
ok tm =
Just (lam' (ABT.annotation l) (drop (fromIntegral n + 1) vs) tm)
Just (lam' (ABT.annotation l) (drop (fromIntegral n + 1) vs) tm)
where
ok (Apps' f _) = ABT.freeVars f == mempty
ok tm = ABT.freeVars tm == mempty
@ -1761,9 +1759,9 @@ toDocTransclude _ _ = Nothing
toDocLink :: Ord v => PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe (Either Reference Referent)
toDocLink ppe (App' (Ref' r) tm)
| nameEndsWith ppe ".docLink" r = case tm of
(toDocEmbedTermLink ppe -> Just tm) -> Just (Right tm)
(toDocEmbedTypeLink ppe -> Just tm) -> Just (Left tm)
_ -> Nothing
(toDocEmbedTermLink ppe -> Just tm) -> Just (Right tm)
(toDocEmbedTypeLink ppe -> Just tm) -> Just (Left tm)
_ -> Nothing
toDocLink _ _ = Nothing
toDocNamedLink :: PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe (Term3 v PrintAnnotation, Term3 v PrintAnnotation)
@ -1802,7 +1800,7 @@ toDocSourceAnnotations _ppe _tm = Just [] -- todo fetch annotations
toDocSourceElement :: Ord v => PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe (Either Reference Referent, [Referent])
toDocSourceElement ppe (Apps' (Ref' r) [tm, toDocSourceAnnotations ppe -> Just annotations])
| nameEndsWith ppe ".docSourceElement" r =
(,annotations) <$> ok tm
(,annotations) <$> ok tm
where
ok tm =
(Right <$> toDocEmbedTermLink ppe tm)
@ -1817,9 +1815,9 @@ toDocSource' ::
Maybe [(Either Reference Referent, [Referent])]
toDocSource' suffix ppe (App' (Ref' r) (List' tms))
| nameEndsWith ppe suffix r =
case [tm | Just tm <- toDocSourceElement ppe <$> toList tms] of
tms' | length tms' == length tms -> Just tms'
_ -> Nothing
case [tm | Just tm <- toDocSourceElement ppe <$> toList tms] of
tms' | length tms' == length tms -> Just tms'
_ -> Nothing
toDocSource' _ _ _ = Nothing
toDocSource,
@ -1849,17 +1847,17 @@ toDocEmbedAnnotation _ _ = Nothing
toDocEmbedAnnotations :: PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe [Term3 v PrintAnnotation]
toDocEmbedAnnotations ppe (App' (Ref' r) (List' tms))
| nameEndsWith ppe ".docEmbedAnnotations" r =
case [ann | Just ann <- toDocEmbedAnnotation ppe <$> toList tms] of
tms' | length tms' == length tms -> Just tms'
_ -> Nothing
case [ann | Just ann <- toDocEmbedAnnotation ppe <$> toList tms] of
tms' | length tms' == length tms -> Just tms'
_ -> Nothing
toDocEmbedAnnotations _ _ = Nothing
toDocSignature :: Ord v => PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe [Referent]
toDocSignature ppe (App' (Ref' r) (List' tms))
| nameEndsWith ppe ".docSignature" r =
case [tm | Just tm <- toDocEmbedSignatureLink ppe <$> toList tms] of
tms' | length tms' == length tms -> Just tms'
_ -> Nothing
case [tm | Just tm <- toDocEmbedSignatureLink ppe <$> toList tms] of
tms' | length tms' == length tms -> Just tms'
_ -> Nothing
toDocSignature _ _ = Nothing
toDocBulletedList :: PrettyPrintEnv -> Term3 v PrintAnnotation -> Maybe [Term3 v PrintAnnotation]

4
parser-typechecker/src/Unison/Syntax/TypeParser.hs
View File

@ -1,5 +1,3 @@
{-# LANGUAGE OverloadedStrings #-}
module Unison.Syntax.TypeParser where
import Control.Monad.Reader (asks)
@ -7,8 +5,8 @@ import qualified Data.Set as Set
import qualified Text.Megaparsec as P
import qualified Unison.Builtin.Decls as DD
import qualified Unison.HashQualified as HQ
import qualified Unison.Name as Name
import qualified Unison.NamesWithHistory as Names
import qualified Unison.Syntax.Name as Name (toVar)
import Unison.Parser.Ann (Ann (..))
import Unison.Prelude
import qualified Unison.Syntax.Lexer as L

1
parser-typechecker/src/Unison/Typechecker.hs
View File

@ -32,6 +32,7 @@ import Unison.Result
pattern Result,
)
import qualified Unison.Result as Result
import qualified Unison.Syntax.Name as Name (toText, unsafeFromText)
import Unison.Term (Term)
import qualified Unison.Term as Term
import Unison.Type (Type)

25
parser-typechecker/src/Unison/UnisonFile/Names.hs
View File

@ -1,8 +1,3 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
module Unison.UnisonFile.Names where
import Data.Bifunctor (second)
@ -13,12 +8,12 @@ import Unison.DataDeclaration (DataDeclaration, EffectDeclaration (..))
import qualified Unison.DataDeclaration as DD
import qualified Unison.DataDeclaration.Names as DD.Names
import qualified Unison.Hashing.V2.Convert as Hashing
import qualified Unison.Name as Name
import Unison.Names (Names (Names))
import qualified Unison.Names.ResolutionResult as Names
import Unison.Prelude
import qualified Unison.Reference as Reference
import qualified Unison.Referent as Referent
import qualified Unison.Syntax.Name as Name (unsafeFromVar)
import qualified Unison.Term as Term
import qualified Unison.UnisonFile as UF
import Unison.UnisonFile.Env (Env (..))
@ -31,8 +26,8 @@ import qualified Unison.WatchKind as WK
toNames :: Var v => UnisonFile v a -> Names
toNames uf = datas <> effects
where
datas = foldMap DD.Names.dataDeclToNames' (Map.toList (UF.dataDeclarationsId uf))
effects = foldMap DD.Names.effectDeclToNames' (Map.toList (UF.effectDeclarationsId uf))
datas = foldMap (DD.Names.dataDeclToNames' Name.unsafeFromVar) (Map.toList (UF.dataDeclarationsId uf))
effects = foldMap (DD.Names.effectDeclToNames' Name.unsafeFromVar) (Map.toList (UF.effectDeclarationsId uf))
typecheckedToNames :: Var v => TypecheckedUnisonFile v a -> Names
typecheckedToNames uf = Names (terms <> ctors) types
@ -81,8 +76,8 @@ bindNames names (UnisonFileId d e ts ws) = do
let termVars = (fst <$> ts) ++ (Map.elems ws >>= map fst)
termVarsSet = Set.fromList termVars
-- todo: can we clean up this lambda using something like `second`
ts' <- traverse (\(v, t) -> (v,) <$> Term.bindNames termVarsSet names t) ts
ws' <- traverse (traverse (\(v, t) -> (v,) <$> Term.bindNames termVarsSet names t)) ws
ts' <- traverse (\(v, t) -> (v,) <$> Term.bindNames Name.unsafeFromVar termVarsSet names t) ts
ws' <- traverse (traverse (\(v, t) -> (v,) <$> Term.bindNames Name.unsafeFromVar termVarsSet names t)) ws
pure $ UnisonFileId d e ts' ws'
-- This function computes hashes for data and effect declarations, and
@ -102,19 +97,19 @@ environmentFor names dataDecls0 effectDecls0 = do
let locallyBoundTypes = Map.keysSet dataDecls0 <> Map.keysSet effectDecls0
-- data decls and hash decls may reference each other, and thus must be hashed together
dataDecls :: Map v (DataDeclaration v a) <-
traverse (DD.Names.bindNames locallyBoundTypes names) dataDecls0
traverse (DD.Names.bindNames Name.unsafeFromVar locallyBoundTypes names) dataDecls0
effectDecls :: Map v (EffectDeclaration v a) <-
traverse (DD.withEffectDeclM (DD.Names.bindNames locallyBoundTypes names)) effectDecls0
traverse (DD.withEffectDeclM (DD.Names.bindNames Name.unsafeFromVar locallyBoundTypes names)) effectDecls0
let allDecls0 :: Map v (DataDeclaration v a)
allDecls0 = Map.union dataDecls (toDataDecl <$> effectDecls)
hashDecls' :: [(v, Reference.Id, DataDeclaration v a)] <- Hashing.hashDataDecls allDecls0
hashDecls' :: [(v, Reference.Id, DataDeclaration v a)] <- Hashing.hashDataDecls Name.unsafeFromVar allDecls0
-- then we have to pick out the dataDecls from the effectDecls
let allDecls = Map.fromList [(v, (r, de)) | (v, r, de) <- hashDecls']
dataDecls' = Map.difference allDecls effectDecls
effectDecls' = second EffectDeclaration <$> Map.difference allDecls dataDecls
-- ctor and effect terms
ctors = foldMap DD.Names.dataDeclToNames' (Map.toList dataDecls')
effects = foldMap DD.Names.effectDeclToNames' (Map.toList effectDecls')
ctors = foldMap (DD.Names.dataDeclToNames' Name.unsafeFromVar) (Map.toList dataDecls')
effects = foldMap (DD.Names.effectDeclToNames' Name.unsafeFromVar) (Map.toList effectDecls')
names' = ctors <> effects
overlaps =
let w v dd (toDataDecl -> ed) = DupDataAndAbility v (DD.annotation dd) (DD.annotation ed)

2
parser-typechecker/unison-parser-typechecker.cabal
View File

@ -242,6 +242,7 @@ library
, process
, random >=1.2.0
, raw-strings-qq
, recover-rtti
, regex-base
, regex-tdfa
, safe
@ -427,6 +428,7 @@ test-suite parser-typechecker-tests
, process
, random >=1.2.0
, raw-strings-qq
, recover-rtti
, regex-base
, regex-tdfa
, safe

1
unison-cli/package.yaml
View File

@ -54,6 +54,7 @@ dependencies:
- open-browser
- pretty-simple
- random >= 1.2.0
- recover-rtti
- regex-tdfa
- semialign
- servant

1
unison-cli/src/Unison/Cli/NamesUtils.hs
View File

@ -28,6 +28,7 @@ import Unison.NamesWithHistory (NamesWithHistory (..))
import qualified Unison.NamesWithHistory as NamesWithHistory
import Unison.Prelude
import qualified Unison.Server.Backend as Backend
import qualified Unison.Syntax.Name as Name (toString, unsafeFromString)
import Unison.UnisonFile (TypecheckedUnisonFile)
import qualified Unison.UnisonFile as UF
import qualified Unison.UnisonFile.Names as UF

6
unison-cli/src/Unison/Codebase/Editor/HandleInput.hs
View File

@ -19,7 +19,6 @@ import qualified Data.List as List
import Data.List.Extra (nubOrd)
import qualified Data.List.NonEmpty as Nel
import qualified Data.Map as Map
import Unison.Cli.TypeCheck (typecheck)
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import Data.Set.NonEmpty (NESet)
@ -45,6 +44,7 @@ import Unison.Cli.Monad (Cli)
import qualified Unison.Cli.Monad as Cli
import qualified Unison.Cli.MonadUtils as Cli
import Unison.Cli.NamesUtils (basicParseNames, basicPrettyPrintNamesA, displayNames, findHistoricalHQs, getBasicPrettyPrintNames, makeHistoricalParsingNames, makePrintNamesFromLabeled', makeShadowedPrintNamesFromHQ)
import Unison.Cli.TypeCheck (typecheck)
import Unison.Cli.UnisonConfigUtils (gitUrlKey, remoteMappingKey)
import Unison.Codebase (Codebase, Preprocessing (..), PushGitBranchOpts (..))
import qualified Unison.Codebase as Codebase
@ -160,7 +160,9 @@ import Unison.Share.Types (codeserverBaseURL)
import qualified Unison.ShortHash as SH
import Unison.Symbol (Symbol)
import qualified Unison.Sync.Types as Share (Path (..), hashJWTHash)
import qualified Unison.Syntax.HashQualified as HQ (unsafeFromString)
import qualified Unison.Syntax.Lexer as L
import qualified Unison.Syntax.Name as Name (toString, toVar, unsafeFromString, unsafeFromVar)
import qualified Unison.Syntax.Parser as Parser
import Unison.Term (Term)
import qualified Unison.Term as Term
@ -2707,7 +2709,7 @@ parseType input src = do
Parsers.parseType (Text.unpack (fst lexed)) (Parser.ParsingEnv mempty names) & onLeft \err ->
Cli.returnEarly (TypeParseError src err)
Type.bindNames mempty (NamesWithHistory.currentNames names) (Type.generalizeLowercase mempty typ) & onLeft \errs ->
Type.bindNames Name.unsafeFromVar mempty (NamesWithHistory.currentNames names) (Type.generalizeLowercase mempty typ) & onLeft \errs ->
Cli.returnEarly (ParseResolutionFailures src (toList errs))
getTermsIncludingHistorical :: Monad m => Path.HQSplit -> Branch0 m -> Cli (Set Referent)

2
unison-cli/src/Unison/Codebase/Editor/HandleInput/MetadataUtils.hs
View File

@ -25,7 +25,6 @@ import qualified Unison.CommandLine.InputPatterns as InputPatterns
import qualified Unison.HashQualified as HQ
import qualified Unison.Hashing.V2.Convert as Hashing
import Unison.Name (Name)
import qualified Unison.Name as Name
import Unison.NameSegment (NameSegment (..))
import Unison.Prelude
import qualified Unison.PrettyPrintEnv as PPE
@ -33,6 +32,7 @@ import Unison.Referent (Referent)
import qualified Unison.Referent as Referent
import qualified Unison.Server.Backend as Backend
import Unison.Symbol (Symbol)
import qualified Unison.Syntax.Name as Name (unsafeFromVar)
import qualified Unison.Util.Monoid as Monoid
import qualified Unison.Util.Relation as R
import qualified Unison.Util.Set as Set

2
unison-cli/src/Unison/Codebase/Editor/HandleInput/Update.hs
View File

@ -42,7 +42,6 @@ import qualified Unison.Codebase.TermEdit as TermEdit
import qualified Unison.Codebase.TypeEdit as TypeEdit
import Unison.Hash (Hash)
import Unison.Name (Name)
import qualified Unison.Name as Name
import Unison.Names (Names)
import qualified Unison.Names as Names
import Unison.Parser.Ann (Ann (..))
@ -56,6 +55,7 @@ import qualified Unison.Result as Result
import Unison.Runtime.IOSource (isTest)
import qualified Unison.Sqlite as Sqlite
import Unison.Symbol (Symbol)
import qualified Unison.Syntax.Name as Name (toVar, unsafeFromVar)
import Unison.Term (Term)
import qualified Unison.Term as Term
import Unison.Type (Type)

3
unison-cli/src/Unison/Codebase/Editor/Propagate.hs
View File

@ -50,6 +50,7 @@ import qualified Unison.Result as Result
import qualified Unison.Runtime.IOSource as IOSource
import qualified Unison.Sqlite as Sqlite
import Unison.Symbol (Symbol)
import qualified Unison.Syntax.Name as Name (unsafeFromVar)
import Unison.Term (Term)
import qualified Unison.Term as Term
import Unison.Type (Type)
@ -332,7 +333,7 @@ propagate patch b = case validatePatch patch of
-- TODO: kind-check the new components
hashedDecls =
(fmap . fmap) (over _2 DerivedId)
. Hashing.hashDataDecls
. Hashing.hashDataDecls Name.unsafeFromVar
$ view _2 <$> declMap
hashedComponents' <- case hashedDecls of
Left _ ->

2
unison-cli/src/Unison/Codebase/Editor/Slurp.hs
View File

@ -15,7 +15,6 @@ import qualified Unison.ConstructorReference as CR
import qualified Unison.DataDeclaration as DD
import qualified Unison.LabeledDependency as LD
import Unison.Name (Name)
import qualified Unison.Name as Name
import Unison.Names (Names)
import qualified Unison.Names as Names
import Unison.Parser.Ann (Ann)
@ -23,6 +22,7 @@ import Unison.Prelude
import Unison.Referent (Referent)
import qualified Unison.Referent as Referent
import qualified Unison.Referent' as Referent
import qualified Unison.Syntax.Name as Name (toText, unsafeFromVar)
import qualified Unison.UnisonFile as UF
import qualified Unison.UnisonFile.Names as UF
import qualified Unison.Util.Map as Map

2
unison-cli/src/Unison/Codebase/Editor/SlurpResult.hs
View File

@ -28,12 +28,12 @@ import qualified Data.Map as Map
import qualified Data.Set as Set
import Unison.Codebase.Editor.SlurpComponent (SlurpComponent (..))
import qualified Unison.Codebase.Editor.SlurpComponent as SC
import qualified Unison.HashQualified as HQ
import Unison.Name (Name)
import Unison.Parser.Ann (Ann)
import Unison.Prelude
import qualified Unison.PrettyPrintEnv as PPE
import qualified Unison.Syntax.DeclPrinter as DeclPrinter
import qualified Unison.Syntax.HashQualified as HQ (unsafeFromVar)
import qualified Unison.Syntax.TypePrinter as TP
import qualified Unison.UnisonFile as UF
import qualified Unison.Util.Pretty as P

1
unison-cli/src/Unison/Codebase/Editor/TodoOutput.hs
View File

@ -33,7 +33,6 @@ data TodoOutput v a = TodoOutput
nameConflicts :: Names,
editConflicts :: Patch
}
deriving (Show)
labeledDependencies :: Ord v => TodoOutput v a -> Set LabeledDependency
labeledDependencies TodoOutput {..} =

3
unison-cli/src/Unison/CommandLine/InputPatterns.hs
View File

@ -40,9 +40,10 @@ import Unison.CommandLine.InputPattern
import qualified Unison.CommandLine.InputPattern as I
import qualified Unison.HashQualified as HQ
import Unison.Name (Name)
import qualified Unison.Name as Name
import qualified Unison.NameSegment as NameSegment
import Unison.Prelude
import qualified Unison.Syntax.HashQualified as HQ (fromString)
import qualified Unison.Syntax.Name as Name (unsafeFromString)
import qualified Unison.Util.ColorText as CT
import Unison.Util.Monoid (intercalateMap)
import qualified Unison.Util.Pretty as P

16
unison-cli/src/Unison/CommandLine/OutputMessages.hs
View File

@ -126,6 +126,8 @@ import qualified Unison.ShortHash as SH
import qualified Unison.ShortHash as ShortHash
import qualified Unison.Sync.Types as Share
import qualified Unison.Syntax.DeclPrinter as DeclPrinter
import qualified Unison.Syntax.HashQualified as HQ (unsafeFromVar)
import qualified Unison.Syntax.Name as Name (toString, toText)
import Unison.Syntax.NamePrinter
( prettyHashQualified,
prettyHashQualified',
@ -2570,10 +2572,10 @@ showDiffNamespace sn ppe oldPath newPath OBD.BranchDiffOutput {..} =
leftNamePad :: P.Width =
foldl1' max $
map
(foldl1' max . map (P.Width . HQ'.nameLength) . toList . view _3)
(foldl1' max . map (P.Width . HQ'.nameLength Name.toText) . toList . view _3)
terms
<> map
(foldl1' max . map (P.Width . HQ'.nameLength) . toList . view _3)
(foldl1' max . map (P.Width . HQ'.nameLength Name.toText) . toList . view _3)
types
prettyGroup ::
( (Referent, b, Set (HQ'.HashQualified Name), Set (HQ'.HashQualified Name)),
@ -2791,7 +2793,7 @@ showDiffNamespace sn ppe oldPath newPath OBD.BranchDiffOutput {..} =
then error "Super invalid UpdateTermDisplay"
else fmap P.column2 $ traverse (mdTermLine newPath namesWidth) newTerms
where
namesWidth = foldl1' max $ fmap (P.Width . HQ'.nameLength . view _1) newTerms
namesWidth = foldl1' max $ fmap (P.Width . HQ'.nameLength Name.toText . view _1) newTerms
prettyUpdateTerm (Just olds, news) = fmap P.column2 $ do
olds <-
traverse
@ -2807,8 +2809,8 @@ showDiffNamespace sn ppe oldPath newPath OBD.BranchDiffOutput {..} =
where
namesWidth =
foldl1' max $
fmap (P.Width . HQ'.nameLength . view _1) news
<> fmap (P.Width . HQ'.nameLength . view _1) olds
fmap (P.Width . HQ'.nameLength Name.toText . view _1) news
<> fmap (P.Width . HQ'.nameLength Name.toText . view _1) olds
prettyMetadataDiff :: OBD.MetadataDiff (OBD.MetadataDisplay v a) -> Numbered Pretty
prettyMetadataDiff OBD.MetadataDiff {..} =
@ -3036,7 +3038,7 @@ prettyDiff diff =
movedTypes =
[ (n, n2) | (n, r) <- R.toList (Names.types removes), n2 <- toList (R.lookupRan r (Names.types adds))
]
moved = Name.sortNamed fst . nubOrd $ (movedTerms <> movedTypes)
moved = Name.sortNamed Name.toText fst . nubOrd $ (movedTerms <> movedTypes)
copiedTerms =
List.multimap
@ -3047,7 +3049,7 @@ prettyDiff diff =
[ (n, n2) | (n2, r) <- R.toList (Names.types adds), not (R.memberRan r (Names.types removes)), n <- toList (R.lookupRan r (Names.types orig))
]
copied =
Name.sortNamed fst $
Name.sortNamed Name.toText fst $
Map.toList (Map.unionWith (<>) copiedTerms copiedTypes)
in P.sepNonEmpty
"\n\n"

3
unison-cli/src/Unison/LSP/FileAnalysis.hs
View File

@ -11,6 +11,7 @@ import Data.IntervalMap.Lazy (IntervalMap)
import qualified Data.IntervalMap.Lazy as IM
import qualified Data.Map as Map
import qualified Data.Text as Text
import Debug.RecoverRTTI (anythingToString)
import Language.LSP.Types
( Diagnostic,
DiagnosticSeverity (DsError),
@ -104,7 +105,7 @@ fileAnalysisWorker = forever do
Map.fromList <$> forMaybe (toList dirtyFileIDs) \docUri -> runMaybeT do
fileInfo <- MaybeT (checkFile $ TextDocumentIdentifier docUri)
pure (docUri, fileInfo)
Debug.debugM Debug.LSP "Freshly Typechecked " freshlyCheckedFiles
Debug.debugM Debug.LSP "Freshly Typechecked " (anythingToString (Map.toList freshlyCheckedFiles))
-- Overwrite any files we successfully checked
atomically $ modifyTVar' checkedFilesV (Map.union freshlyCheckedFiles)
for freshlyCheckedFiles \(FileAnalysis {fileUri, fileVersion, diagnostics}) -> do

2
unison-cli/src/Unison/LSP/Hover.hs
View File

@ -9,13 +9,13 @@ import qualified Data.Text as Text
import Language.LSP.Types
import Language.LSP.Types.Lens
import qualified Unison.Codebase.Path as Path
import qualified Unison.HashQualified as HQ
import Unison.LSP.Types
import Unison.LSP.VFS
import Unison.Prelude
import qualified Unison.Server.Backend as Backend
import qualified Unison.Server.Syntax as Server
import qualified Unison.Server.Types as Backend
import qualified Unison.Syntax.HashQualified as HQ (fromText)
-- | Rudimentary hover handler
--

1
unison-cli/src/Unison/LSP/Types.hs
View File

@ -83,7 +83,6 @@ data FileAnalysis = FileAnalysis
diagnostics :: IntervalMap Position [Diagnostic],
codeActions :: IntervalMap Position [CodeAction]
}
deriving (Show)
getCurrentPath :: Lsp Path.Absolute
getCurrentPath = asks currentPathCache >>= liftIO

5
unison-cli/unison-cli.cabal
View File

@ -164,6 +164,7 @@ library
, open-browser
, pretty-simple
, random >=1.2.0
, recover-rtti
, regex-tdfa
, semialign
, servant
@ -287,6 +288,7 @@ executable cli-integration-tests
, pretty-simple
, process
, random >=1.2.0
, recover-rtti
, regex-tdfa
, semialign
, servant
@ -404,6 +406,7 @@ executable transcripts
, pretty-simple
, process
, random >=1.2.0
, recover-rtti
, regex-tdfa
, semialign
, servant
@ -525,6 +528,7 @@ executable unison
, optparse-applicative >=0.16.1.0
, pretty-simple
, random >=1.2.0
, recover-rtti
, regex-tdfa
, semialign
, servant
@ -652,6 +656,7 @@ test-suite cli-tests
, open-browser
, pretty-simple
, random >=1.2.0
, recover-rtti
, regex-tdfa
, semialign
, servant

5
unison-core/package.yaml
View File

@ -22,6 +22,7 @@ library:
- prelude-extras
- memory
- mtl
- recover-rtti
- rfc5051
- safe
- text
@ -36,8 +37,11 @@ library:
default-extensions:
- ApplicativeDo
- BlockArguments
- DeriveAnyClass
- DeriveFoldable
- DeriveFunctor
- DeriveGeneric
- DeriveTraversable
- DerivingStrategies
- DoAndIfThenElse
- FlexibleContexts
@ -48,6 +52,7 @@ default-extensions:
- NamedFieldPuns
- OverloadedStrings
- PatternSynonyms
- RankNTypes
- ScopedTypeVariables
- TupleSections
- TypeApplications

11
unison-core/src/Unison/DataDeclaration.hs
View File

@ -1,10 +1,4 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
module Unison.DataDeclaration
( DataDeclaration (..),
@ -247,13 +241,14 @@ allVars' = allVars . either toDataDecl id
bindReferences ::
Var v =>
(v -> Name.Name) ->
Set v ->
Map Name.Name Reference ->
DataDeclaration v a ->
Names.ResolutionResult v a (DataDeclaration v a)
bindReferences keepFree names (DataDeclaration m a bound constructors) = do
bindReferences unsafeVarToName keepFree names (DataDeclaration m a bound constructors) = do
constructors <- for constructors $ \(a, v, ty) ->
(a,v,) <$> Type.bindReferences keepFree names ty
(a,v,) <$> Type.bindReferences unsafeVarToName keepFree names ty
pure $ DataDeclaration m a bound constructors
dependencies :: Ord v => DataDeclaration v a -> Set Reference

35
unison-core/src/Unison/DataDeclaration/Names.hs
View File

@ -1,10 +1,4 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
module Unison.DataDeclaration.Names (bindNames, dataDeclToNames', effectDeclToNames') where
@ -24,35 +18,36 @@ import Unison.Var (Var)
import Prelude hiding (cycle)
-- implementation of dataDeclToNames and effectDeclToNames
toNames :: Var v => CT.ConstructorType -> v -> Reference.Id -> DataDeclaration v a -> Names
toNames ct typeSymbol (Reference.DerivedId -> r) dd =
toNames :: Var v => (v -> Name.Name) -> CT.ConstructorType -> v -> Reference.Id -> DataDeclaration v a -> Names
toNames unsafeVarToName ct typeSymbol (Reference.DerivedId -> r) dd =
-- constructor names
foldMap names (DD.constructorVars dd `zip` [0 ..])
-- name of the type itself
<> Names mempty (Rel.singleton (Name.unsafeFromVar typeSymbol) r)
<> Names mempty (Rel.singleton (unsafeVarToName typeSymbol) r)
where
names (ctor, i) =
Names (Rel.singleton (Name.unsafeFromVar ctor) (Referent.Con (ConstructorReference r i) ct)) mempty
Names (Rel.singleton (unsafeVarToName ctor) (Referent.Con (ConstructorReference r i) ct)) mempty
dataDeclToNames :: Var v => v -> Reference.Id -> DataDeclaration v a -> Names
dataDeclToNames = toNames CT.Data
dataDeclToNames :: Var v => (v -> Name.Name) -> v -> Reference.Id -> DataDeclaration v a -> Names
dataDeclToNames unsafeVarToName = toNames unsafeVarToName CT.Data
effectDeclToNames :: Var v => v -> Reference.Id -> EffectDeclaration v a -> Names
effectDeclToNames typeSymbol r ed = toNames CT.Effect typeSymbol r $ DD.toDataDecl ed
effectDeclToNames :: Var v => (v -> Name.Name) -> v -> Reference.Id -> EffectDeclaration v a -> Names
effectDeclToNames unsafeVarToName typeSymbol r ed = toNames unsafeVarToName CT.Effect typeSymbol r $ DD.toDataDecl ed
dataDeclToNames' :: Var v => (v, (Reference.Id, DataDeclaration v a)) -> Names
dataDeclToNames' (v, (r, d)) = dataDeclToNames v r d
dataDeclToNames' :: Var v => (v -> Name.Name) -> (v, (Reference.Id, DataDeclaration v a)) -> Names
dataDeclToNames' unsafeVarToName (v, (r, d)) = dataDeclToNames unsafeVarToName v r d
effectDeclToNames' :: Var v => (v, (Reference.Id, EffectDeclaration v a)) -> Names
effectDeclToNames' (v, (r, d)) = effectDeclToNames v r d
effectDeclToNames' :: Var v => (v -> Name.Name) -> (v, (Reference.Id, EffectDeclaration v a)) -> Names
effectDeclToNames' unsafeVarToName (v, (r, d)) = effectDeclToNames unsafeVarToName v r d
bindNames ::
Var v =>
(v -> Name.Name) ->
Set v ->
Names ->
DataDeclaration v a ->
Names.ResolutionResult v a (DataDeclaration v a)
bindNames keepFree names (DataDeclaration m a bound constructors) = do
bindNames unsafeVarToName keepFree names (DataDeclaration m a bound constructors) = do
constructors <- for constructors $ \(a, v, ty) ->
(a,v,) <$> Type.Names.bindNames keepFree names ty
(a,v,) <$> Type.Names.bindNames unsafeVarToName keepFree names ty
pure $ DataDeclaration m a bound constructors

54
unison-core/src/Unison/HashQualified'.hs
View File

@ -1,10 +1,6 @@
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE OverloadedStrings #-}
module Unison.HashQualified' where
import qualified Data.List as List
import qualified Data.Text as Text
import qualified Unison.HashQualified as HQ
import Unison.Name (Convert, Name, Parse)
@ -20,7 +16,7 @@ import qualified Unison.ShortHash as SH
import Prelude hiding (take)
data HashQualified n = NameOnly n | HashQualified n ShortHash
deriving (Eq, Functor, Generic, Foldable, Traversable)
deriving stock (Eq, Functor, Generic, Foldable, Ord, Traversable)
type HQSegment = HashQualified NameSegment
@ -48,8 +44,8 @@ toName = \case
NameOnly name -> name
HashQualified name _ -> name
nameLength :: HashQualified Name -> Int
nameLength = Text.length . toTextWith Name.toText
nameLength :: (Name -> Text) -> HashQualified Name -> Int
nameLength nameToText = Text.length . toTextWith nameToText
take :: Int -> HashQualified n -> HashQualified n
take i = \case
@ -70,22 +66,6 @@ toString = Text.unpack . toText
toStringWith :: (n -> String) -> HashQualified n -> String
toStringWith f = Text.unpack . toTextWith (Text.pack . f)
-- Parses possibly-hash-qualified into structured type.
fromText :: Text -> Maybe (HashQualified Name)
fromText t = case Text.breakOn "#" t of
(name, "") ->
Just $ NameOnly (Name.unsafeFromText name) -- safe bc breakOn #
(name, hash) ->
HashQualified (Name.unsafeFromText name) <$> SH.fromText hash
unsafeFromText :: Text -> HashQualified Name
unsafeFromText txt = fromMaybe msg (fromText txt)
where
msg = error ("HashQualified.unsafeFromText " <> show txt)
fromString :: String -> Maybe (HashQualified Name)
fromString = fromText . Text.pack
toText :: Show n => HashQualified n -> Text
toText =
toTextWith (Text.pack . show)
@ -122,6 +102,17 @@ requalify hq r = case hq of
NameOnly n -> fromNamedReferent n r
HashQualified n _ -> fromNamedReferent n r
-- | Sort alphabetically.
sortAlphabetically :: Name.Alphabetical n => [HashQualified n] -> [HashQualified n]
sortAlphabetically =
List.sortBy go
where
go (NameOnly n) (NameOnly n2) = Name.compareAlphabetical n n2
-- NameOnly comes first
go NameOnly {} HashQualified {} = LT
go HashQualified {} NameOnly {} = GT
go (HashQualified n sh) (HashQualified n2 sh2) = Name.compareAlphabetical n n2 <> compare sh sh2
-- | Sort the list of names by length of segments: smaller number of segments is listed first. NameOnly < HashQualified
sortByLength :: [HashQualified Name] -> [HashQualified Name]
sortByLength =
@ -129,18 +120,6 @@ sortByLength =
NameOnly name -> (length (Name.reverseSegments name), Nothing, Name.isAbsolute name)
HashQualified name hash -> (length (Name.reverseSegments name), Just hash, Name.isAbsolute name)
-- `HashQualified` is usually used for display, so we sort it alphabetically
instance Name.Alphabetical n => Ord (HashQualified n) where
compare (NameOnly n) (NameOnly n2) = Name.compareAlphabetical n n2
-- NameOnly comes first
compare NameOnly {} HashQualified {} = LT
compare HashQualified {} NameOnly {} = GT
compare (HashQualified n sh) (HashQualified n2 sh2) =
Name.compareAlphabetical n n2 <> compare sh sh2
instance IsString (HashQualified Name) where
fromString = unsafeFromText . Text.pack
instance Show n => Show (HashQualified n) where
show = Text.unpack . toText
@ -154,6 +133,3 @@ instance Convert (HashQualified n) (HQ.HashQualified n) where
instance Parse (HQ.HashQualified n) (HashQualified n) where
parse = fromHQ
instance Parse Text (HashQualified Name) where
parse = fromText

85
unison-core/src/Unison/HashQualified.hs
View File

@ -1,14 +1,10 @@
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE OverloadedStrings #-}
module Unison.HashQualified where
import qualified Data.List as List
import qualified Data.Text as Text
import Unison.ConstructorReference (ConstructorReference)
import qualified Unison.ConstructorReference as ConstructorReference
import Unison.Name (Convert, Name, Parse)
import Unison.Name (Convert, Name)
import qualified Unison.Name as Name
import Unison.Prelude hiding (fromString)
import Unison.Reference (Reference)
@ -17,25 +13,22 @@ import Unison.Referent (Referent)
import qualified Unison.Referent as Referent
import Unison.ShortHash (ShortHash)
import qualified Unison.ShortHash as SH
import Unison.Var (Var)
import qualified Unison.Var as Var
import Prelude hiding (take)
data HashQualified n
= NameOnly n
| HashOnly ShortHash
| HashQualified n ShortHash
deriving (Eq, Foldable, Traversable, Functor, Show, Generic)
deriving stock (Eq, Foldable, Ord, Traversable, Functor, Show, Generic)
stripNamespace :: Text -> HashQualified Name -> HashQualified Name
stripNamespace "" hq = hq
stripNamespace :: Name -> HashQualified Name -> HashQualified Name
stripNamespace namespace hq = case hq of
NameOnly name -> NameOnly $ strip name
HashQualified name sh -> HashQualified (strip name) sh
ho -> ho
where
strip name =
fromMaybe name $ Name.stripNamePrefix (Name.unsafeFromText namespace) name
fromMaybe name $ Name.stripNamePrefix namespace name
toName :: HashQualified n -> Maybe n
toName = \case
@ -43,6 +36,21 @@ toName = \case
HashQualified name _ -> Just name
HashOnly _ -> Nothing
-- | Ordered alphabetically, based on the name. Hashes come last.
sortAlphabetically :: Name.Alphabetical n => [HashQualified n] -> [HashQualified n]
sortAlphabetically =
List.sortBy \a b ->
case (toName a, toName b) of
(Just n, Just n2) -> Name.compareAlphabetical n n2
(Nothing, Just _) -> GT
(Just _, Nothing) -> LT
(Nothing, Nothing) -> EQ
<> case (toHash a, toHash b) of
(Nothing, Nothing) -> EQ
(Nothing, Just _) -> LT -- prefer NameOnly to HashQualified
(Just _, Nothing) -> GT
(Just sh, Just sh2) -> compare sh sh2
-- Sort the list of names by length of segments: smaller number of
-- segments is listed first. NameOnly < Hash qualified < Hash only
--
@ -91,30 +99,6 @@ toString = Text.unpack . toText
toStringWith :: (n -> String) -> HashQualified n -> String
toStringWith f = Text.unpack . toTextWith (Text.pack . f)
fromString :: String -> Maybe (HashQualified Name)
fromString = fromText . Text.pack
unsafeFromString :: String -> HashQualified Name
unsafeFromString s = fromMaybe msg . fromString $ s
where
msg = error $ "HashQualified.unsafeFromString " <> show s
-- Parses possibly-hash-qualified into structured type.
-- Doesn't validate against base58 or the codebase.
fromText :: Text -> Maybe (HashQualified Name)
fromText t = case Text.breakOn "#" t of -- breakOn leaves the '#' on the RHS
("", "") -> Nothing
(name, "") -> NameOnly <$> (Name.fromText name)
("", hash) -> HashOnly <$> SH.fromText hash
(name, hash) -> HashQualified <$> Name.fromText name <*> SH.fromText hash
-- Won't crash as long as SH.unsafeFromText doesn't crash on any input that
-- starts with '#', which is true as of the time of this writing, but not great.
unsafeFromText :: Text -> HashQualified Name
unsafeFromText txt = fromMaybe msg . fromText $ txt
where
msg = error $ "HashQualified.unsafeFromText " <> show txt
toText :: Show n => HashQualified n -> Text
toText =
toTextWith (Text.pack . show)
@ -145,15 +129,6 @@ fromPattern r = HashOnly $ ConstructorReference.toShortHash r
fromName :: n -> HashQualified n
fromName = NameOnly
unsafeFromVar :: Var v => v -> HashQualified Name
unsafeFromVar = unsafeFromText . Var.name
fromVar :: Var v => v -> Maybe (HashQualified Name)
fromVar = fromText . Var.name
toVar :: Var v => HashQualified Name -> v
toVar = Var.named . toTextWith Name.toText
-- todo: find this logic elsewhere and replace with call to this
matchesNamedReferent :: Name -> Referent -> HashQualified Name -> Bool
matchesNamedReferent n r = \case
@ -174,28 +149,8 @@ requalify hq r = case hq of
HashQualified n _ -> fromNamedReferent n r
HashOnly _ -> fromReferent r
-- Ordered alphabetically, based on the name. Hashes come last.
instance (Eq n, Name.Alphabetical n) => Ord (HashQualified n) where
compare a b =
case (toName a, toName b) of
(Just n, Just n2) -> Name.compareAlphabetical n n2
(Nothing, Just _) -> GT
(Just _, Nothing) -> LT
(Nothing, Nothing) -> EQ
<> case (toHash a, toHash b) of
(Nothing, Nothing) -> EQ
(Nothing, Just _) -> LT -- prefer NameOnly to HashQualified
(Just _, Nothing) -> GT
(Just sh, Just sh2) -> compare sh sh2
instance Convert n n2 => Convert (HashQualified n) (HashQualified n2) where
convert = fmap Name.convert
instance Convert n (HashQualified n) where
convert = NameOnly
instance Parse Text (HashQualified Name) where
parse = fromText
-- instance Show n => Show (HashQualified n) where
-- show = Text.unpack . toText

81
unison-core/src/Unison/Name.hs
View File

@ -9,13 +9,6 @@ module Unison.Name
fromSegment,
fromSegments,
fromReverseSegments,
fromText,
fromTextEither,
-- ** Unsafe construction
unsafeFromString,
unsafeFromText,
unsafeFromVar,
-- * Basic queries
countSegments,
@ -45,9 +38,6 @@ module Unison.Name
suffixFrom,
shortestUniqueSuffix,
commonPrefix,
toString,
toText,
toVar,
splits,
-- * Re-exports
@ -59,20 +49,15 @@ module Unison.Name
where
import Control.Lens (mapped, over, _1, _2)
import qualified Control.Lens as Lens
import qualified Data.List as List
import qualified Data.List.Extra as List
import Data.List.NonEmpty (NonEmpty ((:|)))
import qualified Data.List.NonEmpty as List (NonEmpty)
import qualified Data.List.NonEmpty as List.NonEmpty
import qualified Data.Map as Map
import qualified Data.RFC5051 as RFC5051
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified Data.Text.Lazy as Text.Lazy
import qualified Data.Text.Lazy.Builder as Text (Builder)
import qualified Data.Text.Lazy.Builder as Text.Builder
import Unison.Name.Internal (Name (..), fromTextEither, toText)
import Debug.RecoverRTTI (anythingToString)
import Unison.Name.Internal (Name (..))
import Unison.NameSegment (NameSegment (NameSegment))
import qualified Unison.NameSegment as NameSegment
import Unison.Position (Position (..))
@ -80,8 +65,6 @@ import Unison.Prelude
import Unison.Util.Alphabetical (Alphabetical, compareAlphabetical)
import qualified Unison.Util.List as List
import qualified Unison.Util.Relation as R
import Unison.Var (Var)
import qualified Unison.Var as Var
-- | @compareSuffix x y@ compares the suffix of @y@ (in reverse segment order) that is as long as @x@ to @x@ (in reverse
-- segment order).
@ -122,7 +105,11 @@ compareSuffix (Name _ ss0) =
cons :: HasCallStack => NameSegment -> Name -> Name
cons x name =
case name of
Name Absolute _ -> error (reportBug "E495986" ("cannot cons " ++ show x ++ " onto absolute name" ++ show name))
Name Absolute _ ->
error $
reportBug
"E495986"
("cannot cons " ++ anythingToString x ++ " onto absolute name" ++ anythingToString name)
Name Relative (y :| ys) -> Name Relative (y :| ys ++ [x])
-- | Return the number of name segments in a name.
@ -203,7 +190,12 @@ joinDot n1@(Name p0 ss0) n2@(Name p1 ss1) =
error $
reportBug
"E261635"
("joinDot: second name cannot be absolute. (name 1 = " ++ show n1 ++ ", name 2 = " ++ show n2 ++ ")")
( "joinDot: second name cannot be absolute. (name 1 = "
++ anythingToString n1
++ ", name 2 = "
++ anythingToString n2
++ ")"
)
-- | Make a name absolute. No-op if the name is already absolute.
--
@ -332,13 +324,13 @@ sortByText by as =
comp (_, s) (_, s2) = RFC5051.compareUnicode s s2
in fst <$> List.sortBy comp as'
sortNamed :: (a -> Name) -> [a] -> [a]
sortNamed f =
sortNamed :: (Name -> Text) -> (a -> Name) -> [a] -> [a]
sortNamed toText f =
sortByText (toText . f)
sortNames :: [Name] -> [Name]
sortNames =
sortNamed id
sortNames :: (Name -> Text) -> [Name] -> [Name]
sortNames toText =
sortNamed toText id
-- | Return all "splits" of a relative name, which pair a possibly-empty prefix of name segments with a suffix, such
-- that the original name is equivalent to @prefix + suffix@.
@ -442,16 +434,6 @@ suffixFrom (Name p0 ss0) (Name _ ss1) = do
then Just (prepend xs)
else go (prepend . (y :)) ys
-- | Convert a name to a string representation.
toString :: Name -> String
toString =
Text.unpack . toText
-- | Convert a name to a string representation, then parse that as a var.
toVar :: Var v => Name -> v
toVar =
Var.named . toText
-- | Drop all leading segments from a name, retaining only the last segment as a relative name.
--
-- >>> unqualified "a.b.c"
@ -515,20 +497,6 @@ commonPrefix x@(Name p1 _) y@(Name p2 _)
| a == b = a : commonPrefix' as bs
commonPrefix' _ _ = []
-- | Parse a name from a string literal.
--
-- Performs very minor validation (a name can't be empty, nor contain a '#' character [at least currently?]) but makes
-- no attempt at rejecting bogus names like "foo...bar...baz".
fromText :: Text -> Maybe Name
fromText = eitherToMaybe . fromTextEither
-- | Unsafely parse a name from a var, by first rendering the var as a string.
--
-- See 'unsafeFromText'.
unsafeFromVar :: Var v => v -> Name
unsafeFromVar =
unsafeFromText . Var.name
class Convert a b where
convert :: a -> b
@ -542,16 +510,3 @@ instance Parse Text NameSegment where
instance (Parse a a2, Parse b b2) => Parse (a, b) (a2, b2) where
parse (a, b) = (,) <$> parse a <*> parse b
instance Lens.Snoc Name Name NameSegment NameSegment where
_Snoc =
Lens.prism snoc unsnoc
where
snoc :: (Name, NameSegment) -> Name
snoc (Name p (x :| xs), y) =
Name p (y :| x : xs)
unsnoc :: Name -> Either Name (Name, NameSegment)
unsnoc name =
case name of
Name _ (_ :| []) -> Left name
Name p (x :| y : ys) -> Right (Name p (y :| ys), x)

85
unison-core/src/Unison/Name/Internal.hs
View File

@ -2,13 +2,10 @@
-- Name.
module Unison.Name.Internal
( Name (..),
toText,
fromTextEither,
unsafeFromString,
unsafeFromText,
)
where
import Control.Lens as Lens
import Data.List.NonEmpty (pattern (:|))
import qualified Data.List.NonEmpty as List (NonEmpty)
import qualified Data.Text as Text
@ -38,75 +35,19 @@ data Name
(List.NonEmpty NameSegment)
deriving stock (Eq, Generic)
instance Alphabetical Name where
compareAlphabetical n1 n2 =
compareAlphabetical (toText n1) (toText n2)
instance IsString Name where
fromString =
unsafeFromString
instance Ord Name where
compare (Name p0 ss0) (Name p1 ss1) =
compare ss0 ss1 <> compare p0 p1
instance Show Name where
show =
Text.unpack . toText
-- | Convert a name to a string representation.
toText :: Name -> Text
toText (Name pos (x0 :| xs)) =
build (buildPos pos <> foldr step mempty xs <> NameSegment.toTextBuilder x0)
where
step :: NameSegment -> Text.Builder -> Text.Builder
step x acc =
acc <> NameSegment.toTextBuilder x <> "."
build :: Text.Builder -> Text
build =
Text.Lazy.toStrict . Text.Builder.toLazyText
buildPos :: Position -> Text.Builder
buildPos = \case
Absolute -> "."
Relative -> ""
-- | Parse a name from a string literal.
--
-- Performs very minor validation (a name can't be empty, nor contain a '#' character [at least currently?]) but makes
-- no attempt at rejecting bogus names like "foo...bar...baz".
fromTextEither :: Text -> Either Text Name
fromTextEither = \case
"" -> Left "empty name"
"." -> Right $ Name Relative ("." :| [])
".." -> Right $ Name Absolute ("." :| [])
name
| Text.any (== '#') name -> Left ("not a name: " <> tShow name)
| Text.head name == '.' -> Name Absolute <$> (go (Text.tail name))
| otherwise -> Name Relative <$> go name
where
go :: Text -> Either Text (List.NonEmpty NameSegment)
go name =
if ".." `Text.isSuffixOf` name
then Right $ "." :| split (Text.dropEnd 2 name)
else case split name of
[] -> Left "empty name"
s : ss -> Right $ s :| ss
split :: Text -> [NameSegment]
split =
reverse . map NameSegment . Text.split (== '.')
-- | Unsafely parse a name from a string literal.
-- See 'unsafeFromText'.
unsafeFromString :: String -> Name
unsafeFromString =
unsafeFromText . Text.pack
-- | Unsafely parse a name from a string literal.
--
-- Performs very minor validation (a name can't be empty, nor contain a '#' character [at least currently?]) but makes
-- no attempt at rejecting bogus names like "foo...bar...baz".
unsafeFromText :: HasCallStack => Text -> Name
unsafeFromText = either (error . Text.unpack) id . fromTextEither
instance Lens.Snoc Name Name NameSegment NameSegment where
_Snoc =
Lens.prism snoc unsnoc
where
snoc :: (Name, NameSegment) -> Name
snoc (Name p (x :| xs), y) =
Name p (y :| x : xs)
unsnoc :: Name -> Either Name (Name, NameSegment)
unsnoc name =
case name of
Name _ (_ :| []) -> Left name
Name p (x :| y : ys) -> Right (Name p (y :| ys), x)

34
unison-core/src/Unison/Names.hs
View File

@ -1,11 +1,8 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
module Unison.Names
( Names (..),
showNames,
addTerm,
addType,
labeledReferences,
@ -94,14 +91,14 @@ instance Semigroup (Names) where
instance Monoid (Names) where
mempty = Names mempty mempty
instance Show (Names) where
show (Names terms types) =
"Terms:\n"
++ foldMap (\(n, r) -> " " ++ show n ++ " -> " ++ show r ++ "\n") (R.toList terms)
++ "\n"
++ "Types:\n"
++ foldMap (\(n, r) -> " " ++ show n ++ " -> " ++ show r ++ "\n") (R.toList types)
++ "\n"
showNames :: (Name -> String) -> Names -> String
showNames showName (Names terms types) =
"Terms:\n"
++ foldMap (\(n, r) -> " " ++ showName n ++ " -> " ++ show r ++ "\n") (R.toList terms)
++ "\n"
++ "Types:\n"
++ foldMap (\(n, r) -> " " ++ showName n ++ " -> " ++ show r ++ "\n") (R.toList types)
++ "\n"
isEmpty :: Names -> Bool
isEmpty n = R.null (terms n) && R.null (types n)
@ -121,12 +118,13 @@ makeRelative = map Name.makeRelative
-- Finds names that are supersequences of all the given strings, ordered by
-- score and grouped by name.
fuzzyFind ::
(Name -> Text) ->
[String] ->
Names ->
[(FZF.Alignment, Name, Set (Either Referent TypeReference))]
fuzzyFind query names =
fuzzyFind nameToText query names =
fmap flatten
. fuzzyFinds (Name.toString . fst) query
. fuzzyFinds (Text.unpack . nameToText . fst) query
. Prelude.filter prefilter
. Map.toList
-- `mapMonotonic` is safe here and saves a log n factor
@ -137,7 +135,7 @@ fuzzyFind query names =
-- For performance, case-insensitive substring matching as a pre-filter
-- This finds fewer matches than subsequence matching, but is
-- (currently) way faster even on large name sets.
prefilter (Name.toText -> name, _) = case lowerqueryt of
prefilter (nameToText -> name, _) = case lowerqueryt of
-- Special cases here just to help optimizer, since
-- not sure if `all` will get sufficiently unrolled for
-- Text fusion to work out.
@ -491,7 +489,11 @@ hashQualifyTermsRelation = hashQualifyRelation HQ.fromNamedReferent
hashQualifyTypesRelation :: R.Relation Name TypeReference -> R.Relation (HQ.HashQualified Name) TypeReference
hashQualifyTypesRelation = hashQualifyRelation HQ.fromNamedReference
hashQualifyRelation :: Ord r => (Name -> r -> HQ.HashQualified Name) -> R.Relation Name r -> R.Relation (HQ.HashQualified Name) r
hashQualifyRelation ::
Ord r =>
(Name -> r -> HQ.HashQualified Name) ->
R.Relation Name r ->
R.Relation (HQ.HashQualified Name) r
hashQualifyRelation fromNamedRef rel = R.map go rel
where
go (n, r) =

9
unison-core/src/Unison/Names/ResolutionResult.hs
View File

@ -1,8 +1,3 @@
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
module Unison.Names.ResolutionResult where
import Data.Set.NonEmpty
@ -16,13 +11,13 @@ data ResolutionError ref
| -- Contains the names which were in scope and which refs were possible options
-- The NonEmpty set of refs must contain 2 or more refs (otherwise what is ambiguous?).
Ambiguous Names (NESet ref)
deriving (Eq, Ord, Show)
deriving (Eq, Ord)
-- | ResolutionFailure represents the failure to resolve a given variable.
data ResolutionFailure var annotation
= TypeResolutionFailure var annotation (ResolutionError Reference)
| TermResolutionFailure var annotation (ResolutionError Referent)
deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
deriving (Eq, Ord, Functor, Foldable, Traversable)
getAnnotation :: ResolutionFailure v a -> a
getAnnotation = \case

2
unison-core/src/Unison/NamesWithHistory.hs
View File

@ -34,7 +34,6 @@ data NamesWithHistory = NamesWithHistory
-- context to users rather than just a hash.
oldNames :: Names.Names
}
deriving (Show)
instance Semigroup NamesWithHistory where
NamesWithHistory cur1 old1 <> NamesWithHistory cur2 old2 =
@ -71,7 +70,6 @@ data Diff = Diff
addedNames :: Names,
removedNames :: Names
}
deriving (Show)
-- Add `n1` to `currentNames`, shadowing anything with the same name and
-- moving shadowed definitions into `oldNames` so they can can still be

20
unison-core/src/Unison/Term.hs
View File

@ -1,13 +1,5 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE UnicodeSyntax #-}
{-# LANGUAGE ViewPatterns #-}
module Unison.Term where
@ -149,11 +141,12 @@ type Term0' vt v = Term' vt v ()
bindNames ::
forall v a.
Var v =>
(v -> Name.Name) ->
Set v ->
Names ->
Term v a ->
Names.ResolutionResult v a (Term v a)
bindNames keepFreeTerms ns0 e = do
bindNames unsafeVarToName keepFreeTerms ns0 e = do
let freeTmVars = [(v, a) | (v, a) <- ABT.freeVarOccurrences keepFreeTerms e]
-- !_ = trace "bindNames.free term vars: " ()
-- !_ = traceShow $ fst <$> freeTmVars
@ -164,14 +157,14 @@ bindNames keepFreeTerms ns0 e = do
-- !_ = trace "bindNames.free type vars: " ()
-- !_ = traceShow $ fst <$> freeTyVars
okTm :: (v, a) -> Names.ResolutionResult v a (v, Term v a)
okTm (v, a) = case Names.lookupHQTerm (Name.convert $ Name.unsafeFromVar v) ns of
okTm (v, a) = case Names.lookupHQTerm (Name.convert $ unsafeVarToName v) ns of
rs
| Set.size rs == 1 ->
pure (v, fromReferent a $ Set.findMin rs)
| otherwise -> case NES.nonEmptySet rs of
Nothing -> Left (pure (Names.TermResolutionFailure v a Names.NotFound))
Just refs -> Left (pure (Names.TermResolutionFailure v a (Names.Ambiguous ns0 refs)))
okTy (v, a) = case Names.lookupHQType (Name.convert $ Name.unsafeFromVar v) ns of
okTy (v, a) = case Names.lookupHQType (Name.convert $ unsafeVarToName v) ns of
rs
| Set.size rs == 1 -> pure (v, Type.ref a $ Set.findMin rs)
| otherwise -> case NES.nonEmptySet rs of
@ -187,6 +180,7 @@ bindNames keepFreeTerms ns0 e = do
bindSomeNames ::
forall v a.
Var v =>
(v -> Name.Name) ->
Set v ->
Names ->
Term v a ->
@ -200,7 +194,7 @@ bindSomeNames ::
-- || traceShow (freeVars e) False
-- || traceShow e False
-- = undefined
bindSomeNames avoid ns e = bindNames (avoid <> varsToTDNR) ns e
bindSomeNames unsafeVarToName avoid ns e = bindNames unsafeVarToName (avoid <> varsToTDNR) ns e
where
-- `Term.bindNames` takes a set of variables that are not substituted.
-- These should be the variables that will be subject to TDNR, which
@ -211,7 +205,7 @@ bindSomeNames avoid ns e = bindNames (avoid <> varsToTDNR) ns e
-- (if a free variable is being used as a typed hole).
varsToTDNR = Set.filter notFound (freeVars e)
notFound var =
Set.size (Name.searchByRankedSuffix (Name.unsafeFromVar var) (Names.terms ns)) /= 1
Set.size (Name.searchByRankedSuffix (unsafeVarToName var) (Names.terms ns)) /= 1
-- Prepare a term for type-directed name resolution by replacing
-- any remaining free variables with blanks to be resolved by TDNR

12
unison-core/src/Unison/Type.hs
View File

@ -1,11 +1,4 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
module Unison.Type where
@ -67,13 +60,14 @@ bindExternal bs = ABT.substsInheritAnnotation [(v, ref () r) | (v, r) <- bs]
bindReferences ::
Var v =>
(v -> Name.Name) ->
Set v ->
Map Name.Name Reference ->
Type v a ->
Names.ResolutionResult v a (Type v a)
bindReferences keepFree ns t =
bindReferences unsafeVarToName keepFree ns t =
let fvs = ABT.freeVarOccurrences keepFree t
rs = [(v, a, Map.lookup (Name.unsafeFromVar v) ns) | (v, a) <- fvs]
rs = [(v, a, Map.lookup (unsafeVarToName v) ns) | (v, a) <- fvs]
ok (v, _a, Just r) = pure (v, r)
ok (v, a, Nothing) = Left (pure (Names.TypeResolutionFailure v a Names.NotFound))
in List.validate ok rs <&> \es -> bindExternal es t

12
unison-core/src/Unison/Type/Names.hs
View File

@ -1,10 +1,3 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ViewPatterns #-}
module Unison.Type.Names where
import qualified Data.Set as Set
@ -21,14 +14,15 @@ import Unison.Var (Var)
bindNames ::
Var v =>
(v -> Name.Name) ->
Set v ->
Names.Names ->
Type v a ->
Names.ResolutionResult v a (Type v a)
bindNames keepFree ns0 t =
bindNames unsafeVarToName keepFree ns0 t =
let ns = Names.NamesWithHistory ns0 mempty
fvs = ABT.freeVarOccurrences keepFree t
rs = [(v, a, Names.lookupHQType (Name.convert $ Name.unsafeFromVar v) ns) | (v, a) <- fvs]
rs = [(v, a, Names.lookupHQType (Name.convert $ unsafeVarToName v) ns) | (v, a) <- fvs]
ok (v, a, rs) =
if Set.size rs == 1
then pure (v, Set.findMin rs)

5
unison-core/unison-core1.cabal
View File

@ -65,8 +65,11 @@ library
default-extensions:
ApplicativeDo
BlockArguments
DeriveAnyClass
DeriveFoldable
DeriveFunctor
DeriveGeneric
DeriveTraversable
DerivingStrategies
DoAndIfThenElse
FlexibleContexts
@ -77,6 +80,7 @@ library
NamedFieldPuns
OverloadedStrings
PatternSynonyms
RankNTypes
ScopedTypeVariables
TupleSections
TypeApplications
@ -96,6 +100,7 @@ library
, mtl
, nonempty-containers
, prelude-extras
, recover-rtti
, rfc5051
, safe
, text

18
unison-hashing-v2/src/Unison/Hashing/V2/DataDeclaration.hs
View File

@ -1,10 +1,4 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
module Unison.Hashing.V2.DataDeclaration
( DataDeclaration (..),
@ -84,30 +78,32 @@ hashDecls0 decls =
-- affect the hash.
hashDecls ::
(Eq v, Var v, Show v) =>
(v -> Name.Name) ->
Map v (DataDeclaration v a) ->
Names.ResolutionResult v a [(v, Reference.Id, DataDeclaration v a)]
hashDecls decls = do
hashDecls unsafeVarToName decls = do
-- todo: make sure all other external references are resolved before calling this
let varToRef = hashDecls0 (void <$> decls)
varToRef' = second Reference.DerivedId <$> varToRef
decls' = bindTypes <$> decls
bindTypes dd = dd {constructors' = over _3 (Type.bindExternal varToRef') <$> constructors' dd}
typeReferences = Map.fromList (first Name.unsafeFromVar <$> varToRef')
typeReferences = Map.fromList (first unsafeVarToName <$> varToRef')
-- normalize the order of the constructors based on a hash of their types
sortCtors dd = dd {constructors' = sortOn hash3 $ constructors' dd}
hash3 (_, _, typ) = ABT.hash typ :: Hash
decls' <- fmap sortCtors <$> traverse (bindReferences mempty typeReferences) decls'
decls' <- fmap sortCtors <$> traverse (bindReferences unsafeVarToName mempty typeReferences) decls'
pure [(v, r, dd) | (v, r) <- varToRef, Just dd <- [Map.lookup v decls']]
bindReferences ::
Var v =>
(v -> Name.Name) ->
Set v ->
Map Name.Name Reference ->
DataDeclaration v a ->
Names.ResolutionResult v a (DataDeclaration v a)
bindReferences keepFree names (DataDeclaration m a bound constructors) = do
bindReferences unsafeVarToName keepFree names (DataDeclaration m a bound constructors) = do
constructors <- for constructors $ \(a, v, ty) ->
(a,v,) <$> Type.bindReferences keepFree names ty
(a,v,) <$> Type.bindReferences unsafeVarToName keepFree names ty
pure $ DataDeclaration m a bound constructors
data F a

12
unison-hashing-v2/src/Unison/Hashing/V2/Type.hs
View File

@ -1,10 +1,3 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ViewPatterns #-}
module Unison.Hashing.V2.Type
( Type,
F (..),
@ -68,13 +61,14 @@ bindExternal bs = ABT.substsInheritAnnotation [(v, ref () r) | (v, r) <- bs]
bindReferences ::
Var v =>
(v -> Name.Name) ->
Set v ->
Map Name.Name Reference ->
Type v a ->
Names.ResolutionResult v a (Type v a)
bindReferences keepFree ns t =
bindReferences unsafeVarToName keepFree ns t =
let fvs = ABT.freeVarOccurrences keepFree t
rs = [(v, a, Map.lookup (Name.unsafeFromVar v) ns) | (v, a) <- fvs]
rs = [(v, a, Map.lookup (unsafeVarToName v) ns) | (v, a) <- fvs]
ok (v, _a, Just r) = pure (v, r)
ok (v, a, Nothing) = Left (pure (Names.TypeResolutionFailure v a Names.NotFound))
in List.validate ok rs <&> \es -> bindExternal es t

6
unison-share-api/src/Unison/Server/Backend.hs
View File

@ -59,9 +59,6 @@ import qualified Unison.HashQualified as HQ
import qualified Unison.HashQualified' as HQ'
import qualified Unison.Hashing.V2.Convert as Hashing
import Unison.Name (Name)
import Unison.Name as Name
( unsafeFromText,
)
import qualified Unison.Name as Name
import Unison.NameSegment (NameSegment (..))
import qualified Unison.NameSegment as NameSegment
@ -92,6 +89,7 @@ import Unison.ShortHash
import qualified Unison.ShortHash as SH
import Unison.Symbol (Symbol)
import qualified Unison.Syntax.DeclPrinter as DeclPrinter
import Unison.Syntax.Name as Name (toText, unsafeFromText)
import qualified Unison.Syntax.NamePrinter as NP
import qualified Unison.Syntax.TermPrinter as TermPrinter
import qualified Unison.Syntax.TypePrinter as TypePrinter
@ -308,7 +306,7 @@ fuzzyFind ::
[(FZF.Alignment, UnisonName, [FoundRef])]
fuzzyFind printNames query =
let fzfNames =
Names.fuzzyFind (words query) printNames
Names.fuzzyFind Name.toText (words query) printNames
toFoundRef =
fmap (fmap (either FoundTermRef FoundTypeRef) . toList)

5
unison-share-api/src/Unison/Server/Doc/AsHtml.hs
View File

@ -1,6 +1,3 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | Render Unison.Server.Doc and embedded source to Html
module Unison.Server.Doc.AsHtml where
@ -14,6 +11,7 @@ import qualified Data.Char as Char
import Data.Foldable
import Data.Map (Map)
import qualified Data.Map as Map
import qualified Unison.Syntax.Name as Name (toText)
import Data.Maybe
import Data.Sequence (Seq)
import Data.Text (Text)
@ -23,7 +21,6 @@ import qualified Lucid as L
import qualified Lucid.Base as LB
import Unison.Codebase.Editor.DisplayObject (DisplayObject (..))
import Unison.Name (Name)
import qualified Unison.Name as Name
import Unison.Referent (Referent)
import qualified Unison.Referent as Referent
import Unison.Server.Doc

7
unison-share-api/src/Unison/Server/Orphans.hs
View File

@ -21,9 +21,7 @@ import qualified U.Util.Hash as Hash
import Unison.Codebase.Editor.DisplayObject
import qualified Unison.Codebase.Path as Path
import qualified Unison.Codebase.Path.Parse as Path
import Unison.Codebase.ShortBranchHash
( ShortBranchHash (..),
)
import Unison.Codebase.ShortBranchHash (ShortBranchHash (..))
import qualified Unison.Codebase.ShortBranchHash as SBH
import Unison.ConstructorType (ConstructorType)
import qualified Unison.HashQualified as HQ
@ -36,6 +34,9 @@ import qualified Unison.Reference as Reference
import qualified Unison.Referent as Referent
import Unison.ShortHash (ShortHash)
import qualified Unison.ShortHash as SH
import qualified Unison.Syntax.HashQualified as HQ (fromText)
import qualified Unison.Syntax.HashQualified' as HQ' (fromText)
import qualified Unison.Syntax.Name as Name (fromTextEither, toText)
import Unison.Util.Pretty (Width (..))
instance ToJSON Hash where

6
unison-share-api/src/Unison/Server/SearchResult'.hs
View File

@ -21,7 +21,7 @@ import qualified Unison.Type as Type
data SearchResult' v a
= Tm' (TermResult' v a)
| Tp' (TypeResult' v a)
deriving (Eq, Show)
deriving (Eq)
data TermResult' v a
= TermResult'
@ -29,7 +29,7 @@ data TermResult' v a
(Maybe (Type v a))
Referent
(Set (HQ'.HashQualified Name))
deriving (Eq, Show)
deriving (Eq)
data TypeResult' v a
= TypeResult'
@ -37,7 +37,7 @@ data TypeResult' v a
(DisplayObject () (Decl v a))
Reference
(Set (HQ'.HashQualified Name))
deriving (Eq, Show)
deriving (Eq)
pattern Tm :: HQ.HashQualified Name
-> Maybe (Type v a)

6
unison-share-api/src/Unison/Server/SearchResult.hs
View File

@ -12,21 +12,21 @@ import Unison.Referent (Referent)
import qualified Unison.Referent as Referent
import qualified Unison.Util.Relation as R
data SearchResult = Tp TypeResult | Tm TermResult deriving (Eq, Ord, Show)
data SearchResult = Tp TypeResult | Tm TermResult deriving (Eq, Ord)
data TermResult = TermResult
{ termName :: HashQualified Name,
referent :: Referent,
termAliases :: Set (HQ'.HashQualified Name)
}
deriving (Eq, Ord, Show)
deriving (Eq, Ord)
data TypeResult = TypeResult
{ typeName :: HashQualified Name,
reference :: Reference,
typeAliases :: Set (HQ'.HashQualified Name)
}
deriving (Eq, Ord, Show)
deriving (Eq, Ord)
pattern Tm' :: HashQualified Name -> Referent -> Set (HQ'.HashQualified Name) -> SearchResult
pattern Tm' hq r as = Tm (TermResult hq r as)

1
unison-share-api/src/Unison/Server/Syntax.hs
View File

@ -28,6 +28,7 @@ import Unison.Prelude
import Unison.Reference (Reference)
import qualified Unison.Reference as Reference
import qualified Unison.Referent as Referent
import qualified Unison.Syntax.Name as Name (unsafeFromText)
import Unison.Util.AnnotatedText
( AnnotatedText (..),
Segment (..),

1
unison-share-api/src/Unison/Server/Types.hs
View File

@ -55,6 +55,7 @@ import Unison.Server.Doc (Doc)
import Unison.Server.Orphans ()
import Unison.Server.Syntax (SyntaxText)
import Unison.ShortHash (ShortHash)
import qualified Unison.Syntax.HashQualified as HQ (fromText)
import Unison.Util.Pretty (Width (..))
type APIHeaders x =

3
unison-share-api/src/Unison/Util/Find.hs
View File

@ -1,5 +1,3 @@
{-# LANGUAGE ViewPatterns #-}
module Unison.Util.Find
( fuzzyFinder,
simpleFuzzyFinder,
@ -29,6 +27,7 @@ import qualified Unison.Referent as Referent
import Unison.Server.SearchResult (SearchResult)
import qualified Unison.Server.SearchResult as SR
import qualified Unison.ShortHash as SH
import qualified Unison.Syntax.Name as Name (toString)
import Unison.Syntax.NamePrinter (prettyHashQualified)
import Unison.Util.Monoid (intercalateMap)
import qualified Unison.Util.Pretty as P

38
unison-syntax/src/Unison/Syntax/HashQualified'.hs Normal file
View File

@ -0,0 +1,38 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | Syntax-related combinators for HashQualified' (to/from string types).
module Unison.Syntax.HashQualified'
( fromString,
fromText,
unsafeFromText,
)
where
import qualified Data.Text as Text
import Unison.HashQualified' (HashQualified (..))
import Unison.Name (Name, Parse)
import qualified Unison.Name as Name
import Unison.Prelude hiding (fromString)
import qualified Unison.Prelude
import qualified Unison.ShortHash as SH
import qualified Unison.Syntax.Name as Name (unsafeFromText)
instance IsString (HashQualified Name) where
fromString = unsafeFromText . Text.pack
instance Parse Text (HashQualified Name) where
parse = fromText
fromString :: String -> Maybe (HashQualified Name)
fromString = fromText . Text.pack
-- Parses possibly-hash-qualified into structured type.
fromText :: Text -> Maybe (HashQualified Name)
fromText t = case Text.breakOn "#" t of
(name, "") -> Just $ NameOnly (Name.unsafeFromText name) -- safe bc breakOn #
(name, hash) -> HashQualified (Name.unsafeFromText name) <$> SH.fromText hash
unsafeFromText :: HasCallStack => Text -> HashQualified Name
unsafeFromText txt = fromMaybe msg (fromText txt)
where
msg = error ("HashQualified.unsafeFromText " <> show txt)

57
unison-syntax/src/Unison/Syntax/HashQualified.hs Normal file
View File

@ -0,0 +1,57 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | Syntax-related combinators for HashQualified (to/from string types).
module Unison.Syntax.HashQualified
( fromString,
fromText,
unsafeFromString,
unsafeFromText,
unsafeFromVar,
toVar,
)
where
import qualified Data.Text as Text
import Unison.HashQualified (HashQualified (..))
import qualified Unison.HashQualified as HashQualified
import Unison.Name (Name, Parse)
import qualified Unison.Name as Name
import Unison.Prelude hiding (fromString)
import qualified Unison.ShortHash as SH
import qualified Unison.Syntax.Name as Name (fromText, toText)
import Unison.Var (Var)
import qualified Unison.Var as Var
import Prelude hiding (take)
instance Parse Text (HashQualified Name) where
parse = fromText
fromString :: String -> Maybe (HashQualified Name)
fromString = fromText . Text.pack
-- Parses possibly-hash-qualified into structured type.
-- Doesn't validate against base58 or the codebase.
fromText :: Text -> Maybe (HashQualified Name)
fromText t = case Text.breakOn "#" t of -- breakOn leaves the '#' on the RHS
("", "") -> Nothing
(name, "") -> NameOnly <$> Name.fromText name
("", hash) -> HashOnly <$> SH.fromText hash
(name, hash) -> HashQualified <$> Name.fromText name <*> SH.fromText hash
unsafeFromString :: String -> HashQualified Name
unsafeFromString s = fromMaybe msg . fromString $ s
where
msg = error $ "HashQualified.unsafeFromString " <> show s
-- Won't crash as long as SH.unsafeFromText doesn't crash on any input that
-- starts with '#', which is true as of the time of this writing, but not great.
unsafeFromText :: Text -> HashQualified Name
unsafeFromText txt = fromMaybe msg . fromText $ txt
where
msg = error $ "HashQualified.unsafeFromText " <> show txt
unsafeFromVar :: Var v => v -> HashQualified Name
unsafeFromVar = unsafeFromText . Var.name
toVar :: Var v => HashQualified Name -> v
toVar = Var.named . HashQualified.toTextWith Name.toText

122
unison-syntax/src/Unison/Syntax/Name.hs Normal file
View File

@ -0,0 +1,122 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | Syntax-related combinators for Name (to/from string types).
module Unison.Syntax.Name
( fromText,
fromTextEither,
unsafeFromString,
unsafeFromText,
unsafeFromVar,
toString,
toText,
toVar,
)
where
import Data.List.NonEmpty (pattern (:|))
import qualified Data.List.NonEmpty as List (NonEmpty)
import qualified Data.Text as Text
import qualified Data.Text.Lazy as Text.Lazy
import qualified Data.Text.Lazy.Builder as Text (Builder)
import qualified Data.Text.Lazy.Builder as Text.Builder
import Unison.Name.Internal (Name (Name))
import Unison.NameSegment (NameSegment (NameSegment))
import qualified Unison.NameSegment as NameSegment
import Unison.Position (Position (..))
import Unison.Prelude
import Unison.Util.Alphabetical (Alphabetical, compareAlphabetical)
import Unison.Var (Var)
import qualified Unison.Var as Var
instance Alphabetical Name where
compareAlphabetical n1 n2 =
compareAlphabetical (toText n1) (toText n2)
instance IsString Name where
fromString =
unsafeFromString
instance Show Name where
show =
Text.unpack . toText
-- | Convert a name to a string representation.
toString :: Name -> String
toString =
Text.unpack . toText
-- | Convert a name to a string representation.
toText :: Name -> Text
toText (Name pos (x0 :| xs)) =
build (buildPos pos <> foldr step mempty xs <> NameSegment.toTextBuilder x0)
where
step :: NameSegment -> Text.Builder -> Text.Builder
step x acc =
acc <> NameSegment.toTextBuilder x <> "."
build :: Text.Builder -> Text
build =
Text.Lazy.toStrict . Text.Builder.toLazyText
buildPos :: Position -> Text.Builder
buildPos = \case
Absolute -> "."
Relative -> ""
-- | Convert a name to a string representation, then parse that as a var.
toVar :: Var v => Name -> v
toVar =
Var.named . toText
-- | Parse a name from a string literal.
--
-- Performs very minor validation (a name can't be empty, nor contain a '#' character [at least currently?]) but makes
-- no attempt at rejecting bogus names like "foo...bar...baz".
fromText :: Text -> Maybe Name
fromText = eitherToMaybe . fromTextEither
-- | Parse a name from a string literal.
--
-- Performs very minor validation (a name can't be empty, nor contain a '#' character [at least currently?]) but makes
-- no attempt at rejecting bogus names like "foo...bar...baz".
fromTextEither :: Text -> Either Text Name
fromTextEither = \case
"" -> Left "empty name"
"." -> Right $ Name Relative ("." :| [])
".." -> Right $ Name Absolute ("." :| [])
name
| Text.any (== '#') name -> Left ("not a name: " <> tShow name)
| Text.head name == '.' -> Name Absolute <$> (go (Text.tail name))
| otherwise -> Name Relative <$> go name
where
go :: Text -> Either Text (List.NonEmpty NameSegment)
go name =
if ".." `Text.isSuffixOf` name
then Right $ "." :| split (Text.dropEnd 2 name)
else case split name of
[] -> Left "empty name"
s : ss -> Right $ s :| ss
split :: Text -> [NameSegment]
split =
reverse . map NameSegment . Text.split (== '.')
-- | Unsafely parse a name from a string literal.
-- See 'unsafeFromText'.
unsafeFromString :: String -> Name
unsafeFromString =
unsafeFromText . Text.pack
-- | Unsafely parse a name from a string literal.
--
-- Performs very minor validation (a name can't be empty, nor contain a '#' character [at least currently?]) but makes
-- no attempt at rejecting bogus names like "foo...bar...baz".
unsafeFromText :: HasCallStack => Text -> Name
unsafeFromText = either (error . Text.unpack) id . fromTextEither
-- | Unsafely parse a name from a var, by first rendering the var as a string.
--
-- See 'unsafeFromText'.
unsafeFromVar :: Var v => v -> Name
unsafeFromVar =
unsafeFromText . Var.name

11
unison-syntax/src/Unison/Syntax/Parser.hs
View File

@ -1,14 +1,10 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
-- pTrace
{-# OPTIONS_GHC -Wno-deprecations #-}
module Unison.Syntax.Parser where
import Control.Monad.Reader.Class (asks)
import qualified Unison.Syntax.Name as Name (unsafeFromString)
import qualified Crypto.Random as Random
import Data.Bytes.Put (runPutS)
import Data.Bytes.Serial (serialize)
@ -126,10 +122,7 @@ data Error v
| DuplicateTermNames [(v, [Ann])]
| PatternArityMismatch Int Int Ann -- PatternArityMismatch expectedArity actualArity location
| FloatPattern Ann
deriving (Show, Eq, Ord)
instance (Ord v, Show v) => ShowErrorComponent (Error v) where
showErrorComponent e = show e
deriving stock (Eq, Ord)
tokenToPair :: L.Token a -> (Ann, a)
tokenToPair t = (ann t, L.payload t)

3
unison-syntax/unison-syntax.cabal
View File

@ -18,7 +18,10 @@ source-repository head
library
exposed-modules:
Unison.Parser.Ann
Unison.Syntax.HashQualified
Unison.Syntax.HashQualified'
Unison.Syntax.Lexer
Unison.Syntax.Name
Unison.Syntax.Parser
Unison.UnisonFile.Error
hs-source-dirs: