module Unison.DataDeclaration.Records
( generateRecordAccessors,
)
where
import Data.List.NonEmpty (pattern (:|))
import Data.List.NonEmpty qualified as List (NonEmpty)
import Data.Map qualified as Map
import Data.Set qualified as Set
import Unison.ABT qualified as ABT
import Unison.ConstructorReference (GConstructorReference (..))
import Unison.Pattern qualified as Pattern
import Unison.Prelude
import Unison.Reference (TypeReference)
import Unison.Term (Term)
import Unison.Term qualified as Term
import Unison.Type (Type)
import Unison.Type qualified as Type
import Unison.Var (Var)
import Unison.Var qualified as Var
generateRecordAccessors ::
(Semigroup a, Var v) =>
(List.NonEmpty v -> v) ->
(a -> a) ->
[(v, a, Type v a)] ->
[v] ->
v ->
TypeReference ->
[(v, a, Term v a)]
generateRecordAccessors :: forall a v.
(Semigroup a, Var v) =>
(NonEmpty v -> v)
-> (a -> a)
-> [(v, a, Type v a)]
-> [v]
-> v
-> TypeReference
-> [(v, a, Term v a)]
generateRecordAccessors NonEmpty v -> v
namespaced a -> a
generatedAnn [(v, a, Type v a)]
fields [v]
tyvars v
typename TypeReference
typ =
[[(v, a, Term v a)]] -> [(v, a, Term v a)]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join [(v, a, Type v a) -> Int -> [(v, a, Term v a)]
tm (v, a, Type v a)
t Int
i | ((v, a, Type v a)
t, Int
i) <- [(v, a, Type v a)]
fields [(v, a, Type v a)] -> [Int] -> [((v, a, Type v a), Int)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [(Int
0 :: Int) ..]]
where
argname :: v
argname = v -> v
forall v. Var v => v -> v
Var.uncapitalize v
typename
tyvarSet :: Set v
tyvarSet = [v] -> Set v
forall a. Ord a => [a] -> Set a
Set.fromList [v]
tyvars
selfTypeWith :: a -> Map v v -> Type v a
selfTypeWith a
ann Map v v
renaming =
(Type v a -> v -> Type v a) -> Type v a -> [v] -> Type v a
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
(\Type v a
acc v
tyv -> a -> Type v a -> Type v a -> Type v a
forall v a. Ord v => a -> Type v a -> Type v a -> Type v a
Type.app a
ann Type v a
acc (a -> v -> Type v a
forall v a. Ord v => a -> v -> Type v a
Type.var a
ann (v -> v -> Map v v -> v
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault v
tyv v
tyv Map v v
renaming)))
(a -> TypeReference -> Type v a
forall v a. Ord v => a -> TypeReference -> Type v a
Type.ref a
ann TypeReference
typ)
[v]
tyvars
avoidVars :: Set v
avoidVars =
[Set v] -> Set v
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions (Set v
tyvarSet Set v -> [Set v] -> [Set v]
forall a. a -> [a] -> [a]
: v -> Set v
forall a. a -> Set a
Set.singleton v
argname Set v -> [Set v] -> [Set v]
forall a. a -> [a] -> [a]
: [Type v a -> Set v
forall v a. Type v a -> Set v
Type.freeVars Type v a
ty | (v
_, a
_, Type v a
ty) <- [(v, a, Type v a)]
fields])
arrow :: a -> Type v a -> Type v a -> Type v a
arrow a
ann Type v a
i Type v a
o = a -> Type v a -> Type v a -> Type v a
forall v a. Ord v => a -> Type v a -> Type v a -> Type v a
Type.arrow a
ann Type v a
i Type v a
o
tm :: (v, a, Type v a) -> Int -> [(v, a, Term v a)]
tm (v
fname, a
fieldAnn, Type v a
fieldTy) Int
i =
[ (NonEmpty v -> v
namespaced (v
typename v -> [v] -> NonEmpty v
forall a. a -> [a] -> NonEmpty a
:| [v
fname]), a
ann, a -> Term v a -> Type v a -> Term v a
forall v a vt at ap.
Ord v =>
a -> Term2 vt at ap v a -> Type vt at -> Term2 vt at ap v a
Term.ann a
ann Term v a
get Type v a
getTy),
(NonEmpty v -> v
namespaced (v
typename v -> [v] -> NonEmpty v
forall a. a -> [a] -> NonEmpty a
:| [v
fname, Text -> v
forall v. Var v => Text -> v
Var.named Text
"set"]), a
ann, a -> Term v a -> Type v a -> Term v a
forall v a vt at ap.
Ord v =>
a -> Term2 vt at ap v a -> Type vt at -> Term2 vt at ap v a
Term.ann a
ann Term v a
set Type v a
setTy),
(NonEmpty v -> v
namespaced (v
typename v -> [v] -> NonEmpty v
forall a. a -> [a] -> NonEmpty a
:| [v
fname, Text -> v
forall v. Var v => Text -> v
Var.named Text
"modify"]), a
ann, a -> Term v a -> Type v a -> Term v a
forall v a vt at ap.
Ord v =>
a -> Term2 vt at ap v a -> Type vt at -> Term2 vt at ap v a
Term.ann a
ann Term v a
modify Type v a
modifyTy)
]
where
ann :: a
ann = a -> a
generatedAnn a
fieldAnn
conref :: GConstructorReference TypeReference
conref = TypeReference
-> ConstructorId -> GConstructorReference TypeReference
forall r. r -> ConstructorId -> GConstructorReference r
ConstructorReference TypeReference
typ ConstructorId
0
pat :: [Pattern a] -> Pattern a
pat = a
-> GConstructorReference TypeReference -> [Pattern a] -> Pattern a
forall loc.
loc
-> GConstructorReference TypeReference
-> [Pattern loc]
-> Pattern loc
Pattern.Constructor a
ann GConstructorReference TypeReference
conref
soleTyvars :: [v]
soleTyvars =
[ v
v
| v
v <- [v]
tyvars,
v -> Set v -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member v
v Set v
thisFieldVars,
Bool -> Bool
not (v -> Set v -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member v
v Set v
otherFieldVars)
]
where
thisFieldVars :: Set v
thisFieldVars = Set v -> Set v -> Set v
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection Set v
tyvarSet (Type v a -> Set v
forall v a. Type v a -> Set v
Type.freeVars Type v a
fieldTy)
otherFieldVars :: Set v
otherFieldVars =
[Set v] -> Set v
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions
[ Set v -> Set v -> Set v
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection Set v
tyvarSet (Type v a -> Set v
forall v a. Type v a -> Set v
Type.freeVars Type v a
ty)
| ((v
_, a
_, Type v a
ty), Int
j) <- [(v, a, Type v a)]
fields [(v, a, Type v a)] -> [Int] -> [((v, a, Type v a), Int)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [(Int
0 :: Int) ..],
Int
j Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
i
]
renaming :: Map v v
renaming = (Set v, Map v v) -> Map v v
forall a b. (a, b) -> b
snd (((Set v, Map v v) -> v -> (Set v, Map v v))
-> (Set v, Map v v) -> [v] -> (Set v, Map v v)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Set v, Map v v) -> v -> (Set v, Map v v)
forall {a}. Var a => (Set a, Map a a) -> a -> (Set a, Map a a)
freshen (Set v
avoidVars, Map v v
forall k a. Map k a
Map.empty) [v]
soleTyvars)
where
freshen :: (Set a, Map a a) -> a -> (Set a, Map a a)
freshen (Set a
used, Map a a
m) a
v =
let v' :: a
v' = Set a -> a -> a
forall v. Var v => Set v -> v -> v
Var.freshIn Set a
used a
v
in (a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
Set.insert a
v' Set a
used, a -> a -> Map a a -> Map a a
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert a
v a
v' Map a a
m)
freshTyvars :: [v]
freshTyvars = Map v v -> [v]
forall k a. Map k a -> [a]
Map.elems Map v v
renaming
fieldTy' :: Type v a
fieldTy' = Map v v -> Type v a -> Type v a
forall (f :: * -> *) v a.
(Foldable f, Functor f, Var v) =>
Map v v -> Term f v a -> Term f v a
ABT.renames Map v v
renaming Type v a
fieldTy
getTy :: Type v a
getTy = a -> [v] -> Type v a -> Type v a
forall v a. Ord v => a -> [v] -> Type v a -> Type v a
Type.foralls a
ann [v]
tyvars (a -> Type v a -> Type v a -> Type v a
forall v a. Ord v => a -> Type v a -> Type v a -> Type v a
arrow a
ann (a -> Map v v -> Type v a
selfTypeWith a
ann Map v v
forall a. Monoid a => a
mempty) Type v a
fieldTy)
setTy :: Type v a
setTy =
a -> [v] -> Type v a -> Type v a
forall v a. Ord v => a -> [v] -> Type v a -> Type v a
Type.foralls
a
ann
([v]
tyvars [v] -> [v] -> [v]
forall a. Semigroup a => a -> a -> a
<> [v]
freshTyvars)
(a -> Type v a -> Type v a -> Type v a
forall v a. Ord v => a -> Type v a -> Type v a -> Type v a
arrow a
ann Type v a
fieldTy' (a -> Type v a -> Type v a -> Type v a
forall v a. Ord v => a -> Type v a -> Type v a -> Type v a
arrow a
ann (a -> Map v v -> Type v a
selfTypeWith a
ann Map v v
forall a. Monoid a => a
mempty) (a -> Map v v -> Type v a
selfTypeWith a
ann Map v v
renaming)))
modifyTy :: Type v a
modifyTy =
a -> [v] -> Type v a -> Type v a
forall v a. Ord v => a -> [v] -> Type v a -> Type v a
Type.foralls
a
ann
([v]
tyvars [v] -> [v] -> [v]
forall a. Semigroup a => a -> a -> a
<> [v]
freshTyvars)
(a -> Type v a -> Type v a -> Type v a
forall v a. Ord v => a -> Type v a -> Type v a -> Type v a
arrow a
ann (a -> Type v a -> Type v a -> Type v a
forall v a. Ord v => a -> Type v a -> Type v a -> Type v a
arrow a
ann Type v a
fieldTy Type v a
fieldTy') (a -> Type v a -> Type v a -> Type v a
forall v a. Ord v => a -> Type v a -> Type v a -> Type v a
arrow a
ann (a -> Map v v -> Type v a
selfTypeWith a
ann Map v v
forall a. Monoid a => a
mempty) (a -> Map v v -> Type v a
selfTypeWith a
ann Map v v
renaming)))
get :: Term v a
get =
a -> (a, v) -> Term v a -> Term v a
forall v a vt at ap.
Ord v =>
a -> (a, v) -> Term2 vt at ap v a -> Term2 vt at ap v a
Term.lam a
ann (a
ann, v
argname) (Term v a -> Term v a) -> Term v a -> Term v a
forall a b. (a -> b) -> a -> b
$
a -> Term v a -> [MatchCase a (Term v a)] -> Term v a
forall v a vt at.
Ord v =>
a
-> Term2 vt at a v a
-> [MatchCase a (Term2 vt at a v a)]
-> Term2 vt at a v a
Term.match
a
ann
(a -> v -> Term v a
forall a v vt at ap. a -> v -> Term2 vt at ap v a
Term.var a
ann v
argname)
[Pattern a -> Maybe (Term v a) -> Term v a -> MatchCase a (Term v a)
forall loc a. Pattern loc -> Maybe a -> a -> MatchCase loc a
Term.MatchCase ([Pattern a] -> Pattern a
pat [Pattern a]
cargs) Maybe (Term v a)
forall a. Maybe a
Nothing Term v a
rhs]
where
cargs :: [Pattern a]
cargs =
[ if Int
j Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
i then a -> Pattern a
forall loc. loc -> Pattern loc
Pattern.Var a
ann else a -> Pattern a
forall loc. loc -> Pattern loc
Pattern.Unbound a
ann
| ((v, a, Type v a)
_, Int
j) <- [(v, a, Type v a)]
fields [(v, a, Type v a)] -> [Int] -> [((v, a, Type v a), Int)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Int
0 ..]
]
rhs :: Term v a
rhs = a -> v -> Term v a -> Term v a
forall v a (f :: * -> *).
Ord v =>
a -> v -> Term f v a -> Term f v a
ABT.abs' a
ann v
fname (a -> v -> Term v a
forall a v vt at ap. a -> v -> Term2 vt at ap v a
Term.var a
ann v
fname)
set :: Term v a
set =
a -> [(a, v)] -> Term v a -> Term v a
forall v a vt at ap.
Ord v =>
a -> [(a, v)] -> Term2 vt at ap v a -> Term2 vt at ap v a
Term.lam' a
ann [(a
ann, v
fname'), (a
ann, v
argname)] (Term v a -> Term v a) -> Term v a -> Term v a
forall a b. (a -> b) -> a -> b
$
a -> Term v a -> [MatchCase a (Term v a)] -> Term v a
forall v a vt at.
Ord v =>
a
-> Term2 vt at a v a
-> [MatchCase a (Term2 vt at a v a)]
-> Term2 vt at a v a
Term.match
a
ann
(a -> v -> Term v a
forall a v vt at ap. a -> v -> Term2 vt at ap v a
Term.var a
ann v
argname)
[Pattern a -> Maybe (Term v a) -> Term v a -> MatchCase a (Term v a)
forall loc a. Pattern loc -> Maybe a -> a -> MatchCase loc a
Term.MatchCase ([Pattern a] -> Pattern a
pat [Pattern a]
cargs) Maybe (Term v a)
forall a. Maybe a
Nothing Term v a
rhs]
where
fname' :: v
fname' =
Text -> v
forall v. Var v => Text -> v
Var.named (Text -> v) -> (v -> Text) -> v -> v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> Text
forall v. Var v => v -> Text
Var.name (v -> v) -> v -> v
forall a b. (a -> b) -> a -> b
$
Set v -> v -> v
forall v. Var v => Set v -> v -> v
Var.freshIn ([v] -> Set v
forall a. Ord a => [a] -> Set a
Set.fromList ([v] -> Set v) -> [v] -> Set v
forall a b. (a -> b) -> a -> b
$ [v
argname] [v] -> [v] -> [v]
forall a. Semigroup a => a -> a -> a
<> ((v, a, Type v a) -> v
forall {a} {b} {c}. (a, b, c) -> a
fst3 ((v, a, Type v a) -> v) -> [(v, a, Type v a)] -> [v]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(v, a, Type v a)]
fields)) v
fname
cargs :: [Pattern a]
cargs =
[ if Int
j Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
i then a -> Pattern a
forall loc. loc -> Pattern loc
Pattern.Unbound a
ann else a -> Pattern a
forall loc. loc -> Pattern loc
Pattern.Var a
ann
| ((v, a, Type v a)
_, Int
j) <- [(v, a, Type v a)]
fields [(v, a, Type v a)] -> [Int] -> [((v, a, Type v a), Int)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Int
0 ..]
]
rhs :: Term v a
rhs =
(v -> Term v a -> Term v a) -> Term v a -> [v] -> Term v a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
(a -> v -> Term v a -> Term v a
forall v a (f :: * -> *).
Ord v =>
a -> v -> Term f v a -> Term f v a
ABT.abs' a
ann)
(a -> GConstructorReference TypeReference -> Term v a
forall v a vt at ap.
Ord v =>
a -> GConstructorReference TypeReference -> Term2 vt at ap v a
Term.constructor a
ann GConstructorReference TypeReference
conref Term v a -> [Term v a] -> Term v a
forall v a vt at ap.
(Ord v, Semigroup a) =>
Term2 vt at ap v a -> [Term2 vt at ap v a] -> Term2 vt at ap v a
`Term.apps'` [Term v a]
vargs)
[v
v | ((v
v, a
_, Type v a
_), Int
j) <- [(v, a, Type v a)]
fields [(v, a, Type v a)] -> [Int] -> [((v, a, Type v a), Int)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Int
0 ..], Int
j Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
i]
vargs :: [Term v a]
vargs =
[ if Int
j Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
i then a -> v -> Term v a
forall a v vt at ap. a -> v -> Term2 vt at ap v a
Term.var a
ann v
fname' else a -> v -> Term v a
forall a v vt at ap. a -> v -> Term2 vt at ap v a
Term.var a
ann v
v
| ((v
v, a
_, Type v a
_), Int
j) <- [(v, a, Type v a)]
fields [(v, a, Type v a)] -> [Int] -> [((v, a, Type v a), Int)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Int
0 ..]
]
modify :: Term v a
modify =
a -> [(a, v)] -> Term v a -> Term v a
forall v a vt at ap.
Ord v =>
a -> [(a, v)] -> Term2 vt at ap v a -> Term2 vt at ap v a
Term.lam' a
ann [(a
ann, v
fname'), (a
ann, v
argname)] (Term v a -> Term v a) -> Term v a -> Term v a
forall a b. (a -> b) -> a -> b
$
a -> Term v a -> [MatchCase a (Term v a)] -> Term v a
forall v a vt at.
Ord v =>
a
-> Term2 vt at a v a
-> [MatchCase a (Term2 vt at a v a)]
-> Term2 vt at a v a
Term.match
a
ann
(a -> v -> Term v a
forall a v vt at ap. a -> v -> Term2 vt at ap v a
Term.var a
ann v
argname)
[Pattern a -> Maybe (Term v a) -> Term v a -> MatchCase a (Term v a)
forall loc a. Pattern loc -> Maybe a -> a -> MatchCase loc a
Term.MatchCase ([Pattern a] -> Pattern a
pat [Pattern a]
cargs) Maybe (Term v a)
forall a. Maybe a
Nothing Term v a
rhs]
where
fname' :: v
fname' =
Text -> v
forall v. Var v => Text -> v
Var.named (Text -> v) -> (v -> Text) -> v -> v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> Text
forall v. Var v => v -> Text
Var.name (v -> v) -> v -> v
forall a b. (a -> b) -> a -> b
$
Set v -> v -> v
forall v. Var v => Set v -> v -> v
Var.freshIn
([v] -> Set v
forall a. Ord a => [a] -> Set a
Set.fromList ([v] -> Set v) -> [v] -> Set v
forall a b. (a -> b) -> a -> b
$ [v
argname] [v] -> [v] -> [v]
forall a. Semigroup a => a -> a -> a
<> ((v, a, Type v a) -> v
forall {a} {b} {c}. (a, b, c) -> a
fst3 ((v, a, Type v a) -> v) -> [(v, a, Type v a)] -> [v]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(v, a, Type v a)]
fields))
(Text -> v
forall v. Var v => Text -> v
Var.named Text
"f")
cargs :: [Pattern a]
cargs = [a -> Pattern a
forall loc. loc -> Pattern loc
Pattern.Var a
ann | (v, a, Type v a)
_ <- [(v, a, Type v a)]
fields]
rhs :: Term v a
rhs =
(v -> Term v a -> Term v a) -> Term v a -> [v] -> Term v a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
(a -> v -> Term v a -> Term v a
forall v a (f :: * -> *).
Ord v =>
a -> v -> Term f v a -> Term f v a
ABT.abs' a
ann)
(a -> GConstructorReference TypeReference -> Term v a
forall v a vt at ap.
Ord v =>
a -> GConstructorReference TypeReference -> Term2 vt at ap v a
Term.constructor a
ann GConstructorReference TypeReference
conref Term v a -> [Term v a] -> Term v a
forall v a vt at ap.
(Ord v, Semigroup a) =>
Term2 vt at ap v a -> [Term2 vt at ap v a] -> Term2 vt at ap v a
`Term.apps'` [Term v a]
vargs)
((v, a, Type v a) -> v
forall {a} {b} {c}. (a, b, c) -> a
fst3 ((v, a, Type v a) -> v) -> [(v, a, Type v a)] -> [v]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(v, a, Type v a)]
fields)
vargs :: [Term v a]
vargs =
[ if Int
j Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
i
then Term v a -> [Term v a] -> Term v a
forall v a vt at ap.
(Ord v, Semigroup a) =>
Term2 vt at ap v a -> [Term2 vt at ap v a] -> Term2 vt at ap v a
Term.apps' (a -> v -> Term v a
forall a v vt at ap. a -> v -> Term2 vt at ap v a
Term.var a
ann v
fname') [a -> v -> Term v a
forall a v vt at ap. a -> v -> Term2 vt at ap v a
Term.var a
ann v
v]
else a -> v -> Term v a
forall a v vt at ap. a -> v -> Term2 vt at ap v a
Term.var a
ann v
v
| ((v
v, a
_, Type v a
_), Int
j) <- [(v, a, Type v a)]
fields [(v, a, Type v a)] -> [Int] -> [((v, a, Type v a), Int)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Int
0 ..]
]
fst3 :: (a, b, c) -> a
fst3 (a
x, b
_, c
_) = a
x