unisonweb/unison
1
0
Fork 0
mirror of https://github.com/unisonweb/unison.git synced 2024-09-21 07:17:25 +03:00
Code Issues Projects Releases Wiki Activity

Merge pull request #2621 from unisonweb/21-11-10-reftypes

Browse Source 
Add TermReference, TypeReference, ConstructorReference
This commit is contained in:
Mitchell Rosen 2021-11-22 17:01:35 -05:00 committed by GitHub
commit dc2e9751ef
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
48 changed files with 551 additions and 463 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -28,6 +28,7 @@ import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified Text.Regex.TDFA as RE
import Unison.ConstructorReference (GConstructorReference(..))
import qualified Unison.ConstructorType as CT
import Unison.Codebase.CodeLookup ( CodeLookup(..) )
import qualified Unison.Builtin.Decls as DD
@ -58,7 +59,7 @@ names = NamesWithHistory names0 mempty
names0 :: Names
names0 = Names terms types where
terms = Rel.mapRan Referent.Ref (Rel.fromMap termNameRefs) <>
Rel.fromList [ (Name.unsafeFromVar vc, Referent.Con (R.DerivedId r) cid ct)
Rel.fromList [ (Name.unsafeFromVar vc, Referent.Con (ConstructorReference (R.DerivedId r) cid) ct)
| (ct, (_,(r,decl))) <- ((CT.Data,) <$> builtinDataDecls @Symbol) <>
((CT.Effect,) . (second . second) DD.toDataDecl <$> builtinEffectDecls)
, ((_,vc,_), cid) <- DD.constructors' decl `zip` [0..]] <>

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

@ -9,6 +9,7 @@ import Data.List (elemIndex, find)
import qualified Data.Map as Map
import Data.Text (Text, unpack)
import qualified Unison.ABT as ABT
import Unison.ConstructorReference (GConstructorReference(..))
import qualified Unison.ConstructorType as CT
import Unison.DataDeclaration
( DataDeclaration (..),
@ -76,8 +77,8 @@ seekModeRef = lookupDeclRef "io2.SeekMode"
seqViewRef = lookupDeclRef "SeqView"
pairCtorRef, unitCtorRef :: Referent
pairCtorRef = Referent.Con pairRef 0 CT.Data
unitCtorRef = Referent.Con unitRef 0 CT.Data
pairCtorRef = Referent.Con (ConstructorReference pairRef 0) CT.Data
unitCtorRef = Referent.Con (ConstructorReference unitRef 0) CT.Data
constructorId :: Reference -> Text -> Maybe Int
constructorId ref name = do
@ -112,8 +113,8 @@ Just bufferModeBlockBufferingId = constructorId bufferModeRef "io2.BufferMode.Bl
Just bufferModeSizedBlockBufferingId = constructorId bufferModeRef "io2.BufferMode.SizedBlockBuffering"
okConstructorReferent, failConstructorReferent :: Referent.Referent
okConstructorReferent = Referent.Con testResultRef okConstructorId CT.Data
failConstructorReferent = Referent.Con testResultRef failConstructorId CT.Data
okConstructorReferent = Referent.Con (ConstructorReference testResultRef okConstructorId) CT.Data
failConstructorReferent = Referent.Con (ConstructorReference testResultRef failConstructorId) CT.Data
-- | parse some builtin data types, and resolve their free variables using
-- | builtinTypes' and those types defined herein
@ -328,8 +329,8 @@ pattern UnitRef <- (unUnitRef -> True)
pattern PairRef <- (unPairRef -> True)
pattern EitherRef <- ((==) eitherRef -> True)
pattern OptionalRef <- (unOptionalRef -> True)
pattern OptionalNone' <- Term.Constructor' OptionalRef ((==) noneId -> True)
pattern OptionalSome' d <- Term.App' (Term.Constructor' OptionalRef ((==) someId -> True)) d
pattern OptionalNone' <- Term.Constructor' (ConstructorReference OptionalRef ((==) noneId -> True))
pattern OptionalSome' d <- Term.App' (Term.Constructor' (ConstructorReference OptionalRef ((==) someId -> True))) d
pattern TupleType' ts <- (unTupleType -> Just ts)
pattern TupleTerm' xs <- (unTupleTerm -> Just xs)
pattern TuplePattern ps <- (unTuplePattern -> Just ps)
@ -342,23 +343,23 @@ unLeftTerm, unRightTerm
:: Term.Term2 vt at ap v a
-> Maybe (Term.Term2 vt at ap v a)
unRightTerm t = case t of
Term.App' (Term.Constructor' EitherRef EitherRightId) tm ->
Term.App' (Term.Constructor' (ConstructorReference EitherRef EitherRightId)) tm ->
Just tm
_ -> Nothing
unLeftTerm t = case t of
Term.App' (Term.Constructor' EitherRef EitherLeftId) tm ->
Term.App' (Term.Constructor' (ConstructorReference EitherRef EitherLeftId)) tm ->
Just tm
_ -> Nothing
-- some pattern synonyms to make pattern matching on some of these constants more pleasant
pattern DocRef <- ((== docRef) -> True)
pattern DocJoin segs <- Term.App' (Term.Constructor' DocRef DocJoinId) (Term.List' segs)
pattern DocBlob txt <- Term.App' (Term.Constructor' DocRef DocBlobId) (Term.Text' txt)
pattern DocLink link <- Term.App' (Term.Constructor' DocRef DocLinkId) link
pattern DocSource link <- Term.App' (Term.Constructor' DocRef DocSourceId) link
pattern DocSignature link <- Term.App' (Term.Constructor' DocRef DocSignatureId) link
pattern DocEvaluate link <- Term.App' (Term.Constructor' DocRef DocEvaluateId) link
pattern Doc <- Term.App' (Term.Constructor' DocRef _) _
pattern DocJoin segs <- Term.App' (Term.Constructor' (ConstructorReference DocRef DocJoinId)) (Term.List' segs)
pattern DocBlob txt <- Term.App' (Term.Constructor' (ConstructorReference DocRef DocBlobId)) (Term.Text' txt)
pattern DocLink link <- Term.App' (Term.Constructor' (ConstructorReference DocRef DocLinkId)) link
pattern DocSource link <- Term.App' (Term.Constructor' (ConstructorReference DocRef DocSourceId)) link
pattern DocSignature link <- Term.App' (Term.Constructor' (ConstructorReference DocRef DocSignatureId)) link
pattern DocEvaluate link <- Term.App' (Term.Constructor' (ConstructorReference DocRef DocEvaluateId)) link
pattern Doc <- Term.App' (Term.Constructor' (ConstructorReference DocRef _)) _
pattern DocSignatureId <- ((== docSignatureId) -> True)
pattern DocBlobId <- ((== docBlobId) -> True)
pattern DocLinkId <- ((== docLinkId) -> True)
@ -368,8 +369,8 @@ pattern DocJoinId <- ((== docJoinId) -> True)
pattern LinkTermId <- ((== linkTermId) -> True)
pattern LinkTypeId <- ((== linkTypeId) -> True)
pattern LinkRef <- ((== linkRef) -> True)
pattern LinkTerm tm <- Term.App' (Term.Constructor' LinkRef LinkTermId) tm
pattern LinkType ty <- Term.App' (Term.Constructor' LinkRef LinkTypeId) ty
pattern LinkTerm tm <- Term.App' (Term.Constructor' (ConstructorReference LinkRef LinkTermId)) tm
pattern LinkType ty <- Term.App' (Term.Constructor' (ConstructorReference LinkRef LinkTypeId)) ty
unitType, pairType, optionalType, testResultType,
eitherType, ioErrorType, fileModeType, filePathType, bufferModeType, seekModeType,
@ -393,14 +394,14 @@ tlsSignedCertType :: Var v => a -> Type v a
tlsSignedCertType a = Type.ref a tlsSignedCertRef
unitTerm :: Var v => a -> Term v a
unitTerm ann = Term.constructor ann unitRef 0
unitTerm ann = Term.constructor ann (ConstructorReference unitRef 0)
tupleConsTerm :: (Ord v, Semigroup a)
=> Term2 vt at ap v a
-> Term2 vt at ap v a
-> Term2 vt at ap v a
tupleConsTerm hd tl =
Term.apps' (Term.constructor (ABT.annotation hd) pairRef 0) [hd, tl]
Term.apps' (Term.constructor (ABT.annotation hd) (ConstructorReference pairRef 0)) [hd, tl]
tupleTerm :: (Var v, Monoid a) => [Term v a] -> Term v a
tupleTerm = foldr tupleConsTerm (unitTerm mempty)
@ -417,10 +418,10 @@ unTupleTerm
:: Term.Term2 vt at ap v a
-> Maybe [Term.Term2 vt at ap v a]
unTupleTerm t = case t of
Term.Apps' (Term.Constructor' PairRef 0) [fst, snd] ->
Term.Apps' (Term.Constructor' (ConstructorReference PairRef 0)) [fst, snd] ->
(fst :) <$> unTupleTerm snd
Term.Constructor' UnitRef 0 -> Just []
_ -> Nothing
Term.Constructor' (ConstructorReference UnitRef 0) -> Just []
_ -> Nothing
unTupleType :: Var v => Type v a -> Maybe [Type v a]
unTupleType t = case t of
@ -430,8 +431,8 @@ unTupleType t = case t of
unTuplePattern :: Pattern.Pattern loc -> Maybe [Pattern.Pattern loc]
unTuplePattern p = case p of
Pattern.Constructor _ PairRef 0 [fst, snd] -> (fst : ) <$> unTuplePattern snd
Pattern.Constructor _ UnitRef 0 [] -> Just []
Pattern.Constructor _ (ConstructorReference PairRef 0) [fst, snd] -> (fst : ) <$> unTuplePattern snd
Pattern.Constructor _ (ConstructorReference UnitRef 0) [] -> Just []
_ -> Nothing
unUnitRef,unPairRef,unOptionalRef:: Reference -> Bool

5
parser-typechecker/src/Unison/Builtin/Terms.hs
View File

@ -7,6 +7,7 @@ import Data.Map (Map)
import qualified Data.Map as Map
import Data.Text (Text)
import qualified Unison.Builtin.Decls as Decls
import Unison.ConstructorReference (GConstructorReference(..))
import qualified Unison.Hashing.V2.Convert as H
import qualified Unison.Reference as Reference
import Unison.Term (Term)
@ -19,11 +20,11 @@ import qualified Unison.Var as Var
builtinTermsSrc :: Var v => a -> [(v, Term v a, Type v a)]
builtinTermsSrc a =
[ ( v "metadata.isPropagated",
Term.constructor a Decls.isPropagatedRef Decls.isPropagatedConstructorId,
Term.constructor a (ConstructorReference Decls.isPropagatedRef Decls.isPropagatedConstructorId),
Type.ref a Decls.isPropagatedRef
),
( v "metadata.isTest",
Term.constructor a Decls.isTestRef Decls.isTestConstructorId,
Term.constructor a (ConstructorReference Decls.isTestRef Decls.isTestConstructorId),
Type.ref a Decls.isTestRef
)
]

11
parser-typechecker/src/Unison/Codebase.hs
View File

@ -107,6 +107,7 @@ import qualified Unison.Codebase.GitError as GitError
import Unison.Codebase.SyncMode (SyncMode)
import Unison.Codebase.Type (Codebase (..), GetRootBranchError (..), GitError (GitCodebaseError), SyncToDir)
import Unison.CodebasePath (CodebasePath, getCodebaseDir)
import Unison.ConstructorReference (ConstructorReference, GConstructorReference(..))
import Unison.DataDeclaration (Decl)
import qualified Unison.DataDeclaration as DD
import qualified Unison.Hashing.V2.Convert as Hashing
@ -197,14 +198,14 @@ addDefsToCodebase c uf = do
goType f (ref, decl) = putTypeDeclaration c ref (f decl)
getTypeOfConstructor ::
(Monad m, Ord v) => Codebase m v a -> Reference -> Int -> m (Maybe (Type v a))
getTypeOfConstructor codebase (Reference.DerivedId r) cid = do
(Monad m, Ord v) => Codebase m v a -> ConstructorReference -> m (Maybe (Type v a))
getTypeOfConstructor codebase (ConstructorReference (Reference.DerivedId r) cid) = do
maybeDecl <- getTypeDeclaration codebase r
pure $ case maybeDecl of
Nothing -> Nothing
Just decl -> DD.typeOfConstructor (either DD.toDataDecl id decl) cid
getTypeOfConstructor _ r cid =
error $ "Don't know how to getTypeOfConstructor " ++ show r ++ " " ++ show cid
getTypeOfConstructor _ r =
error $ "Don't know how to getTypeOfConstructor " ++ show r
-- | Like 'getWatch', but first looks up the given reference as a regular watch, then as a test watch.
--
@ -267,7 +268,7 @@ getTypeOfReferent ::
m (Maybe (Type v a))
getTypeOfReferent c = \case
Referent.Ref r -> getTypeOfTerm c r
Referent.Con r cid _ -> getTypeOfConstructor c r cid
Referent.Con r _ -> getTypeOfConstructor c r
-- | Get the set of terms, type declarations, and builtin types that depend on the given term, type declaration, or
-- builtin type.

32
parser-typechecker/src/Unison/Codebase/Branch.hs
View File

@ -105,7 +105,7 @@ import Unison.Hashable ( Hashable )
import qualified Unison.Hashable as H
import Unison.Name ( Name )
import qualified Unison.Name as Name
import Unison.Reference ( Reference )
import Unison.Reference ( TypeReference )
import Unison.Referent ( Referent )
import qualified U.Util.Cache as Cache
@ -135,7 +135,7 @@ type Star r n = Metadata.Star r n
-- The @deep*@ fields are derived from the four above.
data Branch0 m = Branch0
{ _terms :: Star Referent NameSegment
, _types :: Star Reference NameSegment
, _types :: Star TypeReference NameSegment
, _children :: Map NameSegment (Branch m)
-- ^ Note the 'Branch' here, not 'Branch0'.
-- Every level in the tree has a history.
@ -143,9 +143,9 @@ data Branch0 m = Branch0
-- names and metadata for this branch and its children
-- (ref, (name, value)) iff ref has metadata `value` at name `name`
, deepTerms :: Relation Referent Name
, deepTypes :: Relation Reference Name
, deepTypes :: Relation TypeReference Name
, deepTermMetadata :: Metadata.R4 Referent Name
, deepTypeMetadata :: Metadata.R4 Reference Name
, deepTypeMetadata :: Metadata.R4 TypeReference Name
, deepPaths :: Set Path
, deepEdits :: Map Name EditHash
}
@ -156,8 +156,8 @@ data Branch0 m = Branch0
data BranchDiff = BranchDiff
{ addedTerms :: Star Referent NameSegment
, removedTerms :: Star Referent NameSegment
, addedTypes :: Star Reference NameSegment
, removedTypes :: Star Reference NameSegment
, addedTypes :: Star TypeReference NameSegment
, removedTypes :: Star TypeReference NameSegment
, changedPatches :: Map NameSegment Patch.PatchDiff
} deriving (Eq, Ord, Show)
@ -178,7 +178,7 @@ instance Monoid BranchDiff where
-- The raw Branch
data Raw = Raw
{ _termsR :: Star Referent NameSegment
, _typesR :: Star Reference NameSegment
, _typesR :: Star TypeReference NameSegment
, _childrenR :: Map NameSegment Hash
, _editsR :: Map NameSegment EditHash
}
@ -189,7 +189,7 @@ makeLensesFor [("_edits", "edits")] ''Branch0
deepReferents :: Branch0 m -> Set Referent
deepReferents = R.dom . deepTerms
deepTypeReferences :: Branch0 m -> Set Reference
deepTypeReferences :: Branch0 m -> Set TypeReference
deepTypeReferences = R.dom . deepTypes
terms :: Lens' (Branch0 m) (Star Referent NameSegment)
@ -201,7 +201,7 @@ terms =
& deriveDeepTerms
& deriveDeepTermMetadata
types :: Lens' (Branch0 m) (Star Reference NameSegment)
types :: Lens' (Branch0 m) (Star TypeReference NameSegment)
types =
lens
_types
@ -217,7 +217,7 @@ children = lens _children (\Branch0{..} x -> branch0 _terms _types x _edits)
branch0 ::
forall m.
Metadata.Star Referent NameSegment ->
Metadata.Star Reference NameSegment ->
Metadata.Star TypeReference NameSegment ->
Map NameSegment (Branch m) ->
Map NameSegment (EditHash, m Patch) ->
Branch0 m
@ -260,11 +260,11 @@ deriveDeepTypes :: Branch0 m -> Branch0 m
deriveDeepTypes branch =
branch {deepTypes = makeDeepTypes (_types branch) (_children branch)}
where
makeDeepTypes :: Metadata.Star Reference NameSegment -> Map NameSegment (Branch m) -> Relation Reference Name
makeDeepTypes :: Metadata.Star TypeReference NameSegment -> Map NameSegment (Branch m) -> Relation TypeReference Name
makeDeepTypes types children =
R.mapRanMonotonic Name.fromSegment (Star3.d1 types) <> ifoldMap go children
where
go :: NameSegment -> Branch m -> Relation Reference Name
go :: NameSegment -> Branch m -> Relation TypeReference Name
go n b =
R.mapRan (Name.cons n) (deepTypes $ head b)
@ -286,11 +286,11 @@ deriveDeepTypeMetadata :: Branch0 m -> Branch0 m
deriveDeepTypeMetadata branch =
branch {deepTypeMetadata = makeDeepTypeMetadata (_types branch) (_children branch)}
where
makeDeepTypeMetadata :: Metadata.Star Reference NameSegment -> Map NameSegment (Branch m) -> Metadata.R4 Reference Name
makeDeepTypeMetadata :: Metadata.Star TypeReference NameSegment -> Map NameSegment (Branch m) -> Metadata.R4 TypeReference Name
makeDeepTypeMetadata types children =
R4.mapD2Monotonic Name.fromSegment (Metadata.starToR4 types) <> ifoldMap go children
where
go :: NameSegment -> Branch m -> Metadata.R4 Reference Name
go :: NameSegment -> Branch m -> Metadata.R4 TypeReference Name
go n b =
R4.mapD2 (Name.cons n) (deepTypeMetadata $ head b)
@ -636,7 +636,7 @@ addTermName r new md =
over terms (Metadata.insertWithMetadata (r, md) . Star3.insertD1 (r, new))
addTypeName
:: Reference -> NameSegment -> Metadata.Metadata -> Branch0 m -> Branch0 m
:: TypeReference -> NameSegment -> Metadata.Metadata -> Branch0 m -> Branch0 m
addTypeName r new md =
over types (Metadata.insertWithMetadata (r, md) . Star3.insertD1 (r, new))
@ -645,7 +645,7 @@ deleteTermName r n b | Star3.memberD1 (r,n) (view terms b)
= over terms (Star3.deletePrimaryD1 (r,n)) b
deleteTermName _ _ b = b
deleteTypeName :: Reference -> NameSegment -> Branch0 m -> Branch0 m
deleteTypeName :: TypeReference -> NameSegment -> Branch0 m -> Branch0 m
deleteTypeName r n b | Star3.memberD1 (r,n) (view types b)
= over types (Star3.deletePrimaryD1 (r,n)) b
deleteTypeName _ _ b = b

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

