mirror of
https://github.com/unisonweb/unison.git
synced 2024-09-11 10:35:57 +03:00
Move name parsing/printing functions from Unison.Name to Unison.Syntax.Name
This commit is contained in:
parent
5245683d9e
commit
ed77121949
@ -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 =
|
||||
|
@ -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
|
||||
|
@ -78,6 +78,7 @@ dependencies:
|
||||
- process
|
||||
- random >= 1.2.0
|
||||
- raw-strings-qq
|
||||
- recover-rtti
|
||||
- regex-base
|
||||
- regex-tdfa
|
||||
- safe
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
@ -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)
|
||||
|
@ -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"]
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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.
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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]
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
@ -54,6 +54,7 @@ dependencies:
|
||||
- open-browser
|
||||
- pretty-simple
|
||||
- random >= 1.2.0
|
||||
- recover-rtti
|
||||
- regex-tdfa
|
||||
- semialign
|
||||
- servant
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
@ -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 _ ->
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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 {..} =
|
||||
|
@ -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
|
||||
|
@ -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"
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
--
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
@ -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)
|
||||
|
@ -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) =
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
@ -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)
|
||||
|
@ -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 (..),
|
||||
|
@ -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 =
|
||||
|
@ -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
38
unison-syntax/src/Unison/Syntax/HashQualified'.hs
Normal 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
57
unison-syntax/src/Unison/Syntax/HashQualified.hs
Normal 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
122
unison-syntax/src/Unison/Syntax/Name.hs
Normal 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
|
@ -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)
|
||||
|
@ -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:
|
||||
|
Loading…
Reference in New Issue
Block a user