@ -84,6 +84,7 @@ import qualified Unison.Codebase.SqliteCodebase.GitError as GitError
import qualified Unison.Codebase.SqliteCodebase.SyncEphemeral as SyncEphemeral
import Unison.Codebase.SyncMode (SyncMode)
import qualified Unison.Codebase.Type as C
import Unison.ConstructorReference (GConstructorReference(..))
import qualified Unison.ConstructorType as CT
import Unison.DataDeclaration (Decl)
import qualified Unison.DataDeclaration as Decl
@ -752,7 +753,7 @@ sqliteCodebase debugName root = do
>>= traverse (Cv.referentid2to1 (getCycleLen "referentsByPrefix") getDeclType)
declReferents' <- Ops.declReferentsByPrefix prefix cycle (read . Text.unpack <$> cid)
let declReferents =
[ Referent.ConId (Reference.Id (Cv.hash2to1 h) pos len) (fromIntegral cid) (Cv.decltype2to1 ct)
[ Referent.ConId (ConstructorReference (Reference.Id (Cv.hash2to1 h) pos len) (fromIntegral cid)) (Cv.decltype2to1 ct)
| (h, pos, len, ct, cids) <- declReferents',
cid <- cids
]

3
parser-typechecker/src/Unison/Codebase/SqliteCodebase/Branch/Dependencies.hs
View File

@ -16,6 +16,7 @@ import Unison.Codebase.Branch (Branch (Branch), Branch0, EditHash)
import qualified Unison.Codebase.Branch as Branch
import qualified Unison.Codebase.Causal as Causal
import Unison.Codebase.Patch (Patch)
import Unison.ConstructorReference (GConstructorReference(..))
import Unison.NameSegment (NameSegment)
import Unison.Reference (Reference, pattern Derived)
import Unison.Referent (Referent)
@ -77,7 +78,7 @@ fromBranch0 b =
[ h | Referent.Ref (Derived h _ _) <- references s] ++
[ h | (Derived h _ _) <- mdValues s]
decls = Set.fromList $
[ h | Referent.Con (Derived h _i _n) _ _ <- references s ]
[ h | Referent.Con (ConstructorReference (Derived h _i _n) _) _ <- references s ]
fromTypesStar :: Branch.Star Reference NameSegment -> Dependencies
fromTypesStar s = Dependencies mempty terms decls where
terms = Set.fromList [ h | (Derived h _ _) <- mdValues s ]

32
parser-typechecker/src/Unison/Codebase/SqliteCodebase/Conversions.hs
View File

@ -41,6 +41,7 @@ import qualified Unison.Codebase.Patch as V1
import qualified Unison.Codebase.ShortBranchHash as V1
import qualified Unison.Codebase.TermEdit as V1.TermEdit
import qualified Unison.Codebase.TypeEdit as V1.TypeEdit
import qualified Unison.ConstructorReference as V1 (GConstructorReference(..))
import qualified Unison.ConstructorType as CT
import qualified Unison.DataDeclaration as V1.Decl
import Unison.Hash (Hash)
@ -103,8 +104,8 @@ term1to2 h =
V1.Term.Text t -> V2.Term.Text t
V1.Term.Char c -> V2.Term.Char c
V1.Term.Ref r -> V2.Term.Ref (rreference1to2 h r)
V1.Term.Constructor r i -> V2.Term.Constructor (reference1to2 r) (fromIntegral i)
V1.Term.Request r i -> V2.Term.Request (reference1to2 r) (fromIntegral i)
V1.Term.Constructor (V1.ConstructorReference r i) -> V2.Term.Constructor (reference1to2 r) (fromIntegral i)
V1.Term.Request (V1.ConstructorReference r i) -> V2.Term.Request (reference1to2 r) (fromIntegral i)
V1.Term.Handle b h -> V2.Term.Handle b h
V1.Term.App f a -> V2.Term.App f a
V1.Term.Ann e t -> V2.Term.Ann e (ttype1to2 t)
@ -131,11 +132,11 @@ term1to2 h =
V1.Pattern.Float _ d -> V2.Term.PFloat d
V1.Pattern.Text _ t -> V2.Term.PText t
V1.Pattern.Char _ c -> V2.Term.PChar c
V1.Pattern.Constructor _ r i ps ->
V1.Pattern.Constructor _ (V1.ConstructorReference r i) ps ->
V2.Term.PConstructor (reference1to2 r) i (goPat <$> ps)
V1.Pattern.As _ p -> V2.Term.PAs (goPat p)
V1.Pattern.EffectPure _ p -> V2.Term.PEffectPure (goPat p)
V1.Pattern.EffectBind _ r i ps k ->
V1.Pattern.EffectBind _ (V1.ConstructorReference r i) ps k ->
V2.Term.PEffectBind (reference1to2 r) i (goPat <$> ps) (goPat k)
V1.Pattern.SequenceLiteral _ ps -> V2.Term.PSequenceLiteral (goPat <$> ps)
V1.Pattern.SequenceOp _ p op p2 ->
@ -165,9 +166,9 @@ term2to1 h lookupSize lookupCT tm =
V2.Term.Char c -> pure $ V1.Term.Char c
V2.Term.Ref r -> V1.Term.Ref <$> rreference2to1 h lookupSize r
V2.Term.Constructor r i ->
V1.Term.Constructor <$> reference2to1 lookupSize r <*> pure (fromIntegral i)
V1.Term.Constructor <$> (V1.ConstructorReference <$> reference2to1 lookupSize r <*> pure (fromIntegral i))
V2.Term.Request r i ->
V1.Term.Request <$> reference2to1 lookupSize r <*> pure (fromIntegral i)
V1.Term.Request <$> (V1.ConstructorReference <$> reference2to1 lookupSize r <*> pure (fromIntegral i))
V2.Term.Handle a a4 -> pure $ V1.Term.Handle a a4
V2.Term.App a a4 -> pure $ V1.Term.App a a4
V2.Term.Ann a t2 -> V1.Term.Ann a <$> ttype2to1 lookupSize t2
@ -194,10 +195,11 @@ term2to1 h lookupSize lookupCT tm =
V2.Term.PText t -> pure $ V1.Pattern.Text a t
V2.Term.PChar c -> pure $ V1.Pattern.Char a c
V2.Term.PConstructor r i ps ->
V1.Pattern.Constructor a <$> reference2to1 lookupSize r <*> pure i <*> (traverse goPat ps)
V1.Pattern.Constructor a <$> (V1.ConstructorReference <$> reference2to1 lookupSize r <*> pure i) <*> (traverse goPat ps)
V2.Term.PAs p -> V1.Pattern.As a <$> goPat p
V2.Term.PEffectPure p -> V1.Pattern.EffectPure a <$> goPat p
V2.Term.PEffectBind r i ps p -> V1.Pattern.EffectBind a <$> reference2to1 lookupSize r <*> pure i <*> traverse goPat ps <*> goPat p
V2.Term.PEffectBind r i ps p ->
V1.Pattern.EffectBind a <$> (V1.ConstructorReference <$> reference2to1 lookupSize r <*> pure i) <*> traverse goPat ps <*> goPat p
V2.Term.PSequenceLiteral ps -> V1.Pattern.SequenceLiteral a <$> traverse goPat ps
V2.Term.PSequenceOp p1 op p2 -> V1.Pattern.SequenceOp a <$> goPat p1 <*> pure (goOp op) <*> goPat p2
goOp = \case
@ -322,30 +324,28 @@ referenceid2to1 lookupSize (V2.Reference.Id h i) =
rreferent2to1 :: Applicative m => Hash -> (Hash -> m V1.Reference.Size) -> (V2.Reference -> m CT.ConstructorType) -> V2.ReferentH -> m V1.Referent
rreferent2to1 h lookupSize lookupCT = \case
V2.Ref r -> V1.Ref <$> rreference2to1 h lookupSize r
V2.Con r i -> V1.Con <$> reference2to1 lookupSize r <*> pure (fromIntegral i) <*> lookupCT r
V2.Con r i -> V1.Con <$> (V1.ConstructorReference <$> reference2to1 lookupSize r <*> pure (fromIntegral i)) <*> lookupCT r
rreferent1to2 :: Hash -> V1.Referent -> V2.ReferentH
rreferent1to2 h = \case
V1.Ref r -> V2.Ref (rreference1to2 h r)
V1.Con r i _ct -> V2.Con (reference1to2 r) (fromIntegral i)
V1.Con (V1.ConstructorReference r i) _ct -> V2.Con (reference1to2 r) (fromIntegral i)
referent2to1 :: Applicative m => (Hash -> m V1.Reference.Size) -> (V2.Reference -> m CT.ConstructorType) -> V2.Referent -> m V1.Referent
referent2to1 lookupSize lookupCT = \case
V2.Ref r -> V1.Ref <$> reference2to1 lookupSize r
V2.Con r i -> V1.Con <$> reference2to1 lookupSize r <*> pure (fromIntegral i) <*> lookupCT r
V2.Con r i -> V1.Con <$> (V1.ConstructorReference <$> reference2to1 lookupSize r <*> pure (fromIntegral i)) <*> lookupCT r
referent1to2 :: V1.Referent -> V2.Referent
referent1to2 = \case
V1.Ref r -> V2.Ref $ reference1to2 r
V1.Con r i _ct -> V2.Con (reference1to2 r) (fromIntegral i)
V1.Con (V1.ConstructorReference r i) _ct -> V2.Con (reference1to2 r) (fromIntegral i)
referentid2to1 :: Applicative m => (Hash -> m V1.Reference.Size) -> (V2.Reference -> m CT.ConstructorType) -> V2.Referent.Id -> m V1.Referent.Id
referentid2to1 lookupSize lookupCT = \case
V2.RefId r -> V1.RefId <$> referenceid2to1 lookupSize r
V2.ConId r i ->
V1.ConId <$> referenceid2to1 lookupSize r
<*> pure (fromIntegral i)
<*> lookupCT (V2.ReferenceDerived r)
V2.ConId r i ->
V1.ConId <$> (V1.ConstructorReference <$>referenceid2to1 lookupSize r <*> pure (fromIntegral i)) <*> lookupCT (V2.ReferenceDerived r)
hash2to1 :: V2.Hash.Hash -> Hash
hash2to1 (V2.Hash.Hash sbs) = V1.Hash sbs

14
parser-typechecker/src/Unison/DeclPrinter.hs
View File

@ -7,6 +7,7 @@ import Unison.Prelude
import Data.List ( isPrefixOf )
import qualified Data.Map as Map
import Unison.ConstructorReference (GConstructorReference(..), ConstructorReference)
import Unison.DataDeclaration ( DataDeclaration
, EffectDeclaration
, toDataDecl
@ -67,7 +68,7 @@ prettyGADT env ctorType r name dd = P.hang header . P.lines $ constructor <$> zi
(DD.constructors' dd)
where
constructor (n, (_, _, t)) =
prettyPattern env ctorType r name n
prettyPattern env ctorType name (ConstructorReference r n)
<> (fmt S.TypeAscriptionColon " :")
`P.hang` TypePrinter.pretty0 env Map.empty (-1) t
header = prettyEffectHeader name (DD.EffectDeclaration dd) <> (fmt S.ControlKeyword " where")
@ -75,17 +76,16 @@ prettyGADT env ctorType r name dd = P.hang header . P.lines $ constructor <$> zi
prettyPattern
:: PrettyPrintEnv
-> CT.ConstructorType
-> Reference
-> HashQualified Name
-> Int
-> ConstructorReference
-> Pretty SyntaxText
prettyPattern env ctorType ref namespace cid = styleHashQualified''
prettyPattern env ctorType namespace ref = styleHashQualified''
(fmt (S.TermReference conRef))
( HQ.stripNamespace (fromMaybe "" $ Name.toText <$> HQ.toName namespace)
$ PPE.termName env conRef
)
where
conRef = Referent.Con ref cid ctorType
conRef = Referent.Con ref ctorType
prettyDataDecl
:: Var v
@ -102,9 +102,9 @@ prettyDataDecl (PrettyPrintEnvDecl unsuffixifiedPPE suffixifiedPPE) r name dd =
constructor (n, (_, _, (Type.ForallsNamed' _ t))) = constructor' n t
constructor (n, (_, _, t) ) = constructor' n t
constructor' n t = case Type.unArrows t of
Nothing -> prettyPattern suffixifiedPPE CT.Data r name n
Nothing -> prettyPattern suffixifiedPPE CT.Data name (ConstructorReference r n)
Just ts -> case fieldNames unsuffixifiedPPE r name dd of
Nothing -> P.group . P.hang' (prettyPattern suffixifiedPPE CT.Data r name n) " "
Nothing -> P.group . P.hang' (prettyPattern suffixifiedPPE CT.Data name (ConstructorReference r n)) " "
$ P.spaced (TypePrinter.prettyRaw suffixifiedPPE Map.empty 10 <$> init ts)
Just fs -> P.group $ (fmt S.DelimiterChar "{ ")
<> P.sep ((fmt S.DelimiterChar ",") <> " " `P.orElse` "\n ")

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

@ -16,6 +16,7 @@ import Data.Map (Map)
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Unison.ABT as ABT
import qualified Unison.ConstructorReference as Memory.ConstructorReference
import qualified Unison.DataDeclaration as Memory.DD
import qualified Unison.Hashing.V2.DataDeclaration as Hashing.DD
import qualified Unison.Hashing.V2.Pattern as Hashing.Pattern
@ -56,8 +57,8 @@ m2hTerm = ABT.transform \case
Memory.Term.Char c -> Hashing.Term.Char c
Memory.Term.Blank b -> Hashing.Term.Blank b
Memory.Term.Ref r -> Hashing.Term.Ref (m2hReference r)
Memory.Term.Constructor r i -> Hashing.Term.Constructor (m2hReference r) i
Memory.Term.Request r i -> Hashing.Term.Request (m2hReference r) i
Memory.Term.Constructor (Memory.ConstructorReference.ConstructorReference r i) -> Hashing.Term.Constructor (m2hReference r) i
Memory.Term.Request (Memory.ConstructorReference.ConstructorReference r i) -> Hashing.Term.Request (m2hReference r) i
Memory.Term.Handle x y -> Hashing.Term.Handle x y
Memory.Term.App f x -> Hashing.Term.App f x
Memory.Term.Ann e t -> Hashing.Term.Ann e (m2hType t)
@ -85,10 +86,12 @@ m2hPattern = \case
Memory.Pattern.Float loc f -> Hashing.Pattern.Float loc f
Memory.Pattern.Text loc t -> Hashing.Pattern.Text loc t
Memory.Pattern.Char loc c -> Hashing.Pattern.Char loc c
Memory.Pattern.Constructor loc r i ps -> Hashing.Pattern.Constructor loc (m2hReference r) i (fmap m2hPattern ps)
Memory.Pattern.Constructor loc (Memory.ConstructorReference.ConstructorReference r i) ps ->
Hashing.Pattern.Constructor loc (m2hReference r) i (fmap m2hPattern ps)
Memory.Pattern.As loc p -> Hashing.Pattern.As loc (m2hPattern p)
Memory.Pattern.EffectPure loc p -> Hashing.Pattern.EffectPure loc (m2hPattern p)
Memory.Pattern.EffectBind loc r i ps k -> Hashing.Pattern.EffectBind loc (m2hReference r) i (fmap m2hPattern ps) (m2hPattern k)
Memory.Pattern.EffectBind loc (Memory.ConstructorReference.ConstructorReference r i) ps k ->
Hashing.Pattern.EffectBind loc (m2hReference r) i (fmap m2hPattern ps) (m2hPattern k)
Memory.Pattern.SequenceLiteral loc ps -> Hashing.Pattern.SequenceLiteral loc (fmap m2hPattern ps)
Memory.Pattern.SequenceOp loc l op r -> Hashing.Pattern.SequenceOp loc (m2hPattern l) (m2hSequenceOp op) (m2hPattern r)
@ -101,7 +104,7 @@ m2hSequenceOp = \case
m2hReferent :: Memory.Referent.Referent -> Hashing.Referent.Referent
m2hReferent = \case
Memory.Referent.Ref ref -> Hashing.Referent.Ref (m2hReference ref)
Memory.Referent.Con ref n ct -> Hashing.Referent.Con (m2hReference ref) n ct
Memory.Referent.Con (Memory.ConstructorReference.ConstructorReference ref n) ct -> Hashing.Referent.Con (m2hReference ref) n ct
h2mTerm :: Ord v => Hashing.Term.Term v a -> Memory.Term.Term v a
h2mTerm = ABT.transform \case
@ -113,8 +116,8 @@ h2mTerm = ABT.transform \case
Hashing.Term.Char c -> Memory.Term.Char c
Hashing.Term.Blank b -> Memory.Term.Blank b
Hashing.Term.Ref r -> Memory.Term.Ref (h2mReference r)
Hashing.Term.Constructor r i -> Memory.Term.Constructor (h2mReference r) i
Hashing.Term.Request r i -> Memory.Term.Request (h2mReference r) i
Hashing.Term.Constructor r i -> Memory.Term.Constructor (Memory.ConstructorReference.ConstructorReference (h2mReference r) i)
Hashing.Term.Request r i -> Memory.Term.Request (Memory.ConstructorReference.ConstructorReference (h2mReference r) i)
Hashing.Term.Handle x y -> Memory.Term.Handle x y
Hashing.Term.App f x -> Memory.Term.App f x
Hashing.Term.Ann e t -> Memory.Term.Ann e (h2mType t)
@ -142,10 +145,12 @@ h2mPattern = \case
Hashing.Pattern.Float loc f -> Memory.Pattern.Float loc f
Hashing.Pattern.Text loc t -> Memory.Pattern.Text loc t
Hashing.Pattern.Char loc c -> Memory.Pattern.Char loc c
Hashing.Pattern.Constructor loc r i ps -> Memory.Pattern.Constructor loc (h2mReference r) i (h2mPattern <$> ps)
Hashing.Pattern.Constructor loc r i ps ->
Memory.Pattern.Constructor loc (Memory.ConstructorReference.ConstructorReference (h2mReference r) i) (h2mPattern <$> ps)
Hashing.Pattern.As loc p -> Memory.Pattern.As loc (h2mPattern p)
Hashing.Pattern.EffectPure loc p -> Memory.Pattern.EffectPure loc (h2mPattern p)
Hashing.Pattern.EffectBind loc r i ps k -> Memory.Pattern.EffectBind loc (h2mReference r) i (h2mPattern <$> ps) (h2mPattern k)
Hashing.Pattern.EffectBind loc r i ps k ->
Memory.Pattern.EffectBind loc (Memory.ConstructorReference.ConstructorReference (h2mReference r) i) (h2mPattern <$> ps) (h2mPattern k)
Hashing.Pattern.SequenceLiteral loc ps -> Memory.Pattern.SequenceLiteral loc (h2mPattern <$> ps)
Hashing.Pattern.SequenceOp loc l op r -> Memory.Pattern.SequenceOp loc (h2mPattern l) (h2mSequenceOp op) (h2mPattern r)
@ -158,7 +163,7 @@ h2mSequenceOp = \case
h2mReferent :: Hashing.Referent.Referent -> Memory.Referent.Referent
h2mReferent = \case
Hashing.Referent.Ref ref -> Memory.Referent.Ref (h2mReference ref)
Hashing.Referent.Con ref n ct -> Memory.Referent.Con (h2mReference ref) n ct
Hashing.Referent.Con ref n ct -> Memory.Referent.Con (Memory.ConstructorReference.ConstructorReference (h2mReference ref) n) ct
hashDecls ::
Var v =>

5
parser-typechecker/src/Unison/Hashing/V2/Referent.hs
View File

@ -4,6 +4,7 @@
module Unison.Hashing.V2.Referent where
import Unison.Prelude
import Unison.ConstructorReference (GConstructorReference(..))
import Unison.Referent' ( Referent'(..), toReference' )
import qualified Data.Char as Char
@ -27,7 +28,7 @@ type ConstructorId = Int
pattern Ref :: Reference -> Referent
pattern Ref r = Ref' r
pattern Con :: Reference -> ConstructorId -> ConstructorType -> Referent
pattern Con r i t = Con' r i t
pattern Con r i t = Con' (ConstructorReference r i) t
{-# COMPLETE Ref, Con #-}
-- | Cannot be a builtin.
@ -117,4 +118,4 @@ fromText t = either (const Nothing) Just $
fold :: (r -> a) -> (r -> ConstructorId -> ConstructorType -> a) -> Referent' r -> a
fold fr fc = \case
Ref' r -> fr r
Con' r i ct -> fc r i ct
Con' (ConstructorReference r i) ct -> fc r i ct

5
parser-typechecker/src/Unison/Parser.hs
View File

@ -35,6 +35,7 @@ import Text.Megaparsec (runParserT)
import qualified Text.Megaparsec as P
import qualified Text.Megaparsec.Char as P
import qualified Unison.ABT as ABT
import Unison.ConstructorReference (ConstructorReference)
import qualified Unison.Hash as Hash
import qualified Unison.HashQualified as HQ
import qualified Unison.Lexer as L
@ -106,8 +107,8 @@ data Error v
= SignatureNeedsAccompanyingBody (L.Token v)
| DisallowedAbsoluteName (L.Token Name)
| EmptyBlock (L.Token String)
| UnknownAbilityConstructor (L.Token (HQ.HashQualified Name)) (Set (Reference, Int))
| UnknownDataConstructor (L.Token (HQ.HashQualified Name)) (Set (Reference, Int))
| UnknownAbilityConstructor (L.Token (HQ.HashQualified Name)) (Set ConstructorReference)
| UnknownDataConstructor (L.Token (HQ.HashQualified Name)) (Set ConstructorReference)
| UnknownTerm (L.Token (HQ.HashQualified Name)) (Set Referent)
| UnknownType (L.Token (HQ.HashQualified Name)) (Set Reference)
| UnknownId (L.Token (HQ.HashQualified Name)) (Set Referent) (Set Reference)

15
parser-typechecker/src/Unison/PrettyPrintEnv.hs
View File

@ -13,6 +13,7 @@ where
import Unison.Prelude
import Unison.ConstructorReference (ConstructorReference)
import Unison.HashQualified ( HashQualified )
import qualified Unison.HashQualified' as HQ'
import Unison.Name ( Name )
@ -28,9 +29,9 @@ data PrettyPrintEnv = PrettyPrintEnv {
-- names for types
types :: Reference -> Maybe (HQ'.HashQualified Name) }
patterns :: PrettyPrintEnv -> Reference -> Int -> Maybe (HQ'.HashQualified Name)
patterns ppe r cid = terms ppe (Referent.Con r cid CT.Data)
<|>terms ppe (Referent.Con r cid CT.Effect)
patterns :: PrettyPrintEnv -> ConstructorReference -> Maybe (HQ'.HashQualified Name)
patterns ppe r = terms ppe (Referent.Con r CT.Data)
<|> terms ppe (Referent.Con r CT.Effect)
instance Show PrettyPrintEnv where
show _ = "PrettyPrintEnv"
@ -57,11 +58,11 @@ typeName env r =
Nothing -> HQ.take todoHashLength (HQ.fromReference r)
Just name -> HQ'.toHQ name
patternName :: PrettyPrintEnv -> Reference -> Int -> HashQualified Name
patternName env r cid =
case patterns env r cid of
patternName :: PrettyPrintEnv -> ConstructorReference -> HashQualified Name
patternName env r =
case patterns env r of
Just name -> HQ'.toHQ name
Nothing -> HQ.take todoHashLength $ HQ.fromPattern r cid
Nothing -> HQ.take todoHashLength $ HQ.fromPattern r
instance Monoid PrettyPrintEnv where
mempty = PrettyPrintEnv (const Nothing) (const Nothing)

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

@ -20,6 +20,7 @@ import Data.Void (Void)
import qualified Text.Megaparsec as P
import qualified Unison.ABT as ABT
import Unison.Builtin.Decls (pattern TupleType')
import Unison.ConstructorReference (ConstructorReference, GConstructorReference(..))
import qualified Unison.HashQualified as HQ
import Unison.Kind (Kind)
import qualified Unison.Kind as Kind
@ -673,14 +674,14 @@ renderTypeError e env src = case e of
, "}\n"
, renderContext env c
]
C.EffectConstructorWrongArgCount e a r cid -> mconcat
C.EffectConstructorWrongArgCount e a r -> mconcat
[ "EffectConstructorWrongArgCount:"
, " expected="
, (fromString . show) e
, ", actual="
, (fromString . show) a
, ", reference="
, showConstructor env r cid
, showConstructor env r
]
C.MalformedEffectBind ctorType ctorResult es -> mconcat
[ "MalformedEffectBind: "
@ -746,7 +747,7 @@ renderCompilerBug env _src bug = mconcat $ case bug of
, " reerence = "
, showTypeRef env rf
]
C.UnknownConstructor sort rf i _decl ->
C.UnknownConstructor sort (ConstructorReference rf i) _decl ->
[ "UnknownConstructor:\n"
, case sort of
C.Data -> " data type\n"
@ -913,9 +914,9 @@ showTypeRef :: IsString s => Env -> R.Reference -> s
showTypeRef env r = fromString . HQ.toString $ PPE.typeName env r
-- todo: do something different/better if cid not found
showConstructor :: IsString s => Env -> R.Reference -> Int -> s
showConstructor env r cid = fromString . HQ.toString $
PPE.patternName env r cid
showConstructor :: IsString s => Env -> ConstructorReference -> s
showConstructor env r = fromString . HQ.toString $
PPE.patternName env r
styleInOverallType
:: (Var v, Annotated a, Eq a)

29
parser-typechecker/src/Unison/Runtime/ANF.hs
View File

@ -85,6 +85,7 @@ import Data.List hiding (and,or)
import Prelude hiding (abs,and,or,seq)
import qualified Prelude
import Unison.Blank (nameb)
import Unison.ConstructorReference (ConstructorReference, GConstructorReference(..))
import Unison.Term hiding (resolve, fresh, float, Text, Ref, List)
import Unison.Var (Var, typed)
import Unison.Util.EnumContainers as EC
@ -206,7 +207,7 @@ enclose keep rec t@(Handle' h body)
a = ABT.annotation body
lbody = rec keep body
fv = Var.freshIn fvs $ typed Var.Eta
args | null evs = [constructor a Ty.unitRef 0]
args | null evs = [constructor a (ConstructorReference Ty.unitRef 0)]
| otherwise = var a <$> evs
lamb | null evs = lam' a [fv] lbody
| otherwise = lam' a evs lbody
@ -220,7 +221,7 @@ isStructured (Int' _) = False
isStructured (Float' _) = False
isStructured (Text' _) = False
isStructured (Char' _) = False
isStructured (Constructor' _ _) = False
isStructured (Constructor' _) = False
isStructured (Apps' Constructor'{} args) = any isStructured args
isStructured (If' b t f)
= isStructured b || isStructured t || isStructured f
@ -328,18 +329,18 @@ lamLift = float . close Set.empty . deannotate
saturate
:: (Var v, Monoid a)
=> Map (Reference,Int) Int -> Term v a -> Term v a
=> Map ConstructorReference Int -> Term v a -> Term v a
saturate dat = ABT.visitPure $ \case
Apps' f@(Constructor' r t) args -> sat r t f args
Apps' f@(Request' r t) args -> sat r t f args
f@(Constructor' r t) -> sat r t f []
f@(Request' r t) -> sat r t f []
Apps' f@(Constructor' r) args -> sat r f args
Apps' f@(Request' r) args -> sat r f args
f@(Constructor' r) -> sat r f []
f@(Request' r) -> sat r f []
_ -> Nothing
where
frsh avoid _ =
let v = Var.freshIn avoid $ typed Var.Eta
in (Set.insert v avoid, v)
sat r t f args = case Map.lookup (r,t) dat of
sat r f args = case Map.lookup r dat of
Just n
| m < n
, vs <- snd $ mapAccumL frsh fvs [1..n-m]
@ -1077,9 +1078,9 @@ anfBlock (Apps' f args) = do
(fctx, (d, cf)) <- anfFunc f
(actx, cas) <- anfArgs args
pure (fctx <> actx, (d, TApp cf cas))
anfBlock (Constructor' r t)
anfBlock (Constructor' (ConstructorReference r t))
= pure (mempty, pure $ TCon r (toEnum t) [])
anfBlock (Request' r t)
anfBlock (Request' (ConstructorReference r t))
= pure (mempty, (Indirect (), TReq r (toEnum t) []))
anfBlock (Boolean' b)
= pure (mempty, pure $ TCon Ty.booleanRef (if b then 1 else 0) [])
@ -1139,7 +1140,7 @@ anfInitCase u (MatchCase p guard (ABT.AbsN' vs bd))
| P.Text _ t <- p
, [] <- vs
= AccumText Nothing . Map.singleton (Util.Text.fromText t) <$> anfBody bd
| P.Constructor _ r t ps <- p = do
| P.Constructor _ (ConstructorReference r t) ps <- p = do
(,) <$> expandBindings ps vs <*> anfBody bd <&> \(us,bd)
-> AccumData r Nothing
. EC.mapSingleton (toEnum t)
@ -1149,7 +1150,7 @@ anfInitCase u (MatchCase p guard (ABT.AbsN' vs bd))
| P.EffectPure _ q <- p =
(,) <$> expandBindings [q] vs <*> anfBody bd <&> \(us,bd) ->
AccumPure $ ABTN.TAbss us bd
| P.EffectBind _ r t ps pk <- p = do
| P.EffectBind _ (ConstructorReference r t) ps pk <- p = do
(,,) <$> expandBindings (snoc ps pk) vs
<*> Compose (pure <$> fresh)
<*> anfBody bd
@ -1303,8 +1304,8 @@ anfCases u = getCompose . fmap fold . traverse (anfInitCase u)
anfFunc :: Var v => Term v a -> ANFM v (Ctx v, Directed () (Func v))
anfFunc (Var' v) = pure (mempty, (Indirect (), FVar v))
anfFunc (Ref' r) = pure (mempty, (Indirect (), FComb r))
anfFunc (Constructor' r t) = pure (mempty, (Direct, FCon r $ toEnum t))
anfFunc (Request' r t) = pure (mempty, (Indirect (), FReq r $ toEnum t))
anfFunc (Constructor' (ConstructorReference r t)) = pure (mempty, (Direct, FCon r $ toEnum t))
anfFunc (Request' (ConstructorReference r t)) = pure (mempty, (Indirect (), FReq r $ toEnum t))
anfFunc tm = do
(fctx, ctm) <- anfBlock tm
(cx, v) <- contextualize ctm

3
parser-typechecker/src/Unison/Runtime/Decompile.hs
View File

@ -10,6 +10,7 @@ module Unison.Runtime.Decompile
import Unison.Prelude
import Unison.ABT (substs)
import Unison.ConstructorReference (GConstructorReference(..))
import Unison.Term
( Term
, nat, int, char, float, boolean, constructor, app, apps', text, ref
@ -39,7 +40,7 @@ import qualified Unison.Term as Term
import Unsafe.Coerce -- for Int -> Double
con :: Var v => Reference -> Word64 -> Term v ()
con rf ct = constructor () rf $ fromIntegral ct
con rf ct = constructor () (ConstructorReference rf $ fromIntegral ct)
err :: String -> Either Error a
err = Left . lit . fromString

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

@ -13,6 +13,7 @@ import Control.Monad.Identity (runIdentity, Identity)
import Data.List (elemIndex, genericIndex)
import Text.RawString.QQ (r)
import Unison.Codebase.CodeLookup (CodeLookup(..))
import Unison.ConstructorReference (GConstructorReference(..))
import Unison.FileParsers (parseAndSynthesizeFile)
import Unison.Parser.Ann (Ann(..))
import Unison.Symbol (Symbol)
@ -134,34 +135,34 @@ doc2UntitledSectionId = constructorNamed doc2Ref "Doc2.UntitledSection"
doc2ColumnId = constructorNamed doc2Ref "Doc2.Column"
doc2GroupId = constructorNamed doc2Ref "Doc2.Group"
pattern Doc2Word txt <- Term.App' (Term.Constructor' Doc2Ref ((==) doc2WordId -> True)) (Term.Text' txt)
pattern Doc2Code d <- Term.App' (Term.Constructor' Doc2Ref ((==) doc2CodeId -> True)) d
pattern Doc2CodeBlock lang d <- Term.Apps' (Term.Constructor' Doc2Ref ((==) doc2CodeBlockId -> True)) [Term.Text' lang, d]
pattern Doc2Bold d <- Term.App' (Term.Constructor' Doc2Ref ((==) doc2BoldId -> True)) d
pattern Doc2Italic d <- Term.App' (Term.Constructor' Doc2Ref ((==) doc2ItalicId -> True)) d
pattern Doc2Strikethrough d <- Term.App' (Term.Constructor' Doc2Ref ((==) doc2StrikethroughId -> True)) d
pattern Doc2Style s d <- Term.Apps' (Term.Constructor' Doc2Ref ((==) doc2StyleId -> True)) [Term.Text' s, d]
pattern Doc2Anchor id d <- Term.Apps' (Term.Constructor' Doc2Ref ((==) doc2AnchorId -> True)) [Term.Text' id, d]
pattern Doc2Blockquote d <- Term.App' (Term.Constructor' Doc2Ref ((==) doc2BlockquoteId -> True)) d
pattern Doc2Blankline <- Term.Constructor' Doc2Ref ((==) doc2BlanklineId -> True)
pattern Doc2Linebreak <- Term.Constructor' Doc2Ref ((==) doc2LinebreakId -> True)
pattern Doc2SectionBreak <- Term.Constructor' Doc2Ref ((==) doc2SectionBreakId -> True)
pattern Doc2Tooltip d tip <- Term.Apps' (Term.Constructor' Doc2Ref ((==) doc2TooltipId -> True)) [d, tip]
pattern Doc2Aside d <- Term.App' (Term.Constructor' Doc2Ref ((==) doc2AsideId -> True)) d
pattern Doc2Callout icon d <- Term.Apps' (Term.Constructor' Doc2Ref ((==) doc2CalloutId -> True)) [icon, d]
pattern Doc2Table ds <- Term.App' (Term.Constructor' Doc2Ref ((==) doc2TableId -> True)) (Term.List' (toList -> ds))
pattern Doc2Folded isFolded d d2 <- Term.Apps' (Term.Constructor' Doc2Ref ((==) doc2FoldedId -> True)) [Term.Boolean' isFolded, d, d2]
pattern Doc2Paragraph ds <- Term.App' (Term.Constructor' Doc2Ref ((==) doc2ParagraphId -> True)) (Term.List' (toList -> ds))
pattern Doc2BulletedList ds <- Term.App' (Term.Constructor' Doc2Ref ((==) doc2BulletedListId -> True)) (Term.List' (toList -> ds))
pattern Doc2NumberedList n ds <- Term.Apps' (Term.Constructor' Doc2Ref ((==) doc2NumberedListId -> True)) [Term.Nat' n, Term.List' (toList -> ds)]
pattern Doc2Section title ds <- Term.Apps' (Term.Constructor' Doc2Ref ((==) doc2SectionId -> True)) [title, Term.List' (toList -> ds)]
pattern Doc2NamedLink name dest <- Term.Apps' (Term.Constructor' Doc2Ref ((==) doc2NamedLinkId -> True)) [name, dest]
pattern Doc2Image alt link caption <- Term.Apps' (Term.Constructor' Doc2Ref ((==) doc2ImageId -> True)) [alt, link, caption]
pattern Doc2Special sf <- Term.App' (Term.Constructor' Doc2Ref ((==) doc2SpecialId -> True)) sf
pattern Doc2Join ds <- Term.App' (Term.Constructor' Doc2Ref ((==) doc2JoinId -> True)) (Term.List' (toList -> ds))
pattern Doc2UntitledSection ds <- Term.App' (Term.Constructor' Doc2Ref ((==) doc2UntitledSectionId -> True)) (Term.List' (toList -> ds))
pattern Doc2Column ds <- Term.App' (Term.Constructor' Doc2Ref ((==) doc2ColumnId -> True)) (Term.List' (toList -> ds))
pattern Doc2Group d <- Term.App' (Term.Constructor' Doc2Ref ((==) doc2GroupId -> True)) d
pattern Doc2Word txt <- Term.App' (Term.Constructor' (ConstructorReference Doc2Ref ((==) doc2WordId -> True))) (Term.Text' txt)
pattern Doc2Code d <- Term.App' (Term.Constructor' (ConstructorReference Doc2Ref ((==) doc2CodeId -> True))) d
pattern Doc2CodeBlock lang d <- Term.Apps' (Term.Constructor' (ConstructorReference Doc2Ref ((==) doc2CodeBlockId -> True))) [Term.Text' lang, d]
pattern Doc2Bold d <- Term.App' (Term.Constructor' (ConstructorReference Doc2Ref ((==) doc2BoldId -> True))) d
pattern Doc2Italic d <- Term.App' (Term.Constructor' (ConstructorReference Doc2Ref ((==) doc2ItalicId -> True))) d
pattern Doc2Strikethrough d <- Term.App' (Term.Constructor' (ConstructorReference Doc2Ref ((==) doc2StrikethroughId -> True))) d
pattern Doc2Style s d <- Term.Apps' (Term.Constructor' (ConstructorReference Doc2Ref ((==) doc2StyleId -> True))) [Term.Text' s, d]
pattern Doc2Anchor id d <- Term.Apps' (Term.Constructor' (ConstructorReference Doc2Ref ((==) doc2AnchorId -> True))) [Term.Text' id, d]
pattern Doc2Blockquote d <- Term.App' (Term.Constructor' (ConstructorReference Doc2Ref ((==) doc2BlockquoteId -> True))) d
pattern Doc2Blankline <- Term.Constructor' (ConstructorReference Doc2Ref ((==) doc2BlanklineId -> True))
pattern Doc2Linebreak <- Term.Constructor' (ConstructorReference Doc2Ref ((==) doc2LinebreakId -> True))
pattern Doc2SectionBreak <- Term.Constructor' (ConstructorReference Doc2Ref ((==) doc2SectionBreakId -> True))
pattern Doc2Tooltip d tip <- Term.Apps' (Term.Constructor' (ConstructorReference Doc2Ref ((==) doc2TooltipId -> True))) [d, tip]
pattern Doc2Aside d <- Term.App' (Term.Constructor' (ConstructorReference Doc2Ref ((==) doc2AsideId -> True))) d
pattern Doc2Callout icon d <- Term.Apps' (Term.Constructor' (ConstructorReference Doc2Ref ((==) doc2CalloutId -> True))) [icon, d]
pattern Doc2Table ds <- Term.App' (Term.Constructor' (ConstructorReference Doc2Ref ((==) doc2TableId -> True))) (Term.List' (toList -> ds))
pattern Doc2Folded isFolded d d2 <- Term.Apps' (Term.Constructor' (ConstructorReference Doc2Ref ((==) doc2FoldedId -> True))) [Term.Boolean' isFolded, d, d2]
pattern Doc2Paragraph ds <- Term.App' (Term.Constructor' (ConstructorReference Doc2Ref ((==) doc2ParagraphId -> True))) (Term.List' (toList -> ds))
pattern Doc2BulletedList ds <- Term.App' (Term.Constructor' (ConstructorReference Doc2Ref ((==) doc2BulletedListId -> True))) (Term.List' (toList -> ds))
pattern Doc2NumberedList n ds <- Term.Apps' (Term.Constructor' (ConstructorReference Doc2Ref ((==) doc2NumberedListId -> True))) [Term.Nat' n, Term.List' (toList -> ds)]
pattern Doc2Section title ds <- Term.Apps' (Term.Constructor' (ConstructorReference Doc2Ref ((==) doc2SectionId -> True))) [title, Term.List' (toList -> ds)]
pattern Doc2NamedLink name dest <- Term.Apps' (Term.Constructor' (ConstructorReference Doc2Ref ((==) doc2NamedLinkId -> True))) [name, dest]
pattern Doc2Image alt link caption <- Term.Apps' (Term.Constructor' (ConstructorReference Doc2Ref ((==) doc2ImageId -> True))) [alt, link, caption]
pattern Doc2Special sf <- Term.App' (Term.Constructor' (ConstructorReference Doc2Ref ((==) doc2SpecialId -> True))) sf
pattern Doc2Join ds <- Term.App' (Term.Constructor' (ConstructorReference Doc2Ref ((==) doc2JoinId -> True))) (Term.List' (toList -> ds))
pattern Doc2UntitledSection ds <- Term.App' (Term.Constructor' (ConstructorReference Doc2Ref ((==) doc2UntitledSectionId -> True))) (Term.List' (toList -> ds))
pattern Doc2Column ds <- Term.App' (Term.Constructor' (ConstructorReference Doc2Ref ((==) doc2ColumnId -> True))) (Term.List' (toList -> ds))
pattern Doc2Group d <- Term.App' (Term.Constructor' (ConstructorReference Doc2Ref ((==) doc2GroupId -> True))) d
pattern Doc2SpecialFormRef <- ((== doc2SpecialFormRef) -> True)
doc2SpecialFormSourceId = constructorNamed doc2SpecialFormRef "Doc2.SpecialForm.Source"
@ -176,17 +177,17 @@ doc2SpecialFormEvalInlineId = constructorNamed doc2SpecialFormRef "Doc2.SpecialF
doc2SpecialFormEmbedId = constructorNamed doc2SpecialFormRef "Doc2.SpecialForm.Embed"
doc2SpecialFormEmbedInlineId = constructorNamed doc2SpecialFormRef "Doc2.SpecialForm.EmbedInline"
pattern Doc2SpecialFormSource tm <- Term.App' (Term.Constructor' Doc2SpecialFormRef ((==) doc2SpecialFormSourceId -> True)) tm
pattern Doc2SpecialFormFoldedSource tm <- Term.App' (Term.Constructor' Doc2SpecialFormRef ((==) doc2SpecialFormFoldedSourceId -> True)) tm
pattern Doc2SpecialFormExample n tm <- Term.Apps' (Term.Constructor' Doc2SpecialFormRef ((==) doc2SpecialFormExampleId -> True)) [Term.Nat' n, tm]
pattern Doc2SpecialFormExampleBlock n tm <- Term.Apps' (Term.Constructor' Doc2SpecialFormRef ((==) doc2SpecialFormExampleBlockId -> True)) [Term.Nat' n, tm]
pattern Doc2SpecialFormLink tm <- Term.App' (Term.Constructor' Doc2SpecialFormRef ((==) doc2SpecialFormLinkId -> True)) tm
pattern Doc2SpecialFormSignature tm <- Term.App' (Term.Constructor' Doc2SpecialFormRef ((==) doc2SpecialFormSignatureId -> True)) tm
pattern Doc2SpecialFormSignatureInline tm <- Term.App' (Term.Constructor' Doc2SpecialFormRef ((==) doc2SpecialFormSignatureInlineId -> True)) tm
pattern Doc2SpecialFormEval tm <- Term.App' (Term.Constructor' Doc2SpecialFormRef ((==) doc2SpecialFormEvalId -> True)) tm
pattern Doc2SpecialFormEvalInline tm <- Term.App' (Term.Constructor' Doc2SpecialFormRef ((==) doc2SpecialFormEvalInlineId -> True)) tm
pattern Doc2SpecialFormEmbed any <- Term.App' (Term.Constructor' Doc2SpecialFormRef ((==) doc2SpecialFormEmbedId -> True)) any
pattern Doc2SpecialFormEmbedInline any <- Term.App' (Term.Constructor' Doc2SpecialFormRef ((==) doc2SpecialFormEmbedInlineId -> True)) any
pattern Doc2SpecialFormSource tm <- Term.App' (Term.Constructor' (ConstructorReference Doc2SpecialFormRef ((==) doc2SpecialFormSourceId -> True))) tm
pattern Doc2SpecialFormFoldedSource tm <- Term.App' (Term.Constructor' (ConstructorReference Doc2SpecialFormRef ((==) doc2SpecialFormFoldedSourceId -> True))) tm
pattern Doc2SpecialFormExample n tm <- Term.Apps' (Term.Constructor' (ConstructorReference Doc2SpecialFormRef ((==) doc2SpecialFormExampleId -> True))) [Term.Nat' n, tm]
pattern Doc2SpecialFormExampleBlock n tm <- Term.Apps' (Term.Constructor' (ConstructorReference Doc2SpecialFormRef ((==) doc2SpecialFormExampleBlockId -> True))) [Term.Nat' n, tm]
pattern Doc2SpecialFormLink tm <- Term.App' (Term.Constructor' (ConstructorReference Doc2SpecialFormRef ((==) doc2SpecialFormLinkId -> True))) tm
pattern Doc2SpecialFormSignature tm <- Term.App' (Term.Constructor' (ConstructorReference Doc2SpecialFormRef ((==) doc2SpecialFormSignatureId -> True))) tm
pattern Doc2SpecialFormSignatureInline tm <- Term.App' (Term.Constructor' (ConstructorReference Doc2SpecialFormRef ((==) doc2SpecialFormSignatureInlineId -> True))) tm
pattern Doc2SpecialFormEval tm <- Term.App' (Term.Constructor' (ConstructorReference Doc2SpecialFormRef ((==) doc2SpecialFormEvalId -> True))) tm
pattern Doc2SpecialFormEvalInline tm <- Term.App' (Term.Constructor' (ConstructorReference Doc2SpecialFormRef ((==) doc2SpecialFormEvalInlineId -> True))) tm
pattern Doc2SpecialFormEmbed any <- Term.App' (Term.Constructor' (ConstructorReference Doc2SpecialFormRef ((==) doc2SpecialFormEmbedId -> True))) any
pattern Doc2SpecialFormEmbedInline any <- Term.App' (Term.Constructor' (ConstructorReference Doc2SpecialFormRef ((==) doc2SpecialFormEmbedInlineId -> True))) any
-- pulls out `vs body` in `Doc2.Term (Any '(vs -> body))`, where
-- vs can be any number of parameters
@ -207,14 +208,14 @@ prettyIndentId = constructorNamed prettyAnnotatedRef "Pretty.Annotated.Indent"
prettyAppendId = constructorNamed prettyAnnotatedRef "Pretty.Annotated.Append"
prettyTableId = constructorNamed prettyAnnotatedRef "Pretty.Annotated.Table"
pattern PrettyEmpty ann <- Term.App' (Term.Constructor' PrettyAnnotatedRef ((==) prettyEmptyId -> True)) ann
pattern PrettyGroup ann tm <- Term.Apps' (Term.Constructor' PrettyAnnotatedRef ((==) prettyGroupId -> True)) [ann, tm]
pattern PrettyLit ann tm <- Term.Apps' (Term.Constructor' PrettyAnnotatedRef ((==) prettyLitId -> True)) [ann, tm]
pattern PrettyWrap ann tm <- Term.Apps' (Term.Constructor' PrettyAnnotatedRef ((==) prettyWrapId -> True)) [ann, tm]
pattern PrettyIndent ann i0 i1 tm <- Term.Apps' (Term.Constructor' PrettyAnnotatedRef ((==) prettyIndentId -> True)) [ann, i0, i1, tm]
pattern PrettyOrElse ann p1 p2 <- Term.Apps' (Term.Constructor' PrettyAnnotatedRef ((==) prettyOrElseId -> True)) [ann, p1, p2]
pattern PrettyTable ann rows <- Term.Apps' (Term.Constructor' PrettyAnnotatedRef ((==) prettyTableId -> True)) [ann, Term.List' rows]
pattern PrettyAppend ann tms <- Term.Apps' (Term.Constructor' PrettyAnnotatedRef ((==) prettyAppendId -> True)) [ann, Term.List' tms]
pattern PrettyEmpty ann <- Term.App' (Term.Constructor' (ConstructorReference PrettyAnnotatedRef ((==) prettyEmptyId -> True))) ann
pattern PrettyGroup ann tm <- Term.Apps' (Term.Constructor' (ConstructorReference PrettyAnnotatedRef ((==) prettyGroupId -> True))) [ann, tm]
pattern PrettyLit ann tm <- Term.Apps' (Term.Constructor' (ConstructorReference PrettyAnnotatedRef ((==) prettyLitId -> True))) [ann, tm]
pattern PrettyWrap ann tm <- Term.Apps' (Term.Constructor' (ConstructorReference PrettyAnnotatedRef ((==) prettyWrapId -> True))) [ann, tm]
pattern PrettyIndent ann i0 i1 tm <- Term.Apps' (Term.Constructor' (ConstructorReference PrettyAnnotatedRef ((==) prettyIndentId -> True))) [ann, i0, i1, tm]
pattern PrettyOrElse ann p1 p2 <- Term.Apps' (Term.Constructor' (ConstructorReference PrettyAnnotatedRef ((==) prettyOrElseId -> True))) [ann, p1, p2]
pattern PrettyTable ann rows <- Term.Apps' (Term.Constructor' (ConstructorReference PrettyAnnotatedRef ((==) prettyTableId -> True))) [ann, Term.List' rows]
pattern PrettyAppend ann tms <- Term.Apps' (Term.Constructor' (ConstructorReference PrettyAnnotatedRef ((==) prettyAppendId -> True))) [ann, Term.List' tms]
pattern PrettyRef <- ((== prettyRef) -> True)
@ -232,22 +233,22 @@ pattern AnsiColorRef <- ((== ansiColorRef) -> True)
"BrightMagenta", "BrightCyan", "BrightWhite" ]
where ct n = constructorNamed ansiColorRef ("ANSI.Color." <> n)
pattern AnsiColorBlack <- Term.Constructor' AnsiColorRef ((==) ansiColorBlackId -> True)
pattern AnsiColorRed <- Term.Constructor' AnsiColorRef ((==) ansiColorRedId -> True)
pattern AnsiColorGreen <- Term.Constructor' AnsiColorRef ((==) ansiColorGreenId -> True)
pattern AnsiColorYellow <- Term.Constructor' AnsiColorRef ((==) ansiColorYellowId -> True)
pattern AnsiColorBlue <- Term.Constructor' AnsiColorRef ((==) ansiColorBlueId -> True)
pattern AnsiColorMagenta <- Term.Constructor' AnsiColorRef ((==) ansiColorMagentaId -> True)
pattern AnsiColorCyan <- Term.Constructor' AnsiColorRef ((==) ansiColorCyanId -> True)
pattern AnsiColorWhite <- Term.Constructor' AnsiColorRef ((==) ansiColorWhiteId -> True)
pattern AnsiColorBrightBlack <- Term.Constructor' AnsiColorRef ((==) ansiColorBrightBlackId -> True)
pattern AnsiColorBrightRed <- Term.Constructor' AnsiColorRef ((==) ansiColorBrightRedId -> True)
pattern AnsiColorBrightGreen <- Term.Constructor' AnsiColorRef ((==) ansiColorBrightGreenId -> True)
pattern AnsiColorBrightYellow <- Term.Constructor' AnsiColorRef ((==) ansiColorBrightYellowId -> True)
pattern AnsiColorBrightBlue <- Term.Constructor' AnsiColorRef ((==) ansiColorBrightBlueId -> True)
pattern AnsiColorBrightMagenta <- Term.Constructor' AnsiColorRef ((==) ansiColorBrightMagentaId -> True)
pattern AnsiColorBrightCyan <- Term.Constructor' AnsiColorRef ((==) ansiColorBrightCyanId -> True)
pattern AnsiColorBrightWhite <- Term.Constructor' AnsiColorRef ((==) ansiColorBrightWhiteId -> True)
pattern AnsiColorBlack <- Term.Constructor' (ConstructorReference AnsiColorRef ((==) ansiColorBlackId -> True))
pattern AnsiColorRed <- Term.Constructor' (ConstructorReference AnsiColorRef ((==) ansiColorRedId -> True))
pattern AnsiColorGreen <- Term.Constructor' (ConstructorReference AnsiColorRef ((==) ansiColorGreenId -> True))
pattern AnsiColorYellow <- Term.Constructor' (ConstructorReference AnsiColorRef ((==) ansiColorYellowId -> True))
pattern AnsiColorBlue <- Term.Constructor' (ConstructorReference AnsiColorRef ((==) ansiColorBlueId -> True))
pattern AnsiColorMagenta <- Term.Constructor' (ConstructorReference AnsiColorRef ((==) ansiColorMagentaId -> True))
pattern AnsiColorCyan <- Term.Constructor' (ConstructorReference AnsiColorRef ((==) ansiColorCyanId -> True))
pattern AnsiColorWhite <- Term.Constructor' (ConstructorReference AnsiColorRef ((==) ansiColorWhiteId -> True))
pattern AnsiColorBrightBlack <- Term.Constructor' (ConstructorReference AnsiColorRef ((==) ansiColorBrightBlackId -> True))
pattern AnsiColorBrightRed <- Term.Constructor' (ConstructorReference AnsiColorRef ((==) ansiColorBrightRedId -> True))
pattern AnsiColorBrightGreen <- Term.Constructor' (ConstructorReference AnsiColorRef ((==) ansiColorBrightGreenId -> True))
pattern AnsiColorBrightYellow <- Term.Constructor' (ConstructorReference AnsiColorRef ((==) ansiColorBrightYellowId -> True))
pattern AnsiColorBrightBlue <- Term.Constructor' (ConstructorReference AnsiColorRef ((==) ansiColorBrightBlueId -> True))
pattern AnsiColorBrightMagenta <- Term.Constructor' (ConstructorReference AnsiColorRef ((==) ansiColorBrightMagentaId -> True))
pattern AnsiColorBrightCyan <- Term.Constructor' (ConstructorReference AnsiColorRef ((==) ansiColorBrightCyanId -> True))
pattern AnsiColorBrightWhite <- Term.Constructor' (ConstructorReference AnsiColorRef ((==) ansiColorBrightWhiteId -> True))
pattern ConsoleTextRef <- ((== consoleTextRef) -> True)
consoleTextPlainId = constructorNamed consoleTextRef "ConsoleText.Plain"
@ -257,12 +258,12 @@ consoleTextBoldId = constructorNamed consoleTextRef "ConsoleText.Bold"
consoleTextUnderlineId = constructorNamed consoleTextRef "ConsoleText.Underline"
consoleTextInvertId = constructorNamed consoleTextRef "ConsoleText.Invert"
pattern ConsoleTextPlain txt <- Term.App' (Term.Constructor' ConsoleTextRef ((==) consoleTextPlainId -> True)) txt
pattern ConsoleTextForeground color ct <- Term.Apps' (Term.Constructor' ConsoleTextRef ((==) consoleTextForegroundId -> True)) [color, ct]
pattern ConsoleTextBackground color ct <- Term.Apps' (Term.Constructor' ConsoleTextRef ((==) consoleTextBackgroundId -> True)) [color, ct]
pattern ConsoleTextBold ct <- Term.App' (Term.Constructor' ConsoleTextRef ((==) consoleTextBoldId -> True)) ct
pattern ConsoleTextUnderline ct <- Term.App' (Term.Constructor' ConsoleTextRef ((==) consoleTextUnderlineId -> True)) ct
pattern ConsoleTextInvert ct <- Term.App' (Term.Constructor' ConsoleTextRef ((==) consoleTextInvertId -> True)) ct
pattern ConsoleTextPlain txt <- Term.App' (Term.Constructor' (ConstructorReference ConsoleTextRef ((==) consoleTextPlainId -> True))) txt
pattern ConsoleTextForeground color ct <- Term.Apps' (Term.Constructor' (ConstructorReference ConsoleTextRef ((==) consoleTextForegroundId -> True))) [color, ct]
pattern ConsoleTextBackground color ct <- Term.Apps' (Term.Constructor' (ConstructorReference ConsoleTextRef ((==) consoleTextBackgroundId -> True))) [color, ct]
pattern ConsoleTextBold ct <- Term.App' (Term.Constructor' (ConstructorReference ConsoleTextRef ((==) consoleTextBoldId -> True))) ct
pattern ConsoleTextUnderline ct <- Term.App' (Term.Constructor' (ConstructorReference ConsoleTextRef ((==) consoleTextUnderlineId -> True))) ct
pattern ConsoleTextInvert ct <- Term.App' (Term.Constructor' (ConstructorReference ConsoleTextRef ((==) consoleTextInvertId -> True))) ct
constructorNamed :: R.Reference -> Text -> DD.ConstructorId
constructorNamed ref name =

5
parser-typechecker/src/Unison/Runtime/Interface.hs
View File

@ -44,6 +44,7 @@ import qualified Data.Map.Strict as Map
import qualified Unison.ABT as Tm (substs)
import qualified Unison.Term as Tm
import Unison.ConstructorReference (ConstructorReference, GConstructorReference(..))
import Unison.DataDeclaration (declFields, declDependencies, Decl)
import qualified Unison.HashQualified as HQ
import qualified Unison.Builtin.Decls as RF
@ -92,10 +93,10 @@ data EvalCtx
, ccache :: CCache
}
uncurryDspec :: DataSpec -> Map.Map (Reference,Int) Int
uncurryDspec :: DataSpec -> Map.Map ConstructorReference Int
uncurryDspec = Map.fromList . concatMap f . Map.toList
where
f (r,l) = zipWith (\n c -> ((r,n),c)) [0..] $ either id id l
f (r,l) = zipWith (\n c -> (ConstructorReference r n,c)) [0..] $ either id id l
cacheContext :: CCache -> EvalCtx
cacheContext

39
parser-typechecker/src/Unison/Runtime/Pattern.hs
View File

@ -11,7 +11,7 @@ module Unison.Runtime.Pattern
, builtinDataSpec
) where
import Control.Lens ((<&>))
import Control.Lens ((<&>), (^.))
import Control.Monad.State (State, state, evalState, runState, modify)
import Data.List (transpose)
@ -24,8 +24,9 @@ import qualified Data.Set as Set
import Unison.ABT
(absChain', visitPure, pattern AbsN', renames)
import Unison.Builtin.Decls (builtinDataDecls, builtinEffectDecls)
import qualified Unison.ConstructorReference as ConstructorReference
import Unison.ConstructorReference (ConstructorReference, GConstructorReference(..))
import Unison.DataDeclaration (declFields)
import Unison.DataDeclaration.ConstructorId (ConstructorId)
import Unison.Pattern
import qualified Unison.Pattern as P
import Unison.Reference (Reference(..))
@ -159,7 +160,7 @@ decomposePattern (Just rf0) t _ (P.Boolean _ b)
| rf0 == Rf.booleanRef
, t == if b then 1 else 0
= [[]]
decomposePattern (Just rf0) t nfields p@(P.Constructor _ rf u ps)
decomposePattern (Just rf0) t nfields p@(P.Constructor _ (ConstructorReference rf u) ps)
| t == u
, rf0 == rf
= if length ps == nfields
@ -168,7 +169,7 @@ decomposePattern (Just rf0) t nfields p@(P.Constructor _ rf u ps)
where
err = "decomposePattern: wrong number of constructor fields: "
++ show (nfields, p)
decomposePattern (Just rf0) t nfields p@(P.EffectBind _ rf u ps pk)
decomposePattern (Just rf0) t nfields p@(P.EffectBind _ (ConstructorReference rf u) ps pk)
| t == u
, rf0 == rf
= if length ps + 1 == nfields
@ -501,10 +502,10 @@ renameTo to from
normalizeSeqP :: P.Pattern a -> P.Pattern a
normalizeSeqP (P.As a p) = P.As a (normalizeSeqP p)
normalizeSeqP (P.EffectPure a p) = P.EffectPure a $ normalizeSeqP p
normalizeSeqP (P.EffectBind a r i ps k)
= P.EffectBind a r i (normalizeSeqP <$> ps) (normalizeSeqP k)
normalizeSeqP (P.Constructor a r i ps)
= P.Constructor a r i $ normalizeSeqP <$> ps
normalizeSeqP (P.EffectBind a r ps k)
= P.EffectBind a r (normalizeSeqP <$> ps) (normalizeSeqP k)
normalizeSeqP (P.Constructor a r ps)
= P.Constructor a r $ normalizeSeqP <$> ps
normalizeSeqP (P.SequenceLiteral a ps)
= P.SequenceLiteral a $ normalizeSeqP <$> ps
normalizeSeqP (P.SequenceOp a p0 op q0)
@ -530,12 +531,12 @@ prepareAs :: Var v => P.Pattern a -> v -> PPM v (P.Pattern v)
prepareAs (P.Unbound _) u = pure $ P.Var u
prepareAs (P.As _ p) u = (useVar >>= renameTo u) *> prepareAs p u
prepareAs (P.Var _) u = P.Var u <$ (renameTo u =<< useVar)
prepareAs (P.Constructor _ r i ps) u = do
P.Constructor u r i <$> traverse preparePattern ps
prepareAs (P.Constructor _ r ps) u = do
P.Constructor u r <$> traverse preparePattern ps
prepareAs (P.EffectPure _ p) u = do
P.EffectPure u <$> preparePattern p
prepareAs (P.EffectBind _ r i ps k) u = do
P.EffectBind u r i
prepareAs (P.EffectBind _ r ps k) u = do
P.EffectBind u r
<$> traverse preparePattern ps
<*> preparePattern k
prepareAs (P.SequenceLiteral _ ps) u = do
@ -554,11 +555,11 @@ prepareAs p u = pure $ u <$ p
preparePattern :: Var v => P.Pattern a -> PPM v (P.Pattern v)
preparePattern p = prepareAs p =<< freshVar
buildPattern :: Bool -> Reference -> ConstructorId -> [v] -> Int -> P.Pattern ()
buildPattern effect r t vs nfields
buildPattern :: Bool -> ConstructorReference -> [v] -> Int -> P.Pattern ()
buildPattern effect r vs nfields
| effect, [] <- vps = internalBug "too few patterns for effect bind"
| effect = P.EffectBind () r t (init vps) (last vps)
| otherwise = P.Constructor () r t vps
| effect = P.EffectBind () r (init vps) (last vps)
| otherwise = P.Constructor () r vps
where
vps | length vs < nfields
= replicate nfields $ P.Unbound ()
@ -661,7 +662,7 @@ buildCase
buildCase spec r eff cons ctx0 (t, vts, m)
= MatchCase pat Nothing . absChain' vs $ compile spec ctx m
where
pat = buildPattern eff r t vs $ cons !! t
pat = buildPattern eff (ConstructorReference r t) vs $ cons !! t
vs = ((),) . fst <$> vts
ctx = Map.fromList vts <> ctx0
@ -740,7 +741,7 @@ determineType = foldMap f
f P.Char{} = PData Rf.charRef
f P.SequenceLiteral{} = PData Rf.listRef
f P.SequenceOp{} = PData Rf.listRef
f (P.Constructor _ r _ _) = PData r
f (P.EffectBind _ r _ _ _) = PReq $ Set.singleton r
f (P.Constructor _ r _) = PData (r ^. ConstructorReference.reference_)
f (P.EffectBind _ r _ _) = PReq $ Set.singleton (r ^. ConstructorReference.reference_)
f P.EffectPure{} = PReq mempty
f _ = Unknown

17
parser-typechecker/src/Unison/Runtime/Serialize.hs
View File

@ -21,6 +21,7 @@ import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import Data.Word (Word8, Word64)
import Unison.ConstructorReference (ConstructorReference, GConstructorReference(..))
import Unison.Reference (Reference(..), pattern Derived, Id(..))
import Unison.Referent (Referent, pattern Ref, pattern Con)
@ -162,10 +163,9 @@ putReferent = \case
Ref r -> do
putWord8 0
putReference r
Con r i ct -> do
Con r ct -> do
putWord8 1
putReference r
putLength i
putConstructorReference r
putConstructorType ct
getReferent :: MonadGet m => m Referent
@ -173,7 +173,7 @@ getReferent = do
tag <- getWord8
case tag of
0 -> Ref <$> getReference
1 -> Con <$> getReference <*> getLength <*> getConstructorType
1 -> Con <$> getConstructorReference <*> getConstructorType
_ -> unknownTag "getReferent" tag
getConstructorType :: MonadGet m => m CT.ConstructorType
@ -218,6 +218,15 @@ getReference = do
1 -> DerivedId <$> (Id <$> getHash <*> getLength <*> getLength)
_ -> unknownTag "Reference" tag
putConstructorReference :: MonadPut m => ConstructorReference -> m ()
putConstructorReference (ConstructorReference r i) = do
putReference r
putLength i
getConstructorReference :: MonadGet m => m ConstructorReference
getConstructorReference =
ConstructorReference <$> getReference <*> getLength
instance Tag UPrim1 where
tag2word DECI = 0
tag2word INCI = 1

29
parser-typechecker/src/Unison/Server/Backend.hs
View File

@ -8,7 +8,7 @@
module Unison.Server.Backend where
import Control.Lens (_2, over)
import Control.Lens ((^.), _2, over)
import Control.Lens.Cons
import Control.Error.Util ((??),hush)
import Control.Monad.Except
@ -45,6 +45,8 @@ import Unison.Codebase.ShortBranchHash
( ShortBranchHash,
)
import qualified Unison.Codebase.ShortBranchHash as SBH
import Unison.ConstructorReference (GConstructorReference(..))
import qualified Unison.ConstructorReference as ConstructorReference
import qualified Unison.DataDeclaration as DD
import qualified Unison.DeclPrinter as DeclPrinter
import qualified Unison.HashQualified as HQ
@ -181,19 +183,18 @@ loadReferentType ::
m (Maybe (Type v Ann))
loadReferentType codebase = \case
Referent.Ref r -> Codebase.getTypeOfTerm codebase r
Referent.Con r cid _ -> getTypeOfConstructor r cid
Referent.Con r _ -> getTypeOfConstructor r
where
getTypeOfConstructor (Reference.DerivedId r) cid = do
-- Mitchell wonders: why was this definition copied from Unison.Codebase?
getTypeOfConstructor (ConstructorReference (Reference.DerivedId r) cid) = do
maybeDecl <- Codebase.getTypeDeclaration codebase r
pure $ case maybeDecl of
Nothing -> Nothing
Just decl -> DD.typeOfConstructor (either DD.toDataDecl id decl) cid
getTypeOfConstructor r cid =
getTypeOfConstructor r =
error $
"Don't know how to getTypeOfConstructor "
++ show r
++ " "
++ show cid
getRootBranch :: Functor m => Codebase m v Ann -> Backend m (Branch m)
getRootBranch =
@ -622,20 +623,6 @@ data DefinitionResults v =
noResults :: [HQ.HashQualified Name]
}
-- Separates type references from term references and returns types and terms,
-- respectively. For terms that are constructors, turns them into their data
-- types.
collateReferences
:: Foldable f
=> Foldable g
=> f Reference -- types requested
-> g Referent -- terms requested, including ctors
-> (Set Reference, Set Reference)
collateReferences (toList -> types) (toList -> terms) =
let terms' = [ r | Referent.Ref r <- terms ]
types' = [ r | Referent.Con r _ _ <- terms ]
in (Set.fromList types' <> Set.fromList types, Set.fromList terms')
expandShortBranchHash
:: Monad m => Codebase m v a -> ShortBranchHash -> Backend m Branch.Hash
expandShortBranchHash codebase hash = do
@ -965,7 +952,7 @@ definitionsBySuffixes namesScope branch codebase includeCycles query = do
where
f :: SR.SearchResult -> Maybe Reference
f = \case
SR.Tm' _ (Referent.Con r _ _) _ -> Just r
SR.Tm' _ (Referent.Con r _) _ -> Just (r ^. ConstructorReference.reference_)
SR.Tp' _ r _ -> Just r
_ -> Nothing
displayTerm :: Reference -> m (DisplayObject (Type v Ann) (Term v Ann))

6
parser-typechecker/src/Unison/Server/Doc.hs
View File

@ -9,6 +9,7 @@
module Unison.Server.Doc where
import Control.Lens ((^.), view)
import Control.Monad
import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
import Data.Foldable
@ -30,6 +31,7 @@ import qualified Unison.ABT as ABT
import qualified Unison.Builtin.Decls as DD
import qualified Unison.Builtin.Decls as Decls
import qualified Unison.Codebase.Editor.DisplayObject as DO
import qualified Unison.ConstructorReference as ConstructorReference
import qualified Unison.DataDeclaration as DD
import qualified Unison.DeclPrinter as DeclPrinter
import qualified Unison.NamePrinter as NP
@ -230,7 +232,7 @@ renderDoc pped terms typeOf eval types tm = eval tm >>= \case
goSrc :: [Term v ()] -> m [Ref (UnisonHash, DisplayObject SyntaxText Src)]
goSrc es = do
let toRef (Term.Ref' r) = Set.singleton r
toRef (Term.RequestOrCtor' r _) = Set.singleton r
toRef (Term.RequestOrCtor' r) = Set.singleton (r ^. ConstructorReference.reference_)
toRef _ = mempty
ppe = PPE.suffixifiedPPE pped
goType :: Reference -> m (Ref (UnisonHash, DisplayObject SyntaxText Src))
@ -273,7 +275,7 @@ renderDoc pped terms typeOf eval types tm = eval tm >>= \case
full tm typ =
formatPretty (TermPrinter.prettyBinding ppe name (Term.ann() tm typ))
pure (DO.UserObject (Src folded (full tm typ)))
Term.RequestOrCtor' r _ | Set.notMember r seen -> (:acc) <$> goType r
Term.RequestOrCtor' (view ConstructorReference.reference_ -> r) | Set.notMember r seen -> (:acc) <$> goType r
_ -> pure acc
DD.TupleTerm' [DD.EitherLeft' (Term.TypeLink' ref), _anns]
| Set.notMember ref seen

48
parser-typechecker/src/Unison/TermParser.hs
View File

@ -34,6 +34,7 @@ import qualified Data.Sequence as Sequence
import qualified Text.Megaparsec as P
import qualified Unison.ABT as ABT
import qualified Unison.Builtin.Decls as DD
import Unison.ConstructorReference (ConstructorReference, GConstructorReference(..))
import qualified Unison.ConstructorType as CT
import qualified Unison.HashQualified as HQ
import qualified Unison.Lexer as L
@ -160,8 +161,8 @@ matchCase = do
pat = case fst <$> pats of
[p] -> p
pats -> foldr pair (unit (ann . last $ pats)) pats
unit ann = Pattern.Constructor ann DD.unitRef 0 []
pair p1 p2 = Pattern.Constructor (ann p1 <> ann p2) DD.pairRef 0 [p1, p2]
unit ann = Pattern.Constructor ann (ConstructorReference DD.unitRef 0) []
pair p1 p2 = Pattern.Constructor (ann p1 <> ann p2) (ConstructorReference DD.pairRef 0) [p1, p2]
guardsAndBlocks <- many $ do
guard <- asum [ Nothing <$ P.try (reserved "|" *> quasikeyword "otherwise")
, optional $ reserved "|" *> infixAppOrBooleanOp ]
@ -202,9 +203,9 @@ parsePattern = root
char = (\c -> Pattern.Char (ann c) (L.payload c)) <$> character
parenthesizedOrTuplePattern :: P v (Pattern Ann, [(Ann, v)])
parenthesizedOrTuplePattern = tupleOrParenthesized parsePattern unit pair
unit ann = (Pattern.Constructor ann DD.unitRef 0 [], [])
unit ann = (Pattern.Constructor ann (ConstructorReference DD.unitRef 0) [], [])
pair (p1, v1) (p2, v2) =
(Pattern.Constructor (ann p1 <> ann p2) DD.pairRef 0 [p1, p2],
(Pattern.Constructor (ann p1 <> ann p2) (ConstructorReference DD.pairRef 0) [p1, p2],
v1 ++ v2)
-- Foo x@(Blah 10)
varOrAs :: P v (Pattern Ann, [(Ann, v)])
@ -216,7 +217,7 @@ parsePattern = root
else pure (Pattern.Var (ann v), [tokenToPair v])
unbound :: P v (Pattern Ann, [(Ann, v)])
unbound = (\tok -> (Pattern.Unbound (ann tok), [])) <$> blank
ctor :: CT.ConstructorType -> _ -> P v (L.Token (Reference, Int))
ctor :: CT.ConstructorType -> _ -> P v (L.Token ConstructorReference)
ctor ct err = do
-- this might be a var, so we avoid consuming it at first
tok <- P.try (P.lookAhead hqPrefixId)
@ -248,10 +249,9 @@ parsePattern = root
effectBind = do
(tok, leaves) <- P.try effectBind0
let (ref,cid) = L.payload tok
(cont, vsp) <- parsePattern
pure $
let f patterns vs = (Pattern.EffectBind (ann tok <> ann cont) ref cid patterns cont, vs ++ vsp)
let f patterns vs = (Pattern.EffectBind (ann tok <> ann cont) (L.payload tok) patterns cont, vs ++ vsp)
in unzipPatterns f leaves
effectPure = go <$> parsePattern where
@ -266,15 +266,13 @@ parsePattern = root
-- ex: unique type Day = Mon | Tue | ...
nullaryCtor = P.try $ do
tok <- ctor CT.Data UnknownDataConstructor
let (ref, cid) = L.payload tok
pure (Pattern.Constructor (ann tok) ref cid [], [])
pure (Pattern.Constructor (ann tok) (L.payload tok) [], [])
constructor = do
tok <- ctor CT.Data UnknownDataConstructor
let (ref,cid) = L.payload tok
f patterns vs =
let f patterns vs =
let loc = foldl (<>) (ann tok) $ map ann patterns
in (Pattern.Constructor loc ref cid patterns, vs)
in (Pattern.Constructor loc (L.payload tok) patterns, vs)
unzipPatterns f <$> many leaf
seqLiteral = Parser.seq f root
@ -520,12 +518,12 @@ docBlock = do
segs <- many segment
closeTok <- closeBlock
let a = ann openTok <> ann closeTok
pure . docNormalize $ Term.app a (Term.constructor a DD.docRef DD.docJoinId) (Term.list a segs)
pure . docNormalize $ Term.app a (Term.constructor a (ConstructorReference DD.docRef DD.docJoinId)) (Term.list a segs)
where
segment = blob <|> linky
blob = do
s <- string
pure $ Term.app (ann s) (Term.constructor (ann s) DD.docRef DD.docBlobId)
pure $ Term.app (ann s) (Term.constructor (ann s) (ConstructorReference DD.docRef DD.docBlobId))
(Term.text (ann s) (L.payload s))
linky = asum [include, signature, evaluate, source, link]
include = do
@ -535,29 +533,29 @@ docBlock = do
_ <- P.try (reserved "signature")
tok <- termLink'
pure $ Term.app (ann tok)
(Term.constructor (ann tok) DD.docRef DD.docSignatureId)
(Term.constructor (ann tok) (ConstructorReference DD.docRef DD.docSignatureId))
(Term.termLink (ann tok) (L.payload tok))
evaluate = do
_ <- P.try (reserved "evaluate")
tok <- termLink'
pure $ Term.app (ann tok)
(Term.constructor (ann tok) DD.docRef DD.docEvaluateId)
(Term.constructor (ann tok) (ConstructorReference DD.docRef DD.docEvaluateId))
(Term.termLink (ann tok) (L.payload tok))
source = do
_ <- P.try (reserved "source")
l <- link''
pure $ Term.app (ann l)
(Term.constructor (ann l) DD.docRef DD.docSourceId)
(Term.constructor (ann l) (ConstructorReference DD.docRef DD.docSourceId))
l
link'' = either ty t <$> link' where
t tok = Term.app (ann tok)
(Term.constructor (ann tok) DD.linkRef DD.linkTermId)
(Term.constructor (ann tok) (ConstructorReference DD.linkRef DD.linkTermId))
(Term.termLink (ann tok) (L.payload tok))
ty tok = Term.app (ann tok)
(Term.constructor (ann tok) DD.linkRef DD.linkTypeId)
(Term.constructor (ann tok) (ConstructorReference DD.linkRef DD.linkTypeId))
(Term.typeLink (ann tok) (L.payload tok))
link = d <$> link'' where
d tm = Term.app (ann tm) (Term.constructor (ann tm) DD.docRef DD.docLinkId) tm
d tm = Term.app (ann tm) (Term.constructor (ann tm) (ConstructorReference DD.docRef DD.docLinkId)) tm
-- Used by unbreakParas within docNormalize. Doc literals are a joined sequence
-- segments. This type describes a property of a segment.
@ -610,7 +608,7 @@ docNormalize :: (Ord v, Show v) => Term v a -> Term v a
docNormalize tm = case tm of
-- This pattern is just `DD.DocJoin seqs`, but exploded in order to grab
-- the annotations. The aim is just to map `normalize` over it.
a@(Term.App' c@(Term.Constructor' DD.DocRef DD.DocJoinId) s@(Term.List' seqs))
a@(Term.App' c@(Term.Constructor' (ConstructorReference DD.DocRef DD.DocJoinId)) s@(Term.List' seqs))
-> join (ABT.annotation a)
(ABT.annotation c)
(ABT.annotation s)
@ -806,12 +804,12 @@ docNormalize tm = case tm of
tracing when x =
(const id $ trace ("at " ++ when ++ ": " ++ (show x) ++ "\n")) x
blob aa ac at txt =
Term.app aa (Term.constructor ac DD.docRef DD.docBlobId) (Term.text at txt)
Term.app aa (Term.constructor ac (ConstructorReference DD.docRef DD.docBlobId)) (Term.text at txt)
join aa ac as segs =
Term.app aa (Term.constructor ac DD.docRef DD.docJoinId) (Term.list' as segs)
Term.app aa (Term.constructor ac (ConstructorReference DD.docRef DD.docJoinId)) (Term.list' as segs)
mapBlob :: Ord v => (Text -> Text) -> Term v a -> Term v a
-- this pattern is just `DD.DocBlob txt` but exploded to capture the annotations as well
mapBlob f (aa@(Term.App' ac@(Term.Constructor' DD.DocRef DD.DocBlobId) at@(Term.Text' txt)))
mapBlob f (aa@(Term.App' ac@(Term.Constructor' (ConstructorReference DD.DocRef DD.DocBlobId)) at@(Term.Text' txt)))
= blob (ABT.annotation aa) (ABT.annotation ac) (ABT.annotation at) (f txt)
mapBlob _ t = t
@ -1099,6 +1097,6 @@ tupleOrParenthesizedTerm = label "tuple" $ tupleOrParenthesized term DD.unitTerm
pair t1 t2 =
Term.app (ann t1 <> ann t2)
(Term.app (ann t1)
(Term.constructor (ann t1 <> ann t2) DD.pairRef 0)
(Term.constructor (ann t1 <> ann t2) (ConstructorReference DD.pairRef 0))
t1)
t2

75
parser-typechecker/src/Unison/TermPrinter.hs
View File

@ -6,6 +6,7 @@ module Unison.TermPrinter where
import Unison.Prelude
import Control.Lens ((^.))
import Control.Monad.State (evalState)
import qualified Control.Monad.State as State
import Data.List
@ -20,6 +21,8 @@ import qualified Unison.ABT as ABT
import qualified Unison.Blank as Blank
import Unison.Builtin.Decls (pattern TuplePattern, pattern TupleTerm')
import qualified Unison.Builtin.Decls as DD
import Unison.ConstructorReference (GConstructorReference(..))
import qualified Unison.ConstructorReference as ConstructorReference
import qualified Unison.ConstructorType as CT
import qualified Unison.HashQualified as HQ
import Unison.Lexer (showEscapeChar, symbolyId)
@ -212,16 +215,16 @@ pretty0
Just c -> "?\\" ++ [c]
Nothing -> '?': [c]
Blank' id -> fmt S.Blank $ l "_" <> l (fromMaybe "" (Blank.nameb id))
Constructor' ref cid ->
Constructor' ref ->
styleHashQualified'' (fmt $ S.TermReference conRef) name
where
name = elideFQN im $ PrettyPrintEnv.termName n conRef
conRef = Referent.Con ref cid CT.Data
Request' ref cid ->
conRef = Referent.Con ref CT.Data
Request' ref ->
styleHashQualified'' (fmt $ S.TermReference conRef) name
where
name = elideFQN im $ PrettyPrintEnv.termName n conRef
conRef = Referent.Con ref cid CT.Effect
conRef = Referent.Con ref CT.Effect
Handle' h body -> paren (p >= 2) $
if PP.isMultiLine pb || PP.isMultiLine ph then PP.lines [
(fmt S.ControlKeyword "handle") `PP.hang` pb,
@ -237,7 +240,7 @@ pretty0
ph = pblock h
pblock tm = let (im', uses) = calcImports im tm
in uses $ [pretty0 n (ac 0 Block im' doc) tm]
App' x (Constructor' DD.UnitRef 0) ->
App' x (Constructor' (ConstructorReference DD.UnitRef 0)) ->
paren (p >= 11 || isBlock x && p >= 3) $
fmt S.DelayForceChar (l "!")
<> pretty0 n (ac (if isBlock x then 0 else 10) Normal im doc) x
@ -376,7 +379,7 @@ pretty0
$ letIntro
$ uses [PP.lines (map printBinding bs ++ body e)]
where
body (Constructor' DD.UnitRef 0) | elideUnit = []
body (Constructor' (ConstructorReference DD.UnitRef 0)) | elideUnit = []
body e = [PP.group $ pretty0 n (ac 0 Normal im doc) e]
printBinding (v, binding) = if isBlank $ Var.nameStr v
then pretty0 n (ac (-1) Normal im doc) binding
@ -397,9 +400,9 @@ pretty0
nonForcePred :: Term3 v PrintAnnotation -> Bool
nonForcePred = \case
Constructor' DD.UnitRef 0 -> False
Constructor' DD.DocRef _ -> False
_ -> True
Constructor' (ConstructorReference DD.UnitRef 0) -> False
Constructor' (ConstructorReference DD.DocRef _) -> False
_ -> True
nonUnitArgPred :: Var v => v -> Bool
nonUnitArgPred v = (Var.name v) /= "()"
@ -454,15 +457,15 @@ prettyPattern n c@(AmbientContext { imports = im }) p vs patt = case patt of
TuplePattern pats | length pats /= 1 ->
let (pats_printed, tail_vs) = patterns (-1) vs pats
in (PP.parenthesizeCommas pats_printed, tail_vs)
Pattern.Constructor _ ref cid [] ->
Pattern.Constructor _ ref [] ->
(styleHashQualified'' (fmt $ S.TermReference conRef) name, vs)
where
name = elideFQN im $ PrettyPrintEnv.termName n conRef
conRef = Referent.Con ref cid CT.Data
Pattern.Constructor _ ref cid pats ->
conRef = Referent.Con ref CT.Data
Pattern.Constructor _ ref pats ->
let (pats_printed, tail_vs) = patternsSep 10 PP.softbreak vs pats
name = elideFQN im $ PrettyPrintEnv.termName n conRef
conRef = Referent.Con ref cid CT.Data
conRef = Referent.Con ref CT.Data
in ( paren (p >= 10)
$ styleHashQualified'' (fmt $ S.TermReference conRef) name
`PP.hang` pats_printed
@ -474,11 +477,11 @@ prettyPattern n c@(AmbientContext { imports = im }) p vs patt = case patt of
Pattern.EffectPure _ pat ->
let (printed, eventual_tail) = prettyPattern n c (-1) vs pat
in (PP.sep " " [fmt S.DelimiterChar "{", printed, fmt S.DelimiterChar "}"], eventual_tail)
Pattern.EffectBind _ ref cid pats k_pat ->
Pattern.EffectBind _ ref pats k_pat ->
let (pats_printed , tail_vs ) = patternsSep 10 PP.softbreak vs pats
(k_pat_printed, eventual_tail) = prettyPattern n c 0 tail_vs k_pat
name = elideFQN im $ PrettyPrintEnv.termName n conRef
conRef = Referent.Con ref cid CT.Effect
conRef = Referent.Con ref CT.Effect
in ( PP.group (
fmt S.DelimiterChar "{" <>
(PP.sep " " . PP.nonEmpty $
@ -919,9 +922,9 @@ suffixCounterTerm :: Var v => PrettyPrintEnv -> Term2 v at ap v a -> PrintAnnota
suffixCounterTerm n = \case
Var' v -> countHQ $ HQ.unsafeFromVar v
Ref' r -> countHQ $ PrettyPrintEnv.termName n (Referent.Ref r)
Constructor' r _ | noImportRefs r -> mempty
Constructor' r i -> countHQ $ PrettyPrintEnv.termName n (Referent.Con r i CT.Data)
Request' r i -> countHQ $ PrettyPrintEnv.termName n (Referent.Con r i CT.Effect)
Constructor' r | noImportRefs (r ^. ConstructorReference.reference_) -> mempty
Constructor' r -> countHQ $ PrettyPrintEnv.termName n (Referent.Con r CT.Data)
Request' r -> countHQ $ PrettyPrintEnv.termName n (Referent.Con r CT.Effect)
Ann' _ t -> countTypeUsages n t
Match' _ bs -> let pat (MatchCase p _ _) = p
in foldMap ((countPatternUsages n) . pat) bs
@ -945,22 +948,22 @@ countTypeUsages n t = snd $ annotation $ reannotateUp (suffixCounterType n) t
countPatternUsages :: PrettyPrintEnv -> Pattern loc -> PrintAnnotation
countPatternUsages n p = Pattern.foldMap' f p where
f = \case
Pattern.Unbound _ -> mempty
Pattern.Var _ -> mempty
Pattern.Boolean _ _ -> mempty
Pattern.Int _ _ -> mempty
Pattern.Nat _ _ -> mempty
Pattern.Float _ _ -> mempty
Pattern.Text _ _ -> mempty
Pattern.Char _ _ -> mempty
Pattern.As _ _ -> mempty
Pattern.SequenceLiteral _ _ -> mempty
Pattern.SequenceOp _ _ _ _ -> mempty
Pattern.EffectPure _ _ -> mempty
Pattern.EffectBind _ r i _ _ -> countHQ $ PrettyPrintEnv.patternName n r i
Pattern.Constructor _ r i _ ->
if noImportRefs r then mempty
else countHQ $ PrettyPrintEnv.patternName n r i
Pattern.Unbound _ -> mempty
Pattern.Var _ -> mempty
Pattern.Boolean _ _ -> mempty
Pattern.Int _ _ -> mempty
Pattern.Nat _ _ -> mempty
Pattern.Float _ _ -> mempty
Pattern.Text _ _ -> mempty
Pattern.Char _ _ -> mempty
Pattern.As _ _ -> mempty
Pattern.SequenceLiteral _ _ -> mempty
Pattern.SequenceOp _ _ _ _ -> mempty
Pattern.EffectPure _ _ -> mempty
Pattern.EffectBind _ r _ _ -> countHQ $ PrettyPrintEnv.patternName n r
Pattern.Constructor _ r _ ->
if noImportRefs (r ^. ConstructorReference.reference_) then mempty
else countHQ $ PrettyPrintEnv.patternName n r
countHQ :: HQ.HashQualified Name -> PrintAnnotation
countHQ hq = fold $ fmap countName (HQ.toName $ hq)
@ -1176,10 +1179,10 @@ isDestructuringBind scrutinee [MatchCase pat _ (ABT.AbsN' vs _)]
Pattern.Float _ _ -> True
Pattern.Text _ _ -> True
Pattern.Char _ _ -> True
Pattern.Constructor _ _ _ ps -> any hasLiteral ps
Pattern.Constructor _ _ ps -> any hasLiteral ps
Pattern.As _ p -> hasLiteral p
Pattern.EffectPure _ p -> hasLiteral p
Pattern.EffectBind _ _ _ ps pk -> any hasLiteral (pk : ps)
Pattern.EffectBind _ _ ps pk -> any hasLiteral (pk : ps)
Pattern.SequenceLiteral _ ps -> any hasLiteral ps
Pattern.SequenceOp _ p _ p2 -> hasLiteral p || hasLiteral p2
Pattern.Var _ -> False

44
parser-typechecker/src/Unison/Typechecker/Context.hs
View File

@ -64,6 +64,7 @@ import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified Unison.ABT as ABT
import qualified Unison.Blank as B
import Unison.ConstructorReference (ConstructorReference, GConstructorReference(..))
import Unison.DataDeclaration ( DataDeclaration
, EffectDeclaration
)
@ -107,7 +108,7 @@ universal' a v = ABT.annotatedVar a (TypeVar.Universal v)
-- | Elements of an ordered algorithmic context
data Element v loc
-- | A variable declaration
= Var (TypeVar v loc)
= Var (TypeVar v loc)
-- | `v` is solved to some monotype
| Solved (B.Blank loc) v (Monotype v loc)
-- | `v` has type `a`, maybe quantified
@ -210,7 +211,7 @@ data Unknown = Data | Effect deriving Show
data CompilerBug v loc
= UnknownDecl Unknown Reference (Map Reference (DataDeclaration v loc))
| UnknownConstructor Unknown Reference Int (DataDeclaration v loc)
| UnknownConstructor Unknown ConstructorReference (DataDeclaration v loc)
| UndeclaredTermVariable v (Context v loc)
| RetractFailure (Element v loc) (Context v loc)
| EmptyLetRec (Term v loc) -- the body of the empty let rec
@ -326,7 +327,7 @@ data Cause v loc
| UnknownSymbol loc v
| UnknownTerm loc v [Suggestion v loc] (Type v loc)
| AbilityCheckFailure [Type v loc] [Type v loc] (Context v loc) -- ambient, requested
| EffectConstructorWrongArgCount ExpectedArgCount ActualArgCount Reference ConstructorId
| EffectConstructorWrongArgCount ExpectedArgCount ActualArgCount ConstructorReference
| MalformedEffectBind (Type v loc) (Type v loc) [Type v loc] -- type of ctor, type of ctor result
-- Type of ctor, number of arguments we got
| PatternArityMismatch loc (Type v loc) Int
@ -709,10 +710,10 @@ getEffectDeclaration r = do
liftResult . typeError $ DataEffectMismatch Data r decl
Just decl -> pure decl
getDataConstructorType :: (Var v, Ord loc) => Reference -> Int -> M v loc (Type v loc)
getDataConstructorType :: (Var v, Ord loc) => ConstructorReference -> M v loc (Type v loc)
getDataConstructorType = getConstructorType' Data getDataDeclaration
getEffectConstructorType :: (Var v, Ord loc) => Reference -> Int -> M v loc (Type v loc)
getEffectConstructorType :: (Var v, Ord loc) => ConstructorReference -> M v loc (Type v loc)
getEffectConstructorType = getConstructorType' Effect go where
go r = DD.toDataDecl <$> getEffectDeclaration r
@ -721,13 +722,12 @@ getEffectConstructorType = getConstructorType' Effect go where
getConstructorType' :: Var v
=> Unknown
-> (Reference -> M v loc (DataDeclaration v loc))
-> Reference
-> Int
-> ConstructorReference
-> M v loc (Type v loc)
getConstructorType' kind get r cid = do
getConstructorType' kind get (ConstructorReference r cid) = do
decl <- get r
case drop cid (DD.constructors decl) of
[] -> compilerCrash $ UnknownConstructor kind r cid decl
[] -> compilerCrash $ UnknownConstructor kind (ConstructorReference r cid) decl
(_v, typ) : _ -> pure $ ABT.vmap TypeVar.Universal typ
extendUniversal :: (Var v) => v -> M v loc v
@ -988,12 +988,12 @@ synthesizeWanted (Term.Ann' (Term.Ref' _) t)
p (TypeVar.Existential _ v) = Set.singleton v
p _ = mempty
synthesizeWanted (Term.Constructor' r cid)
synthesizeWanted (Term.Constructor' r)
-- Constructors do not have effects
= (,[]) . Type.purifyArrows <$> getDataConstructorType r cid
synthesizeWanted tm@(Term.Request' r cid) =
= (,[]) . Type.purifyArrows <$> getDataConstructorType r
synthesizeWanted tm@(Term.Request' r) =
fmap (wantRequest tm) . ungeneralize . Type.purifyArrows
=<< getEffectConstructorType r cid
=<< getEffectConstructorType r
synthesizeWanted (Term.Let1Top' top binding e) = do
isClosed <- isClosed binding
-- note: no need to freshen binding, it can't refer to v
@ -1164,9 +1164,9 @@ checkCases scrutType outType cases@(Term.MatchCase _ _ t : _)
coalesceWanteds =<< traverse (checkCase scrutType' outType) cases
getEffect
:: Var v => Ord loc => Reference -> Int -> M v loc (Type v loc)
getEffect ref cid = do
ect <- getEffectConstructorType ref cid
:: Var v => Ord loc => ConstructorReference -> M v loc (Type v loc)
getEffect ref = do
ect <- getEffectConstructorType ref
uect <- ungeneralize ect
let final (Type.Arrow' _ o) = final o
final t = t
@ -1182,8 +1182,8 @@ requestType ps = getCompose . fmap fold $ traverse single ps
where
single (Pattern.As _ p) = single p
single Pattern.EffectPure{} = Compose . pure . Just $ []
single (Pattern.EffectBind _ ref cid _ _)
= Compose $ Just . pure <$> getEffect ref cid
single (Pattern.EffectBind _ ref _ _)
= Compose $ Just . pure <$> getEffect ref
single _ = Compose $ pure Nothing
checkCase :: forall v loc . (Var v, Ord loc)
@ -1299,8 +1299,8 @@ checkPattern scrutineeType p =
lift $ subtype (Type.text loc) scrutineeType $> mempty
Pattern.Char loc _ ->
lift $ subtype (Type.char loc) scrutineeType $> mempty
Pattern.Constructor loc ref cid args -> do
dct <- lift $ getDataConstructorType ref cid
Pattern.Constructor loc ref args -> do
dct <- lift $ getDataConstructorType ref
udct <- lift $ skolemize forcedData dct
unless (Type.arity udct == length args)
. lift
@ -1332,7 +1332,7 @@ checkPattern scrutineeType p =
applyM vt
checkPattern vt p
-- ex: { Stream.emit x -> k } -> ...
Pattern.EffectBind loc ref cid args k -> do
Pattern.EffectBind loc ref args k -> do
-- scrutineeType should be a supertype of `Effect e vt`
-- for fresh existentials `e` and `vt`
e <- lift $ extendExistential Var.inferPatternBindE
@ -1340,7 +1340,7 @@ checkPattern scrutineeType p =
let evt = Type.effectV loc (loc, existentialp loc e)
(loc, existentialp loc v)
lift $ subtype evt scrutineeType
ect <- lift $ getEffectConstructorType ref cid
ect <- lift $ getEffectConstructorType ref
uect <- lift $ skolemize forcedEffect ect
unless (Type.arity uect == length args)
. lift

8
parser-typechecker/src/Unison/Typechecker/Extractor.hs
View File

@ -6,7 +6,7 @@ import Control.Monad.Reader
import qualified Data.List as List
import Data.List.NonEmpty ( NonEmpty )
import qualified Data.Set as Set
import Unison.Reference ( Reference )
import Unison.ConstructorReference (ConstructorReference)
import qualified Unison.Term as Term
import qualified Unison.Type as Type
import qualified Unison.Typechecker.Context as C
@ -259,10 +259,10 @@ effectConstructorWrongArgCount
:: ErrorExtractor
v
loc
(C.ExpectedArgCount, C.ActualArgCount, Reference, C.ConstructorId)
(C.ExpectedArgCount, C.ActualArgCount, ConstructorReference)
effectConstructorWrongArgCount = cause >>= \case
C.EffectConstructorWrongArgCount expected actual r cid ->
pure (expected, actual, r, cid)
C.EffectConstructorWrongArgCount expected actual r ->
pure (expected, actual, r)
_ -> mzero
malformedEffectBind

15
parser-typechecker/src/Unison/Typechecker/TypeLookup.hs
View File

@ -2,8 +2,9 @@ module Unison.Typechecker.TypeLookup where
import Unison.Prelude
import Unison.ConstructorReference (ConstructorReference, GConstructorReference(..))
import Unison.Reference (Reference)
import Unison.Referent (Referent, ConstructorId)
import Unison.Referent (Referent)
import Unison.Type (Type)
import qualified Data.Map as Map
import qualified Unison.ConstructorType as CT
@ -21,8 +22,8 @@ data TypeLookup v a =
typeOfReferent :: TypeLookup v a -> Referent -> Maybe (Type v a)
typeOfReferent tl r = case r of
Referent.Ref r -> typeOfTerm tl r
Referent.Con r cid CT.Data -> typeOfDataConstructor tl r cid
Referent.Con r cid CT.Effect -> typeOfEffectConstructor tl r cid
Referent.Con r CT.Data -> typeOfDataConstructor tl r
Referent.Con r CT.Effect -> typeOfEffectConstructor tl r
-- bombs if not found
unsafeConstructorType :: TypeLookup v a -> Reference -> CT.ConstructorType
@ -35,12 +36,12 @@ constructorType tl r =
(const CT.Data <$> Map.lookup r (dataDecls tl)) <|>
(const CT.Effect <$> Map.lookup r (effectDecls tl))
typeOfDataConstructor :: TypeLookup v a -> Reference -> ConstructorId -> Maybe (Type v a)
typeOfDataConstructor tl r cid = go =<< Map.lookup r (dataDecls tl)
typeOfDataConstructor :: TypeLookup v a -> ConstructorReference -> Maybe (Type v a)
typeOfDataConstructor tl (ConstructorReference r cid) = go =<< Map.lookup r (dataDecls tl)
where go dd = DD.typeOfConstructor dd cid
typeOfEffectConstructor :: TypeLookup v a -> Reference -> ConstructorId -> Maybe (Type v a)
typeOfEffectConstructor tl r cid = go =<< Map.lookup r (effectDecls tl)
typeOfEffectConstructor :: TypeLookup v a -> ConstructorReference -> Maybe (Type v a)
typeOfEffectConstructor tl (ConstructorReference r cid) = go =<< Map.lookup r (effectDecls tl)
where go dd = DD.typeOfConstructor (DD.toDataDecl dd) cid
typeOfTerm :: TypeLookup v a -> Reference -> Maybe (Type v a)

5
parser-typechecker/src/Unison/UnisonFile.hs
View File

@ -39,6 +39,7 @@ import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Unison.ABT as ABT
import qualified Unison.Builtin.Decls as DD
import Unison.ConstructorReference (GConstructorReference(..))
import qualified Unison.ConstructorType as CT
import Unison.DataDeclaration (DataDeclaration, EffectDeclaration (..))
import qualified Unison.DataDeclaration as DD
@ -193,7 +194,7 @@ hashConstructors
:: forall v a. Ord v => TypecheckedUnisonFile v a -> Map v Referent.Id
hashConstructors file =
let ctors1 = Map.elems (dataDeclarationsId' file) >>= \(ref, dd) ->
[ (v, Referent.ConId ref i CT.Data) | (v,i) <- DD.constructorVars dd `zip` [0 ..] ]
[ (v, Referent.ConId (ConstructorReference ref i) CT.Data) | (v,i) <- DD.constructorVars dd `zip` [0 ..] ]
ctors2 = Map.elems (effectDeclarationsId' file) >>= \(ref, dd) ->
[ (v, Referent.ConId ref i CT.Effect) | (v,i) <- DD.constructorVars (DD.toDataDecl dd) `zip` [0 ..] ]
[ (v, Referent.ConId (ConstructorReference ref i) CT.Effect) | (v,i) <- DD.constructorVars (DD.toDataDecl dd) `zip` [0 ..] ]
in Map.fromList (ctors1 ++ ctors2)

9
parser-typechecker/tests/Unison/Test/ANF.hs
View File

@ -6,6 +6,7 @@ module Unison.Test.ANF where
import EasyTest
import Unison.ABT.Normalized (Term(TAbs))
import Unison.ConstructorReference (GConstructorReference(..))
import qualified Unison.Pattern as P
import Unison.Reference (Reference)
import Unison.Runtime.ANF as ANF
@ -99,9 +100,9 @@ denormalize (TApp f args) = Term.apps' df (Term.var () <$> args)
FVar v -> Term.var () v
FComb _ -> error "FComb"
FCon r n ->
Term.constructor () r (fromIntegral $ rawTag n)
Term.constructor () (ConstructorReference r (fromIntegral $ rawTag n))
FReq r n ->
Term.request () r (fromIntegral $ rawTag n)
Term.request () (ConstructorReference r (fromIntegral $ rawTag n))
FPrim _ -> error "FPrim"
FCont _ -> error "denormalize FCont"
denormalize (TFrc _) = error "denormalize TFrc"
@ -147,7 +148,7 @@ denormalizeMatch b
ipat r _ i
| r == Ty.natRef = P.Nat () $ fromIntegral i
| otherwise = P.Int () $ fromIntegral i
dpat r n t = P.Constructor () r (fromEnum t) (replicate n $ P.Var ())
dpat r n t = P.Constructor () (ConstructorReference r (fromEnum t)) (replicate n $ P.Var ())
denormalizeBranch :: (Num a, Var v) =>
Term ANormalF v -> (a, ABT.Term (Term.F v () ()) v ())
@ -171,7 +172,7 @@ denormalizeHandler cs df = dcs
where (_, db) = denormalizeBranch df
rf r rcs = foldMapWithKey (cf r) rcs
cf r t b = [ Term.MatchCase
(P.EffectBind () r (fromEnum t)
(P.EffectBind () (ConstructorReference r (fromEnum t))
(replicate n $ P.Var ()) (P.Var ()))
Nothing
db

7
unison-cli/src/Unison/Codebase/Editor/AuthorInfo.hs
View File

@ -9,6 +9,7 @@ import qualified Data.Map as Map
import Data.Text (Text)
import qualified Unison.Hashing.V2.Convert as H
import Unison.Prelude (MonadIO, Word8)
import Unison.ConstructorReference (GConstructorReference(..))
import qualified Unison.Reference as Reference
import Unison.Term (Term)
import qualified Unison.Term as Term
@ -30,7 +31,7 @@ createAuthorInfo a t = createAuthorInfo' . unpack <$> liftIO (getRandomBytes 32)
hashAndWrangle "guid" $
Term.app
a
(Term.constructor a guidTypeRef 0)
(Term.constructor a (ConstructorReference guidTypeRef 0))
( Term.app
a
(Term.builtin a "Bytes.fromList")
@ -40,7 +41,7 @@ createAuthorInfo a t = createAuthorInfo' . unpack <$> liftIO (getRandomBytes 32)
[(authorRef, authorTerm)] =
hashAndWrangle "author" $
Term.apps
(Term.constructor a authorTypeRef 0)
(Term.constructor a (ConstructorReference authorTypeRef 0))
[ (a, Term.ref a (Reference.DerivedId guidRef)),
(a, Term.text a t)
]
@ -48,7 +49,7 @@ createAuthorInfo a t = createAuthorInfo' . unpack <$> liftIO (getRandomBytes 32)
[(chRef, chTerm)] =
hashAndWrangle "copyrightHolder" $
Term.apps
(Term.constructor a chTypeRef 0)
(Term.constructor a (ConstructorReference chTypeRef 0))
[ (a, Term.ref a (Reference.DerivedId guidRef)),
(a, Term.text a t)
]

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

@ -77,6 +77,7 @@ import qualified Unison.CommandLine.DisplayValues as DisplayValues
import qualified Unison.CommandLine.FuzzySelect as Fuzzy
import qualified Unison.CommandLine.InputPattern as InputPattern
import qualified Unison.CommandLine.InputPatterns as InputPatterns
import Unison.ConstructorReference (GConstructorReference(..))
import qualified Unison.DataDeclaration as DD
import qualified Unison.HashQualified as HQ
import qualified Unison.HashQualified' as HQ'
@ -1453,13 +1454,13 @@ loop = do
oks results =
[ (r, msg)
| (r, Term.List' ts) <- Map.toList results,
Term.App' (Term.Constructor' ref cid) (Term.Text' msg) <- toList ts,
Term.App' (Term.Constructor' (ConstructorReference ref cid)) (Term.Text' msg) <- toList ts,
cid == DD.okConstructorId && ref == DD.testResultRef
]
fails results =
[ (r, msg)
| (r, Term.List' ts) <- Map.toList results,
Term.App' (Term.Constructor' ref cid) (Term.Text' msg) <- toList ts,
Term.App' (Term.Constructor' (ConstructorReference ref cid)) (Term.Text' msg) <- toList ts,
cid == DD.failConstructorId && ref == DD.testResultRef
]
cachedTests <- fmap Map.fromList . eval $ LoadWatches WK.TestWatch testRefs
@ -1565,13 +1566,13 @@ loop = do
let oks results =
[ (r, msg)
| (r, Term.List' ts) <- results,
Term.App' (Term.Constructor' ref cid) (Term.Text' msg) <- toList ts,
Term.App' (Term.Constructor' (ConstructorReference ref cid)) (Term.Text' msg) <- toList ts,
cid == DD.okConstructorId && ref == DD.testResultRef
]
fails results =
[ (r, msg)
| (r, Term.List' ts) <- results,
Term.App' (Term.Constructor' ref cid) (Term.Text' msg) <- toList ts,
Term.App' (Term.Constructor' (ConstructorReference ref cid)) (Term.Text' msg) <- toList ts,
cid == DD.failConstructorId && ref == DD.testResultRef
]
@ -1672,7 +1673,7 @@ loop = do
eval (LoadTerm i) <&> \case
Nothing -> error $ "What happened to " ++ show i ++ "?"
Just tm -> Set.delete r $ Term.dependencies tm
tm con@(Referent.Con (Reference.DerivedId i) cid _ct) =
tm con@(Referent.Con (ConstructorReference (Reference.DerivedId i) cid) _ct) =
eval (LoadType i) <&> \case
Nothing -> error $ "What happened to " ++ show i ++ "?"
Just decl -> case DD.typeOfConstructor (DD.asDataDecl decl) cid of
@ -1796,7 +1797,7 @@ handleDependents hq = do
dependents <-
let tp r = eval $ GetDependents r
tm (Referent.Ref r) = eval $ GetDependents r
tm (Referent.Con r _i _ct) = eval $ GetDependents r
tm (Referent.Con (ConstructorReference r _cid) _ct) = eval $ GetDependents r
in LD.fold tp tm ld
-- Use an unsuffixified PPE here, so we display full names (relative to the current path), rather than the shortest possible
-- unambiguous name.
@ -3306,7 +3307,7 @@ diffHelper before after = do
loadTypeOfTerm :: Referent -> Action m i v (Maybe (Type v Ann))
loadTypeOfTerm (Referent.Ref r) = eval $ LoadTypeOfTerm r
loadTypeOfTerm (Referent.Con (Reference.DerivedId r) cid _) = do
loadTypeOfTerm (Referent.Con (ConstructorReference (Reference.DerivedId r) cid) _) = do
decl <- eval $ LoadType r
case decl of
Just (either DD.toDataDecl id -> dd) -> pure $ DD.typeOfConstructor dd cid

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

@ -21,6 +21,7 @@ import Unison.Codebase.Editor.Command
import Unison.Codebase.Editor.Output
import Unison.Codebase.Patch ( Patch(..) )
import qualified Unison.Codebase.Patch as Patch
import Unison.ConstructorReference (GConstructorReference(..))
import Unison.DataDeclaration ( Decl )
import qualified Unison.DataDeclaration as Decl
import qualified Unison.Name as Name
@ -123,8 +124,8 @@ propagateCtorMapping oldComponent newComponent = let
, (newC, (_,newName,_)) <- zip [0 ..] $ Decl.constructors' newDecl
, ol'Name == newName || (isSingleton (Decl.asDataDecl oldDecl) && isSingleton newDecl)
, oldR /= newR
, let oldCon = Referent.Con oldR oldC t
newCon = Referent.Con newR newC t
, let oldCon = Referent.Con (ConstructorReference oldR oldC) t
newCon = Referent.Con (ConstructorReference newR newC) t
]
in if debugMode then traceShow ("constructorMappings", r) r else r
@ -182,8 +183,8 @@ genInitialCtorMapping rootNames initialTypeReplacements = do
, let t = Decl.constructorType oldDecl
, (oldC, _) <- zip [0 ..] $ Decl.constructors' (Decl.asDataDecl oldDecl)
, (newC, _) <- zip [0 ..] $ Decl.constructors' newDecl
, let oldCon = Referent.Con oldR oldC t
newCon = Referent.Con newR newC t
, let oldCon = Referent.Con (ConstructorReference oldR oldC) t
newCon = Referent.Con (ConstructorReference newR newC) t
, ctorNamesMatch oldCon newCon
|| (isSingleton (Decl.asDataDecl oldDecl) && isSingleton newDecl)
, oldR /= newR
@ -581,7 +582,7 @@ applyPropagate patch Edits {..} = do
updateLevel termEdits typeEdits termTypes Branch0 {..} =
Branch.branch0 terms types _children _edits
where
isPropagatedReferent (Referent.Con _ _ _) = True
isPropagatedReferent (Referent.Con _ _) = True
isPropagatedReferent (Referent.Ref r) = isPropagated r
terms0 = Star3.replaceFacts replaceConstructor constructorReplacements _terms
@ -606,7 +607,7 @@ applyPropagate patch Edits {..} = do
else Metadata.delete (propagatedMd r')) $ s
replaceConstructor :: Referent -> Referent -> _ -> _
replaceConstructor (Referent.Con _ _ _) !new s =
replaceConstructor (Referent.Con _ _) !new s =
-- TODO: revisit this once patches have constructor mappings
-- at the moment, all constructor replacements are autopropagated
-- rather than added manually

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

@ -7,6 +7,7 @@ module Unison.Codebase.Editor.SlurpResult where
import Unison.Prelude
import Control.Lens ((^.))
import Unison.Codebase.Editor.SlurpComponent (SlurpComponent(..))
import Unison.Name ( Name )
import Unison.Parser.Ann ( Ann )
@ -14,6 +15,7 @@ import Unison.Var (Var)
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Unison.Codebase.Editor.SlurpComponent as SC
import qualified Unison.ConstructorReference as ConstructorReference
import qualified Unison.DataDeclaration as DD
import qualified Unison.DeclPrinter as DeclPrinter
import qualified Unison.HashQualified as HQ
@ -75,7 +77,7 @@ constructorsFor types uf = let
names = UF.typecheckedToNames uf
typesRefs = Set.unions $ Names.typesNamed names . Name.unsafeFromVar <$> toList types
ctorNames = R.filterRan isOkCtor (Names.terms names)
isOkCtor (Referent.Con r _ _) | Set.member r typesRefs = True
isOkCtor (Referent.Con r _) | Set.member (r ^. ConstructorReference.reference_) typesRefs = True
isOkCtor _ = False
in Set.map Name.toVar $ R.dom ctorNames

23
unison-cli/src/Unison/CommandLine/DisplayValues.hs
View File

@ -6,6 +6,8 @@ module Unison.CommandLine.DisplayValues where
import Unison.Prelude
import Control.Lens ((^.))
import Unison.ConstructorReference (GConstructorReference(..))
import Unison.Reference (Reference)
import Unison.Referent (Referent)
import Unison.Term (Term)
@ -13,6 +15,7 @@ import Unison.Type (Type)
import Unison.Var (Var)
import qualified Data.Map as Map
import qualified Unison.ABT as ABT
import qualified Unison.ConstructorReference as ConstructorReference
import qualified Unison.Runtime.IOSource as DD
import qualified Unison.Builtin.Decls as DD
import qualified Unison.DataDeclaration as DD
@ -68,7 +71,7 @@ displayTerm' :: (Var v, Monad m)
-> Term v ()
-> m Pretty
displayTerm' elideUnit pped terms typeOf eval types = \case
tm@(Term.Apps' (Term.Constructor' typ _) _)
tm@(Term.Apps' (Term.Constructor' (ConstructorReference typ _)) _)
| typ == DD.docRef -> displayDoc pped terms typeOf eval types tm
| typ == DD.doc2Ref -> do
-- Pretty.get (doc.formatConsole tm)
@ -130,7 +133,7 @@ displayPretty pped terms typeOf eval types tm = go tm
-- to do some ascii art rendering
let tys = [ ref | DD.TupleTerm' [DD.EitherLeft' (Term.TypeLink' ref),_anns] <- toList es ]
toRef (Term.Ref' r) = Just r
toRef (Term.RequestOrCtor' r _) = Just r
toRef (Term.RequestOrCtor' r) = Just (r ^. ConstructorReference.reference_)
toRef _ = Nothing
tms = [ ref | DD.TupleTerm' [DD.EitherRight' (DD.Doc2Term (toRef -> Just ref)),_anns] <- toList es ]
typeMap <- let
@ -179,10 +182,10 @@ displayPretty pped terms typeOf eval types tm = go tm
in case e of
DD.EitherLeft' (Term.TypeLink' ref) -> go $ PPE.typeName ppe ref
DD.EitherRight' (DD.Doc2Term (Term.Ref' ref)) -> go $ PPE.termName ppe (Referent.Ref ref)
DD.EitherRight' (DD.Doc2Term (Term.Request' ref cid)) ->
go $ PPE.termName ppe (Referent.Con ref cid CT.Effect)
DD.EitherRight' (DD.Doc2Term (Term.Constructor' ref cid)) ->
go $ PPE.termName ppe (Referent.Con ref cid CT.Data)
DD.EitherRight' (DD.Doc2Term (Term.Request' ref)) ->
go $ PPE.termName ppe (Referent.Con ref CT.Effect)
DD.EitherRight' (DD.Doc2Term (Term.Constructor' ref)) ->
go $ PPE.termName ppe (Referent.Con ref CT.Data)
_ -> P.red <$> displayTerm pped terms typeOf eval types e
-- Signature [Doc2.Term]
@ -225,8 +228,8 @@ displayPretty pped terms typeOf eval types tm = go tm
toReferent tm = case tm of
Term.Ref' r -> Just (Referent.Ref r)
Term.Constructor' r cid -> Just (Referent.Con r cid CT.Data)
Term.Request' r cid -> Just (Referent.Con r cid CT.Effect)
Term.Constructor' r -> Just (Referent.Con r CT.Data)
Term.Request' r -> Just (Referent.Con r CT.Effect)
_ -> Nothing
goSignature r = typeOf r >>= \case
@ -303,13 +306,13 @@ displayDoc pped terms typeOf evaluated types = go
in terms ref >>= \case
Nothing -> pure $ "😶 Missing term source for: " <> termName ppe r
Just tm -> pure $ TP.pretty ppe tm
Referent.Con r _ _ -> pure $ typeName (PPE.declarationPPE pped r) r
Referent.Con (ConstructorReference r _) _ -> pure $ typeName (PPE.declarationPPE pped r) r
prettyTerm terms r = case r of
Referent.Ref (Reference.Builtin _) -> prettySignature r
Referent.Ref ref -> let ppe = PPE.declarationPPE pped ref in terms ref >>= \case
Nothing -> pure $ "😶 Missing term source for: " <> termName ppe r
Just tm -> pure . P.syntaxToColor $ P.group $ TP.prettyBinding ppe (PPE.termName ppe r) tm
Referent.Con r _ _ -> prettyType r
Referent.Con (ConstructorReference r _) _ -> prettyType r
prettyType r = let ppe = PPE.declarationPPE pped r in types r >>= \case
Nothing -> pure $ "😶 Missing type source for: " <> typeName ppe r
Just ty -> pure . P.syntaxToColor $ P.group $ DP.prettyDecl pped r (PPE.typeName ppe r) ty

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

@ -59,6 +59,7 @@ import Unison.CommandLine
)
import Unison.CommandLine.InputPatterns (makeExample, makeExample')
import qualified Unison.CommandLine.InputPatterns as IP
import Unison.ConstructorReference (GConstructorReference(..))
import qualified Unison.DataDeclaration as DD
import qualified Unison.DeclPrinter as DeclPrinter
import qualified Unison.Hash as Hash
@ -2398,7 +2399,7 @@ watchPrinter src ppe ann kind term isHit =
extra = " " <> replicate (length kind) ' ' -- for the ` | > ` after the line number
line = lines !! (lineNum - 1)
addCache p = if isHit then p <> " (cached)" else p
renderTest (Term.App' (Term.Constructor' _ id) (Term.Text' msg)) =
renderTest (Term.App' (Term.Constructor' (ConstructorReference _ id)) (Term.Text' msg)) =
"\n"
<> if id == DD.okConstructorId
then
@ -2548,7 +2549,7 @@ isTestOk :: Term v Ann -> Bool
isTestOk tm = case tm of
Term.List' ts -> all isSuccess ts
where
isSuccess (Term.App' (Term.Constructor' ref cid) _) =
isSuccess (Term.App' (Term.Constructor' (ConstructorReference ref cid)) _) =
cid == DD.okConstructorId
&& ref == DD.testResultRef
isSuccess _ = False

35
unison-core/src/Unison/ConstructorReference.hs Normal file
View File

@ -0,0 +1,35 @@
-- | The constructor reference type.
module Unison.ConstructorReference
( GConstructorReference (..),
ConstructorReference,
ConstructorReferenceId,
reference_,
toShortHash,
)
where
import Control.Lens
import Unison.DataDeclaration.ConstructorId (ConstructorId)
import Unison.Prelude
import Unison.Reference (TypeReference, TypeReferenceId)
import qualified Unison.Reference as Reference
import Unison.ShortHash (ShortHash)
import qualified Unison.ShortHash as ShortHash
-- | A reference to a constructor is represented by a reference to its type declaration, plus the ordinal constructor id.
data GConstructorReference r
= ConstructorReference !r !ConstructorId
deriving stock (Eq, Functor, Ord, Show)
type ConstructorReference = GConstructorReference TypeReference
type ConstructorReferenceId = GConstructorReference TypeReferenceId
-- | A lens onto the reference part of a constructor reference.
reference_ :: Lens (GConstructorReference r) (GConstructorReference s) r s
reference_ =
lens (\(ConstructorReference r _) -> r) \(ConstructorReference _ i) r -> ConstructorReference r i
toShortHash :: ConstructorReference -> ShortHash
toShortHash (ConstructorReference r i) =
(Reference.toShortHash r) {ShortHash.cid = Just (tShow i)}

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

@ -44,6 +44,7 @@ import qualified Data.Map as Map
import qualified Data.Set as Set
import Prelude.Extras (Show1)
import qualified Unison.ABT as ABT
import Unison.ConstructorReference (GConstructorReference(..))
import qualified Unison.ConstructorType as CT
import Unison.DataDeclaration.ConstructorId (ConstructorId)
import qualified Unison.Name as Name
@ -120,7 +121,7 @@ generateRecordAccessors fields typename typ =
(Term.var ann argname)
[Term.MatchCase pat Nothing rhs]
where
pat = Pattern.Constructor ann typ 0 cargs
pat = Pattern.Constructor ann (ConstructorReference typ 0) cargs
cargs = [ if j == i then Pattern.Var ann else Pattern.Unbound ann
| (_, j) <- fields `zip` [0..]]
rhs = ABT.abs' ann fname (Term.var ann fname)
@ -131,10 +132,10 @@ generateRecordAccessors fields typename typ =
where
fname' = Var.named . Var.name $
Var.freshIn (Set.fromList $ [argname] <> (fst <$> fields)) fname
pat = Pattern.Constructor ann typ 0 cargs
pat = Pattern.Constructor ann (ConstructorReference typ 0) cargs
cargs = [ if j == i then Pattern.Unbound ann else Pattern.Var ann
| (_, j) <- fields `zip` [0..]]
rhs = foldr (ABT.abs' ann) (Term.constructor ann typ 0 `Term.apps'` vargs)
rhs = foldr (ABT.abs' ann) (Term.constructor ann (ConstructorReference typ 0) `Term.apps'` vargs)
[ f | ((f, _), j) <- fields `zip` [0..], j /= i ]
vargs = [ if j == i then Term.var ann fname' else Term.var ann v
| ((v, _), j) <- fields `zip` [0..]]
@ -146,9 +147,9 @@ generateRecordAccessors fields typename typ =
fname' = Var.named . Var.name $
Var.freshIn (Set.fromList $ [argname] <> (fst <$> fields))
(Var.named "f")
pat = Pattern.Constructor ann typ 0 cargs
pat = Pattern.Constructor ann (ConstructorReference typ 0) cargs
cargs = replicate (length fields) $ Pattern.Var ann
rhs = foldr (ABT.abs' ann) (Term.constructor ann typ 0 `Term.apps'` vargs)
rhs = foldr (ABT.abs' ann) (Term.constructor ann (ConstructorReference typ 0) `Term.apps'` vargs)
(fst <$> fields)
vargs = [ if j == i
then Term.apps' (Term.var ann fname') [Term.var ann v]
@ -184,7 +185,7 @@ constructorNames dd = Var.name <$> constructorVars dd
-- reliable way of doing that. —AI
declConstructorReferents :: Reference.Id -> Decl v a -> [Referent.Id]
declConstructorReferents rid decl =
[ Referent'.Con' rid i ct | i <- constructorIds (asDataDecl decl) ]
[ Referent'.Con' (ConstructorReference rid i) ct | i <- constructorIds (asDataDecl decl) ]
where ct = constructorType decl
constructorIds :: DataDeclaration v a -> [ConstructorId]

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

@ -16,6 +16,7 @@ import qualified Unison.DataDeclaration as DD
import qualified Unison.Util.Relation as Rel
import Prelude hiding ( cycle )
import Unison.ConstructorReference (GConstructorReference(..))
import qualified Unison.Name as Name
import qualified Unison.Reference as Reference
import qualified Unison.Referent as Referent
@ -34,7 +35,7 @@ toNames ct typeSymbol (Reference.DerivedId -> r) dd =
<> Names mempty (Rel.singleton (Name.unsafeFromVar typeSymbol) r)
where
names (ctor, i) =
Names (Rel.singleton (Name.unsafeFromVar ctor) (Referent.Con r i ct)) mempty
Names (Rel.singleton (Name.unsafeFromVar ctor) (Referent.Con (ConstructorReference r i) ct)) mempty
dataDeclToNames :: Var v => v -> Reference.Id -> DataDeclaration v a -> Names
dataDeclToNames = toNames CT.Data

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

@ -9,11 +9,13 @@ import Unison.Prelude hiding (fromString)
import qualified Data.Text as Text
import Prelude hiding ( take )
import Unison.ConstructorReference (ConstructorReference)
import qualified Unison.ConstructorReference as ConstructorReference
import Unison.Name ( Name, Convert, Parse )
import qualified Unison.Name as Name
import Unison.Reference ( Reference )
import qualified Unison.Reference as Reference
import Unison.Referent ( Referent, ConstructorId )
import Unison.Referent ( Referent )
import qualified Unison.Referent as Referent
import Unison.ShortHash ( ShortHash )
import qualified Unison.ShortHash as SH
@ -127,8 +129,8 @@ fromReferent = HashOnly . Referent.toShortHash
fromReference :: Reference -> HashQualified Name
fromReference = HashOnly . Reference.toShortHash
fromPattern :: Reference -> ConstructorId -> HashQualified Name
fromPattern r cid = HashOnly $ Referent.patternShortHash r cid
fromPattern :: ConstructorReference -> HashQualified Name
fromPattern r = HashOnly $ ConstructorReference.toShortHash r
fromName :: n -> HashQualified n
fromName = NameOnly

15
unison-core/src/Unison/LabeledDependency.hs
View File

@ -17,9 +17,12 @@ module Unison.LabeledDependency
import Unison.Prelude hiding (fold)
import Control.Lens ((^.))
import Unison.ConstructorReference (ConstructorReference)
import qualified Unison.ConstructorReference as ConstructorReference
import Unison.ConstructorType (ConstructorType(Data, Effect))
import Unison.Reference (Reference(DerivedId), Id)
import Unison.Referent (Referent, pattern Ref, pattern Con, ConstructorId)
import Unison.Referent (Referent, pattern Ref, pattern Con)
import qualified Data.Set as Set
-- dumb constructor name is private
@ -28,16 +31,16 @@ newtype LabeledDependency = X (Either Reference Referent) deriving (Eq, Ord, Sho
derivedType, derivedTerm :: Id -> LabeledDependency
typeRef, termRef :: Reference -> LabeledDependency
referent :: Referent -> LabeledDependency
dataConstructor :: Reference -> ConstructorId -> LabeledDependency
effectConstructor :: Reference -> ConstructorId -> LabeledDependency
dataConstructor :: ConstructorReference -> LabeledDependency
effectConstructor :: ConstructorReference -> LabeledDependency
derivedType = X . Left . DerivedId
derivedTerm = X . Right . Ref . DerivedId
typeRef = X . Left
termRef = X . Right . Ref
referent = X . Right
dataConstructor r cid = X . Right $ Con r cid Data
effectConstructor r cid = X . Right $ Con r cid Effect
dataConstructor r = X . Right $ Con r Data
effectConstructor r = X . Right $ Con r Effect
referents :: Foldable f => f Referent -> Set LabeledDependency
referents rs = Set.fromList (map referent $ toList rs)
@ -53,4 +56,4 @@ toReference :: LabeledDependency -> Either Reference Reference
toReference = \case
X (Left r) -> Left r
X (Right (Ref r)) -> Right r
X (Right (Con r _ _)) -> Left r
X (Right (Con r _)) -> Left (r ^. ConstructorReference.reference_)

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

@ -58,6 +58,7 @@ import qualified Data.Set as Set
import qualified Data.Text as Text
import Prelude hiding (filter, map)
import qualified Prelude
import Unison.ConstructorReference (GConstructorReference(..))
import qualified Unison.HashQualified as HQ
import qualified Unison.HashQualified' as HQ'
import Unison.Name (Name)
@ -432,8 +433,8 @@ constructorsForType :: Reference -> Names -> [(Name,Referent)]
constructorsForType r ns = let
-- rather than searching all of names, we use the known possible forms
-- that the constructors can take
possibleDatas = [ Referent.Con r cid CT.Data | cid <- [0..] ]
possibleEffects = [ Referent.Con r cid CT.Effect | cid <- [0..] ]
possibleDatas = [ Referent.Con (ConstructorReference r cid) CT.Data | cid <- [0..] ]
possibleEffects = [ Referent.Con (ConstructorReference r cid) CT.Effect | cid <- [0..] ]
trim [] = []
trim (h:t) = case R.lookupRan h (terms ns) of
s | Set.null s -> []

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

@ -6,6 +6,7 @@ import Unison.Prelude
import Control.Lens (view, _4)
import Data.List.Extra (nubOrd, sort)
import Unison.ConstructorReference (ConstructorReference)
import Unison.HashQualified (HashQualified)
import qualified Unison.HashQualified as HQ
import qualified Unison.HashQualified' as HQ'
@ -263,10 +264,10 @@ lookupHQPattern
:: HQ.HashQualified Name
-> CT.ConstructorType
-> NamesWithHistory
-> Set (Reference, Int)
-> Set ConstructorReference
lookupHQPattern hq ctt names = Set.fromList
[ (r, cid)
| Referent.Con r cid ct <- toList $ lookupHQTerm hq names
[ r
| Referent.Con r ct <- toList $ lookupHQTerm hq names
, ct == ctt
]

49
unison-core/src/Unison/Pattern.hs
View File

@ -8,6 +8,7 @@ import qualified Data.Foldable as Foldable hiding (foldMap')
import Data.List (intercalate)
import qualified Data.Map as Map
import qualified Data.Set as Set
import Unison.ConstructorReference (ConstructorReference, GConstructorReference(..))
import qualified Unison.ConstructorType as CT
import Unison.DataDeclaration.ConstructorId (ConstructorId)
import qualified Unison.Hashable as H
@ -27,10 +28,10 @@ data Pattern loc
| Float loc !Double
| Text loc !Text
| Char loc !Char
| Constructor loc !Reference !ConstructorId [Pattern loc]
| Constructor loc !ConstructorReference [Pattern loc]
| As loc (Pattern loc)
| EffectPure loc (Pattern loc)
| EffectBind loc !Reference !ConstructorId [Pattern loc] (Pattern loc)
| EffectBind loc !ConstructorReference [Pattern loc] (Pattern loc)
| SequenceLiteral loc [Pattern loc]
| SequenceOp loc (Pattern loc) !SeqOp (Pattern loc)
deriving (Ord,Generic,Functor,Foldable,Traversable)
@ -50,16 +51,16 @@ updateDependencies tms p = case p of
Float{} -> p
Text{} -> p
Char{} -> p
Constructor loc r cid ps -> case Map.lookup (Referent.Con r cid CT.Data) tms of
Just (Referent.Con r cid CT.Data) -> Constructor loc r cid (updateDependencies tms <$> ps)
_ -> Constructor loc r cid (updateDependencies tms <$> ps)
Constructor loc r ps -> case Map.lookup (Referent.Con r CT.Data) tms of
Just (Referent.Con r CT.Data) -> Constructor loc r (updateDependencies tms <$> ps)
_ -> Constructor loc r (updateDependencies tms <$> ps)
As loc p -> As loc (updateDependencies tms p)
EffectPure loc p -> EffectPure loc (updateDependencies tms p)
EffectBind loc r cid pats k -> case Map.lookup (Referent.Con r cid CT.Effect) tms of
Just (Referent.Con r cid CT.Effect) ->
EffectBind loc r cid (updateDependencies tms <$> pats) (updateDependencies tms k)
EffectBind loc r pats k -> case Map.lookup (Referent.Con r CT.Effect) tms of
Just (Referent.Con r CT.Effect) ->
EffectBind loc r (updateDependencies tms <$> pats) (updateDependencies tms k)
_ ->
EffectBind loc r cid (updateDependencies tms <$> pats) (updateDependencies tms k)
EffectBind loc r (updateDependencies tms <$> pats) (updateDependencies tms k)
SequenceLiteral loc ps -> SequenceLiteral loc (updateDependencies tms <$> ps)
SequenceOp loc lhs op rhs ->
SequenceOp loc (updateDependencies tms lhs) op (updateDependencies tms rhs)
@ -78,17 +79,17 @@ instance Show (Pattern loc) where
show (Float _ x) = "Float " <> show x
show (Text _ t) = "Text " <> show t
show (Char _ c) = "Char " <> show c
show (Constructor _ r i ps) =
show (Constructor _ (ConstructorReference r i) ps) =
"Constructor " <> unwords [show r, show i, show ps]
show (As _ p) = "As " <> show p
show (EffectPure _ k) = "EffectPure " <> show k
show (EffectBind _ r i ps k) =
show (EffectBind _ (ConstructorReference r i) ps k) =
"EffectBind " <> unwords [show r, show i, show ps, show k]
show (SequenceLiteral _ ps) = "Sequence " <> intercalate ", " (fmap show ps)
show (SequenceOp _ ph op pt) = "Sequence " <> show ph <> " " <> show op <> " " <> show pt
application :: Pattern loc -> Bool
application (Constructor _ _ _ (_ : _)) = True
application (Constructor _ _ (_ : _)) = True
application _ = False
loc :: Pattern loc -> loc
@ -96,10 +97,10 @@ loc p = head $ Foldable.toList p
setLoc :: Pattern loc -> loc -> Pattern loc
setLoc p loc = case p of
EffectBind _ a b c d -> EffectBind loc a b c d
EffectBind _ a b c -> EffectBind loc a b c
EffectPure _ a -> EffectPure loc a
As _ a -> As loc a
Constructor _ a b c -> Constructor loc a b c
Constructor _ a b -> Constructor loc a b
SequenceLiteral _ ps -> SequenceLiteral loc ps
SequenceOp _ ph op pt -> SequenceOp loc ph op pt
x -> fmap (const loc) x
@ -111,10 +112,10 @@ instance H.Hashable (Pattern p) where
tokens (Int _ n) = H.Tag 3 : [H.Int n]
tokens (Nat _ n) = H.Tag 4 : [H.Nat n]
tokens (Float _ f) = H.Tag 5 : H.tokens f
tokens (Constructor _ r n args) =
tokens (Constructor _ (ConstructorReference r n) args) =
[H.Tag 6, H.accumulateToken r, H.Nat $ fromIntegral n, H.accumulateToken args]
tokens (EffectPure _ p) = H.Tag 7 : H.tokens p
tokens (EffectBind _ r n args k) =
tokens (EffectBind _ (ConstructorReference r n) args k) =
[H.Tag 8, H.accumulateToken r, H.Nat $ fromIntegral n, H.accumulateToken args, H.accumulateToken k]
tokens (As _ p) = H.Tag 9 : H.tokens p
tokens (Text _ t) = H.Tag 10 : H.tokens t
@ -130,9 +131,9 @@ instance Eq (Pattern loc) where
Int _ n == Int _ m = n == m
Nat _ n == Nat _ m = n == m
Float _ f == Float _ g = f == g
Constructor _ r n args == Constructor _ s m brgs = r == s && n == m && args == brgs
Constructor _ r args == Constructor _ s brgs = r == s && args == brgs
EffectPure _ p == EffectPure _ q = p == q
EffectBind _ r ctor ps k == EffectBind _ r2 ctor2 ps2 k2 = r == r2 && ctor == ctor2 && ps == ps2 && k == k2
EffectBind _ r ps k == EffectBind _ r2 ps2 k2 = r == r2 && ps == ps2 && k == k2
As _ p == As _ q = p == q
Text _ t == Text _ t2 = t == t2
SequenceLiteral _ ps == SequenceLiteral _ ps2 = ps == ps2
@ -149,10 +150,10 @@ foldMap' f p = case p of
Float _ _ -> f p
Text _ _ -> f p
Char _ _ -> f p
Constructor _ _ _ ps -> f p <> foldMap (foldMap' f) ps
Constructor _ _ ps -> f p <> foldMap (foldMap' f) ps
As _ p' -> f p <> foldMap' f p'
EffectPure _ p' -> f p <> foldMap' f p'
EffectBind _ _ _ ps p' -> f p <> foldMap (foldMap' f) ps <> foldMap' f p'
EffectBind _ _ ps p' -> f p <> foldMap (foldMap' f) ps <> foldMap' f p'
SequenceLiteral _ ps -> f p <> foldMap (foldMap' f) ps
SequenceOp _ p1 _ p2 -> f p <> foldMap' f p1 <> foldMap' f p2
@ -171,9 +172,9 @@ generalizedDependencies literalType dataConstructor dataType effectConstructor e
Unbound _ -> mempty
Var _ -> mempty
As _ _ -> mempty
Constructor _ r cid _ -> [dataType r, dataConstructor r cid]
Constructor _ (ConstructorReference r cid) _ -> [dataType r, dataConstructor r cid]
EffectPure _ _ -> [effectType Type.effectRef]
EffectBind _ r cid _ _ ->
EffectBind _ (ConstructorReference r cid) _ _ ->
[effectType Type.effectRef, effectType r, effectConstructor r cid]
SequenceLiteral _ _ -> [literalType Type.listRef]
SequenceOp {} -> [literalType Type.listRef]
@ -187,7 +188,7 @@ generalizedDependencies literalType dataConstructor dataType effectConstructor e
labeledDependencies :: Pattern loc -> Set LabeledDependency
labeledDependencies = generalizedDependencies LD.typeRef
LD.dataConstructor
(\r i -> LD.dataConstructor (ConstructorReference r i))
LD.typeRef
LD.effectConstructor
(\r i -> LD.effectConstructor (ConstructorReference r i))
LD.typeRef

14
unison-core/src/Unison/Reference.hs
View File

@ -11,6 +11,10 @@ module Unison.Reference
Id(..),
Pos,
Size,
TermReference,
TermReferenceId,
TypeReference,
TypeReferenceId,
derivedBase32Hex,
Component, members,
component,
@ -64,6 +68,16 @@ pattern Derived h i n = DerivedId (Id h i n)
-- | @Pos@ is a position into a cycle of size @Size@, as cycles are hashed together.
data Id = Id H.Hash Pos Size deriving (Generic)
-- | A term reference.
type TermReference = Reference
type TermReferenceId = Id
-- | A type declaration reference.
type TypeReference = Reference
type TypeReferenceId = Id
unsafeId :: Reference -> Id
unsafeId (Builtin b) =
error $ "Tried to get the hash of builtin " <> Text.unpack b <> "."

13
unison-core/src/Unison/Referent'.hs
View File

@ -19,6 +19,7 @@ module Unison.Referent'
where
import Control.Lens (Lens, lens)
import Unison.ConstructorReference (GConstructorReference (..))
import Unison.ConstructorType (ConstructorType)
import Unison.DataDeclaration.ConstructorId (ConstructorId)
import Unison.Hashable (Hashable (tokens))
@ -35,7 +36,7 @@ import Unison.Prelude (Word64)
-- | When @Ref'@ then @r@ represents a term.
--
-- When @Con'@ then @r@ is a type declaration.
data Referent' r = Ref' r | Con' r ConstructorId ConstructorType
data Referent' r = Ref' r | Con' (GConstructorReference r) ConstructorType
deriving (Show, Ord, Eq, Functor)
-- | A lens onto the reference in a referent.
@ -44,7 +45,7 @@ reference_ =
lens toReference' \rt rc ->
case rt of
Ref' _ -> Ref' rc
Con' _ cid ct -> Con' rc cid ct
Con' (ConstructorReference _ cid) ct -> Con' (ConstructorReference rc cid) ct
isConstructor :: Referent' r -> Bool
isConstructor Con' {} = True
@ -58,18 +59,18 @@ toTermReference = \case
toReference' :: Referent' r -> r
toReference' = \case
Ref' r -> r
Con' r _i _t -> r
Con' (ConstructorReference r _i) _t -> r
toTypeReference :: Referent' r -> Maybe r
toTypeReference = \case
Con' r _i _t -> Just r
Con' (ConstructorReference r _i) _t -> Just r
_ -> Nothing
fold :: (r -> a) -> (r -> ConstructorId -> ConstructorType -> a) -> Referent' r -> a
fold fr fc = \case
Ref' r -> fr r
Con' r i ct -> fc r i ct
Con' (ConstructorReference r i) ct -> fc r i ct
instance Hashable r => Hashable (Referent' r) where
tokens (Ref' r) = [H.Tag 0] ++ H.tokens r
tokens (Con' r i dt) = [H.Tag 2] ++ H.tokens r ++ H.tokens (fromIntegral i :: Word64) ++ H.tokens dt
tokens (Con' (ConstructorReference r i) dt) = [H.Tag 2] ++ H.tokens r ++ H.tokens (fromIntegral i :: Word64) ++ H.tokens dt

27
unison-core/src/Unison/Referent.hs
View File

@ -24,17 +24,18 @@ module Unison.Referent
toShortHash,
toText,
toString,
patternShortHash,
)
where
import qualified Data.Char as Char
import qualified Data.Text as Text
import Unison.ConstructorReference (ConstructorReference, ConstructorReferenceId, GConstructorReference(..))
import qualified Unison.ConstructorReference as ConstructorReference
import Unison.ConstructorType (ConstructorType)
import qualified Unison.ConstructorType as CT
import Unison.DataDeclaration.ConstructorId (ConstructorId)
import Unison.Prelude hiding (fold)
import Unison.Reference (Reference)
import Unison.Reference (Reference, TermReference)
import qualified Unison.Reference as R
import Unison.Referent' (Referent' (..), toReference', reference_)
import Unison.ShortHash (ShortHash)
@ -49,11 +50,11 @@ import qualified Unison.Reference as Reference
-- rather than the target of a Reference.
type Referent = Referent' Reference
pattern Ref :: Reference -> Referent
pattern Ref :: TermReference -> Referent
pattern Ref r = Ref' r
pattern Con :: Reference -> ConstructorId -> ConstructorType -> Referent
pattern Con r i t = Con' r i t
pattern Con :: ConstructorReference -> ConstructorType -> Referent
pattern Con r t = Con' r t
{-# COMPLETE Ref, Con #-}
@ -63,8 +64,8 @@ type Id = Referent' R.Id
pattern RefId :: R.Id -> Unison.Referent.Id
pattern RefId r = Ref' r
pattern ConId :: R.Id -> ConstructorId -> ConstructorType -> Unison.Referent.Id
pattern ConId r i t = Con' r i t
pattern ConId :: ConstructorReferenceId -> ConstructorType -> Unison.Referent.Id
pattern ConId r t = Con' r t
{-# COMPLETE RefId, ConId #-}
@ -75,16 +76,12 @@ pattern ConId r i t = Con' r i t
toShortHash :: Referent -> ShortHash
toShortHash = \case
Ref r -> R.toShortHash r
Con r i _ -> patternShortHash r i
-- also used by HashQualified.fromPattern
patternShortHash :: Reference -> Int -> ShortHash
patternShortHash r i = (R.toShortHash r) { SH.cid = Just . Text.pack $ show i }
Con r _ -> ConstructorReference.toShortHash r
toText :: Referent -> Text
toText = \case
Ref r -> R.toText r
Con r cid ct -> R.toText r <> "#" <> ctorTypeText ct <> Text.pack (show cid)
Con (ConstructorReference r cid) ct -> R.toText r <> "#" <> ctorTypeText ct <> Text.pack (show cid)
ctorTypeText :: CT.ConstructorType -> Text
ctorTypeText CT.Effect = EffectCtor
@ -122,7 +119,7 @@ fromText t = either (const Nothing) Just $
r <- R.fromText (Text.dropEnd 1 refPart)
ctorType <- ctorType
let cid = read (Text.unpack cidPart)
pure $ Con r cid ctorType
pure $ Con (ConstructorReference r cid) ctorType
else
Left ("invalid constructor id: " <> Text.unpack cidPart)
where
@ -139,4 +136,4 @@ fromText t = either (const Nothing) Just $
fold :: (r -> a) -> (r -> Int -> ConstructorType -> a) -> Referent' r -> a
fold fr fc = \case
Ref' r -> fr r
Con' r i ct -> fc r i ct
Con' (ConstructorReference r i) ct -> fc r i ct

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

@ -24,6 +24,7 @@ import Prelude.Extras (Eq1(..), Show1(..))
import Text.Show
import qualified Unison.ABT as ABT
import qualified Unison.Blank as B
import Unison.ConstructorReference (ConstructorReference, GConstructorReference(..))
import Unison.Names ( Names )
import qualified Unison.Names as Names
import qualified Unison.NamesWithHistory as Names
@ -61,10 +62,8 @@ data F typeVar typeAnn patternAnn a
| Char Char
| Blank (B.Blank typeAnn)
| Ref Reference
-- First argument identifies the data type,
-- second argument identifies the constructor
| Constructor Reference ConstructorId
| Request Reference ConstructorId
| Constructor ConstructorReference
| Request ConstructorReference
| Handle a a
| App a a
| Ann a (Type typeVar typeAnn)
@ -241,8 +240,8 @@ extraMap vtf atf apf = \case
Char x -> Char x
Blank x -> Blank (fmap atf x)
Ref x -> Ref x
Constructor x y -> Constructor x y
Request x y -> Request x y
Constructor x -> Constructor x
Request x -> Request x
Handle x y -> Handle x y
App x y -> App x y
Ann tm x -> Ann tm (ABT.amap atf (ABT.vmap vtf x))
@ -419,9 +418,9 @@ pattern TypeLink' r <- (ABT.out -> ABT.Tm (TypeLink r))
pattern Builtin' r <- (ABT.out -> ABT.Tm (Ref (Builtin r)))
pattern App' f x <- (ABT.out -> ABT.Tm (App f x))
pattern Match' scrutinee branches <- (ABT.out -> ABT.Tm (Match scrutinee branches))
pattern Constructor' ref n <- (ABT.out -> ABT.Tm (Constructor ref n))
pattern Request' ref n <- (ABT.out -> ABT.Tm (Request ref n))
pattern RequestOrCtor' ref n <- (unReqOrCtor -> Just (ref, n))
pattern Constructor' ref <- (ABT.out -> ABT.Tm (Constructor ref))
pattern Request' ref <- (ABT.out -> ABT.Tm (Request ref))
pattern RequestOrCtor' ref <- (unReqOrCtor -> Just ref)
pattern If' cond t f <- (ABT.out -> ABT.Tm (If cond t f))
pattern And' x y <- (ABT.out -> ABT.Tm (And x y))
pattern Or' x y <- (ABT.out -> ABT.Tm (Or x y))
@ -480,8 +479,8 @@ pattern Referent' r <- (unReferent -> Just r)
unReferent :: Term2 vt at ap v a -> Maybe Referent
unReferent (Ref' r) = Just $ Referent.Ref r
unReferent (Constructor' r cid) = Just $ Referent.Con r cid CT.Data
unReferent (Request' r cid) = Just $ Referent.Con r cid CT.Effect
unReferent (Constructor' r) = Just $ Referent.Con r CT.Data
unReferent (Request' r) = Just $ Referent.Con r CT.Effect
unReferent _ = Nothing
refId :: Ord v => a -> Reference.Id -> Term2 vt at ap v a
@ -531,11 +530,11 @@ placeholder a s = ABT.tm' a . Blank $ B.Recorded (B.Placeholder a s)
resolve :: Ord v => at -> ab -> String -> Term2 vt ab ap v at
resolve at ab s = ABT.tm' at . Blank $ B.Recorded (B.Resolve ab s)
constructor :: Ord v => a -> Reference -> ConstructorId -> Term2 vt at ap v a
constructor a ref n = ABT.tm' a (Constructor ref n)
constructor :: Ord v => a -> ConstructorReference -> Term2 vt at ap v a
constructor a ref = ABT.tm' a (Constructor ref)
request :: Ord v => a -> Reference -> ConstructorId -> Term2 vt at ap v a
request a ref n = ABT.tm' a (Request ref n)
request :: Ord v => a -> ConstructorReference -> Term2 vt at ap v a
request a ref = ABT.tm' a (Request ref)
-- todo: delete and rename app' to app
app_ :: Ord v => Term0' vt v -> Term0' vt v -> Term0' vt v
@ -833,10 +832,10 @@ unLamsPred' (LamNamed' v body, pred) | pred v = case unLamsPred' (body, pred) of
Just (vs, body) -> Just (v:vs, body)
unLamsPred' _ = Nothing
unReqOrCtor :: Term2 vt at ap v a -> Maybe (Reference, ConstructorId)
unReqOrCtor (Constructor' r cid) = Just (r, cid)
unReqOrCtor (Request' r cid) = Just (r, cid)
unReqOrCtor _ = Nothing
unReqOrCtor :: Term2 vt at ap v a -> Maybe ConstructorReference
unReqOrCtor (Constructor' r) = Just r
unReqOrCtor (Request' r) = Just r
unReqOrCtor _ = Nothing
-- Dependencies including referenced data and effect decls
dependencies :: (Ord v, Ord vt) => Term2 vt at ap v a -> Set Reference
@ -891,8 +890,8 @@ generalizedDependencies termRef typeRef literalType dataConstructor dataType eff
f t@(Ref r) = Writer.tell [termRef r] $> t
f t@(TermLink r) = case r of
Referent.Ref r -> Writer.tell [termRef r] $> t
Referent.Con r id CT.Data -> Writer.tell [dataConstructor r id] $> t
Referent.Con r id CT.Effect -> Writer.tell [effectConstructor r id] $> t
Referent.Con (ConstructorReference r id) CT.Data -> Writer.tell [dataConstructor r id] $> t
Referent.Con (ConstructorReference r id) CT.Effect -> Writer.tell [effectConstructor r id] $> t
f t@(TypeLink r) = Writer.tell [typeRef r] $> t
f t@(Ann _ typ) =
Writer.tell (map typeRef . toList $ Type.dependencies typ) $> t
@ -902,9 +901,9 @@ generalizedDependencies termRef typeRef literalType dataConstructor dataType eff
f t@(Boolean _) = Writer.tell [literalType Type.booleanRef] $> t
f t@(Text _) = Writer.tell [literalType Type.textRef] $> t
f t@(List _) = Writer.tell [literalType Type.listRef] $> t
f t@(Constructor r cid) =
f t@(Constructor (ConstructorReference r cid)) =
Writer.tell [dataType r, dataConstructor r cid] $> t
f t@(Request r cid) =
f t@(Request (ConstructorReference r cid)) =
Writer.tell [effectType r, effectConstructor r cid] $> t
f t@(Match _ cases) = traverse_ goPat cases $> t
f t = pure t
@ -921,9 +920,9 @@ labeledDependencies
labeledDependencies = generalizedDependencies LD.termRef
LD.typeRef
LD.typeRef
LD.dataConstructor
(\r i -> LD.dataConstructor (ConstructorReference r i))
LD.typeRef
LD.effectConstructor
(\r i -> LD.effectConstructor (ConstructorReference r i))
LD.typeRef
updateDependencies
@ -935,15 +934,15 @@ updateDependencies
updateDependencies termUpdates typeUpdates = ABT.rebuildUp go
where
referent (Referent.Ref r) = Ref r
referent (Referent.Con r cid CT.Data) = Constructor r cid
referent (Referent.Con r cid CT.Effect) = Request r cid
referent (Referent.Con r CT.Data) = Constructor r
referent (Referent.Con r CT.Effect) = Request r
go (Ref r ) = case Map.lookup (Referent.Ref r) termUpdates of
Nothing -> Ref r
Just r -> referent r
go ct@(Constructor r cid) = case Map.lookup (Referent.Con r cid CT.Data) termUpdates of
go ct@(Constructor r) = case Map.lookup (Referent.Con r CT.Data) termUpdates of
Nothing -> ct
Just r -> referent r
go req@(Request r cid) = case Map.lookup (Referent.Con r cid CT.Effect) termUpdates of
go req@(Request r) = case Map.lookup (Referent.Con r CT.Effect) termUpdates of
Nothing -> req
Just r -> referent r
go (TermLink r) = TermLink (Map.findWithDefault r r termUpdates)
@ -1007,9 +1006,9 @@ fromReferent :: Ord v
-> Term2 vt at ap v a
fromReferent a = \case
Referent.Ref r -> ref a r
Referent.Con r i ct -> case ct of
CT.Data -> constructor a r i
CT.Effect -> request a r i
Referent.Con r ct -> case ct of
CT.Data -> constructor a r
CT.Effect -> request a r
-- mostly boring serialization code below ...
@ -1027,8 +1026,8 @@ instance (ABT.Var vt, Eq at, Eq a) => Eq (F vt at p a) where
Ref x == Ref y = x == y
TermLink x == TermLink y = x == y
TypeLink x == TypeLink y = x == y
Constructor r cid == Constructor r2 cid2 = r == r2 && cid == cid2
Request r cid == Request r2 cid2 = r == r2 && cid == cid2
Constructor r == Constructor r2 = r == r2
Request r == Request r2 = r == r2
Handle h b == Handle h2 b2 = h == h2 && b == b2
App f a == App f2 a2 = f == f2 && a == a2
Ann e t == Ann e2 t2 = e == e2 && t == t2
@ -1071,13 +1070,13 @@ instance (Show v, Show a) => Show (F v a0 p a) where
go _ (Handle b body) = showParen
True
(s "handle " <> shows b <> s " in " <> shows body)
go _ (Constructor r n ) = s "Con" <> shows r <> s "#" <> shows n
go _ (Constructor (ConstructorReference r n)) = s "Con" <> shows r <> s "#" <> shows n
go _ (Match scrutinee cases) = showParen
True
(s "case " <> shows scrutinee <> s " of " <> shows cases)
go _ (Text s ) = shows s
go _ (Char c ) = shows c
go _ (Request r n) = s "Req" <> shows r <> s "#" <> shows n
go _ (Request (ConstructorReference r n)) = s "Req" <> shows r <> s "#" <> shows n
go p (If c t f) =
showParen (p > 0)
$ s "if "

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

@ -26,6 +26,7 @@ library
Unison.ABT
Unison.ABT.Normalized
Unison.Blank
Unison.ConstructorReference
Unison.ConstructorType
Unison.DataDeclaration
Unison.DataDeclaration.ConstructorId