module Unison.FileParsers
  ( ShouldUseTndr (..),
    computeTypecheckingEnvironment,
    synthesizeFile,
  )
where

import Control.Lens
import Control.Monad.State (evalStateT)
import Data.Foldable qualified as Foldable
import Data.List (partition)
import Data.List qualified as List
import Data.List.NonEmpty qualified as List.NonEmpty
import Data.Map qualified as Map
import Data.Sequence qualified as Seq
import Data.Set qualified as Set
import Unison.ABT qualified as ABT
import Unison.Blank qualified as Blank
import Unison.Builtin qualified as Builtin
import Unison.ConstructorReference qualified as ConstructorReference
import Unison.Name qualified as Name
import Unison.Names qualified as Names
import Unison.Parser.Ann (Ann)
import Unison.Prelude
import Unison.PrettyPrintEnv.Names qualified as PPE
import Unison.Reference (TermReference, TypeReference)
import Unison.Referent qualified as Referent
import Unison.Result (CompilerBug (..), Note (..), ResultT, pattern Result)
import Unison.Result qualified as Result
import Unison.Syntax.Name qualified as Name (unsafeParseVar)
import Unison.Syntax.Parser qualified as Parser
import Unison.Term qualified as Term
import Unison.Type qualified as Type
import Unison.Typechecker qualified as Typechecker
import Unison.Typechecker.Context qualified as Context
import Unison.Typechecker.Extractor (RedundantTypeAnnotation)
import Unison.Typechecker.TypeLookup qualified as TL
import Unison.UnisonFile (definitionLocation)
import Unison.UnisonFile qualified as UF
import Unison.UnisonFile.Names qualified as UF
import Unison.Util.Defns (Defns (..), DefnsF)
import Unison.Util.List qualified as List
import Unison.Util.Relation qualified as Rel
import Unison.Var (Var)
import Unison.Var qualified as Var
import Unison.WatchKind (WatchKind)

type Term v = Term.Term v Ann

type Type v = Type.Type v Ann

type UnisonFile v = UF.UnisonFile v Ann

-- each round of TDNR emits its own TopLevelComponent notes, so we remove
-- duplicates (based on var name and location), preferring the later note as
-- that will have the latest typechecking info
convertNotes :: (Ord v) => Typechecker.Notes v ann -> Seq (Note v ann)
convertNotes :: forall v ann. Ord v => Notes v ann -> Seq (Note v ann)
convertNotes (Typechecker.Notes Seq (CompilerBug v ann)
bugs Seq (ErrorNote v ann)
es Seq (InfoNote v ann)
is) =
  (CompilerBug v ann -> Note v ann
forall v loc. CompilerBug v loc -> Note v loc
CompilerBug (CompilerBug v ann -> Note v ann)
-> (CompilerBug v ann -> CompilerBug v ann)
-> CompilerBug v ann
-> Note v ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompilerBug v ann -> CompilerBug v ann
forall v loc. CompilerBug v loc -> CompilerBug v loc
TypecheckerBug (CompilerBug v ann -> Note v ann)
-> Seq (CompilerBug v ann) -> Seq (Note v ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Seq (CompilerBug v ann)
bugs) Seq (Note v ann) -> Seq (Note v ann) -> Seq (Note v ann)
forall a. Semigroup a => a -> a -> a
<> (ErrorNote v ann -> Note v ann
forall v loc. ErrorNote v loc -> Note v loc
TypeError (ErrorNote v ann -> Note v ann)
-> Seq (ErrorNote v ann) -> Seq (Note v ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Seq (ErrorNote v ann)
es) Seq (Note v ann) -> Seq (Note v ann) -> Seq (Note v ann)
forall a. Semigroup a => a -> a -> a
<> (InfoNote v ann -> Note v ann
forall v loc. InfoNote v loc -> Note v loc
TypeInfo (InfoNote v ann -> Note v ann)
-> Seq (InfoNote v ann) -> Seq (Note v ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [InfoNote v ann] -> Seq (InfoNote v ann)
forall a. [a] -> Seq a
Seq.fromList [InfoNote v ann]
is')
  where
    is' :: [InfoNote v ann]
is' = (Word, InfoNote v ann) -> InfoNote v ann
forall a b. (a, b) -> b
snd ((Word, InfoNote v ann) -> InfoNote v ann)
-> [(Word, InfoNote v ann)] -> [InfoNote v ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Word, InfoNote v ann) -> Either Word [v])
-> [(Word, InfoNote v ann)] -> [(Word, InfoNote v ann)]
forall (f :: * -> *) b a.
(Foldable f, Ord b) =>
(a -> b) -> f a -> [a]
List.uniqueBy' (Word, InfoNote v ann) -> Either Word [v]
forall {a} {a} {loc}. (a, InfoNote a loc) -> Either a [a]
f ([(Word
1 :: Word) ..] [Word] -> [InfoNote v ann] -> [(Word, InfoNote v ann)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` Seq (InfoNote v ann) -> [InfoNote v ann]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList Seq (InfoNote v ann)
is)
    f :: (a, InfoNote a loc) -> Either a [a]
f (a
_, Context.TopLevelComponent [(a, Type a loc, RedundantTypeAnnotation)]
cs) = [a] -> Either a [a]
forall a b. b -> Either a b
Right [a
v | (a
v, Type a loc
_, RedundantTypeAnnotation
_) <- [(a, Type a loc, RedundantTypeAnnotation)]
cs]
    f (a
i, InfoNote a loc
_) = a -> Either a [a]
forall a b. a -> Either a b
Left a
i

-- | Should we use type-directed name resolution?
data ShouldUseTndr m
  = ShouldUseTndr'No
  | ShouldUseTndr'Yes (Parser.ParsingEnv m)

-- | Compute a typechecking environment, given:
--
--     * Whether or not to use type-directed name resolution during type checking.
--     * The abilities that are considered to already have ambient handlers.
--     * A function to compute a @TypeLookup@ for the given set of type- or term-references.
--     * The parsing environment that was used to parse the parsed Unison file.
--     * The parsed Unison file for which the typechecking environment is applicable.
computeTypecheckingEnvironment ::
  (Var v, Monad m) =>
  ShouldUseTndr m ->
  [Type v] ->
  (DefnsF Set TermReference TypeReference -> m (TL.TypeLookup v Ann)) ->
  UnisonFile v ->
  m (Typechecker.Env v Ann)
computeTypecheckingEnvironment :: forall v (m :: * -> *).
(Var v, Monad m) =>
ShouldUseTndr m
-> [Type v]
-> (DefnsF Set TermReference TermReference -> m (TypeLookup v Ann))
-> UnisonFile v
-> m (Env v Ann)
computeTypecheckingEnvironment ShouldUseTndr m
shouldUseTndr [Type v]
ambientAbilities DefnsF Set TermReference TermReference -> m (TypeLookup v Ann)
typeLookupf UnisonFile v
uf =
  case ShouldUseTndr m
shouldUseTndr of
    ShouldUseTndr m
ShouldUseTndr'No -> do
      TypeLookup v Ann
tl <- DefnsF Set TermReference TermReference -> m (TypeLookup v Ann)
typeLookupf (UnisonFile v -> DefnsF Set TermReference TermReference
forall a v.
(Monoid a, Var v) =>
UnisonFile v a -> DefnsF Set TermReference TermReference
UF.dependencies UnisonFile v
uf)
      pure
        Typechecker.Env
          { $sel:ambientAbilities:Env :: [Type v]
ambientAbilities = [Type v]
ambientAbilities,
            $sel:typeLookup:Env :: TypeLookup v Ann
typeLookup = TypeLookup v Ann
tl,
            $sel:termsByShortname:Env :: Map Name [NamedReference v Ann]
termsByShortname = Map Name [NamedReference v Ann]
forall k a. Map k a
Map.empty
          }
    ShouldUseTndr'Yes ParsingEnv m
parsingEnv -> do
      let preexistingNames :: Names
preexistingNames = ParsingEnv m -> Names
forall (m :: * -> *). ParsingEnv m -> Names
Parser.names ParsingEnv m
parsingEnv
          tm :: Term v Ann
tm = UnisonFile v -> Term v Ann
forall v a. (Var v, Monoid a) => UnisonFile v a -> Term v a
UF.typecheckingTerm UnisonFile v
uf
          possibleDeps :: [(Name, Name, Referent)]
possibleDeps =
            [ (Name
name, Name
shortname, Referent
r)
              | (Name
name, Referent
r) <- Relation Name Referent -> [(Name, Referent)]
forall a b. Relation a b -> [(a, b)]
Rel.toList (Names -> Relation Name Referent
Names.terms Names
preexistingNames),
                v
v <- Set v -> [v]
forall a. Set a -> [a]
Set.toList (Term v Ann -> Set v
forall vt v a. Term' vt v a -> Set v
Term.freeVars Term v Ann
tm),
                let shortname :: Name
shortname = v -> Name
forall v. Var v => v -> Name
Name.unsafeParseVar v
v,
                Name
name Name -> [NameSegment] -> RedundantTypeAnnotation
`Name.endsWithReverseSegments` NonEmpty NameSegment -> [NameSegment]
forall a. NonEmpty a -> [a]
List.NonEmpty.toList (Name -> NonEmpty NameSegment
Name.reverseSegments Name
shortname)
            ]
          possibleRefs :: DefnsF Set TermReference TermReference
possibleRefs =
            (DefnsF Set TermReference TermReference
 -> (Name, Name, Referent)
 -> DefnsF Set TermReference TermReference)
-> DefnsF Set TermReference TermReference
-> [(Name, Name, Referent)]
-> DefnsF Set TermReference TermReference
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl'
              ( \DefnsF Set TermReference TermReference
acc -> \case
                  (Name
_, Name
_, Referent.Con ConstructorReference
ref ConstructorType
_) -> DefnsF Set TermReference TermReference
acc DefnsF Set TermReference TermReference
-> (DefnsF Set TermReference TermReference
    -> DefnsF Set TermReference TermReference)
-> DefnsF Set TermReference TermReference
forall a b. a -> (a -> b) -> b
& ASetter
  (DefnsF Set TermReference TermReference)
  (DefnsF Set TermReference TermReference)
  (Set TermReference)
  (Set TermReference)
-> (Set TermReference -> Set TermReference)
-> DefnsF Set TermReference TermReference
-> DefnsF Set TermReference TermReference
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
  (DefnsF Set TermReference TermReference)
  (DefnsF Set TermReference TermReference)
  (Set TermReference)
  (Set TermReference)
#types (TermReference -> Set TermReference -> Set TermReference
forall a. Ord a => a -> Set a -> Set a
Set.insert (ConstructorReference
ref ConstructorReference
-> Getting TermReference ConstructorReference TermReference
-> TermReference
forall s a. s -> Getting a s a -> a
^. Getting TermReference ConstructorReference TermReference
forall r s (f :: * -> *).
Functor f =>
(r -> f s)
-> GConstructorReference r -> f (GConstructorReference s)
ConstructorReference.reference_))
                  (Name
_, Name
_, Referent.Ref TermReference
ref) -> DefnsF Set TermReference TermReference
acc DefnsF Set TermReference TermReference
-> (DefnsF Set TermReference TermReference
    -> DefnsF Set TermReference TermReference)
-> DefnsF Set TermReference TermReference
forall a b. a -> (a -> b) -> b
& ASetter
  (DefnsF Set TermReference TermReference)
  (DefnsF Set TermReference TermReference)
  (Set TermReference)
  (Set TermReference)
-> (Set TermReference -> Set TermReference)
-> DefnsF Set TermReference TermReference
-> DefnsF Set TermReference TermReference
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
  (DefnsF Set TermReference TermReference)
  (DefnsF Set TermReference TermReference)
  (Set TermReference)
  (Set TermReference)
#terms (TermReference -> Set TermReference -> Set TermReference
forall a. Ord a => a -> Set a -> Set a
Set.insert TermReference
ref)
              )
              (Set TermReference
-> Set TermReference -> DefnsF Set TermReference TermReference
forall terms types. terms -> types -> Defns terms types
Defns Set TermReference
forall a. Set a
Set.empty Set TermReference
forall a. Set a
Set.empty)
              [(Name, Name, Referent)]
possibleDeps
      TypeLookup v Ann
tl <- (TypeLookup v Ann -> TypeLookup v Ann)
-> m (TypeLookup v Ann) -> m (TypeLookup v Ann)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (UnisonFile v -> TypeLookup v Ann
forall v a. Var v => UnisonFile v a -> TypeLookup v a
UF.declsToTypeLookup UnisonFile v
uf TypeLookup v Ann -> TypeLookup v Ann -> TypeLookup v Ann
forall a. Semigroup a => a -> a -> a
<>) (DefnsF Set TermReference TermReference -> m (TypeLookup v Ann)
typeLookupf (UnisonFile v -> DefnsF Set TermReference TermReference
forall a v.
(Monoid a, Var v) =>
UnisonFile v a -> DefnsF Set TermReference TermReference
UF.dependencies UnisonFile v
uf DefnsF Set TermReference TermReference
-> DefnsF Set TermReference TermReference
-> DefnsF Set TermReference TermReference
forall a. Semigroup a => a -> a -> a
<> DefnsF Set TermReference TermReference
possibleRefs))
      -- For populating the TDNR environment, we pick definitions
      -- from the namespace and from the local file whose full name
      -- has a suffix that equals one of the free variables in the file.
      -- Example, the namespace has [foo.bar.baz, qux.quaffle] and
      -- the file has definitons [utils.zonk, utils.blah] and
      -- the file has free variables [bar.baz, zonk].
      --
      -- In this case, [foo.bar.baz, utils.zonk] are used to create
      -- the TDNR environment.
      let fqnsByShortName :: Map Name [NamedReference v Ann]
fqnsByShortName =
            [(Name, NamedReference v Ann)] -> Map Name [NamedReference v Ann]
forall (f :: * -> *) k v.
(Foldable f, Ord k) =>
f (k, v) -> Map k [v]
List.multimap ([(Name, NamedReference v Ann)] -> Map Name [NamedReference v Ann])
-> [(Name, NamedReference v Ann)]
-> Map Name [NamedReference v Ann]
forall a b. (a -> b) -> a -> b
$
              -- external TDNR possibilities
              [ (Name
shortname, NamedReference v Ann
nr)
                | (Name
name, Name
shortname, Referent
r) <- [(Name, Name, Referent)]
possibleDeps,
                  Type v
typ <- Maybe (Type v) -> [Type v]
forall a. Maybe a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Maybe (Type v) -> [Type v]) -> Maybe (Type v) -> [Type v]
forall a b. (a -> b) -> a -> b
$ TypeLookup v Ann -> Referent -> Maybe (Type v)
forall v a. TypeLookup v a -> Referent -> Maybe (Type v a)
TL.typeOfReferent TypeLookup v Ann
tl Referent
r,
                  let nr :: NamedReference v Ann
nr = Name -> Type v -> Replacement v -> NamedReference v Ann
forall v loc.
Name -> Type v loc -> Replacement v -> NamedReference v loc
Typechecker.NamedReference Name
name Type v
typ (Referent -> Replacement v
forall v. Referent -> Replacement v
Context.ReplacementRef Referent
r)
              ]
                [(Name, NamedReference v Ann)]
-> [(Name, NamedReference v Ann)] -> [(Name, NamedReference v Ann)]
forall a. Semigroup a => a -> a -> a
<>
                -- local file TDNR possibilities
                [ (Name
shortname, NamedReference v Ann
nr)
                  | (Name
name, Referent
r) <- Relation Name Referent -> [(Name, Referent)]
forall a b. Relation a b -> [(a, b)]
Rel.toList (Names -> Relation Name Referent
Names.terms (Names -> Relation Name Referent)
-> Names -> Relation Name Referent
forall a b. (a -> b) -> a -> b
$ UnisonFile v -> Names
forall v a. Var v => UnisonFile v a -> Names
UF.toNames UnisonFile v
uf),
                    v
v <- Set v -> [v]
forall a. Set a -> [a]
Set.toList (Term v Ann -> Set v
forall vt v a. Term' vt v a -> Set v
Term.freeVars Term v Ann
tm),
                    let shortname :: Name
shortname = v -> Name
forall v. Var v => v -> Name
Name.unsafeParseVar v
v,
                    Name
name Name -> [NameSegment] -> RedundantTypeAnnotation
`Name.endsWithReverseSegments` NonEmpty NameSegment -> [NameSegment]
forall a. NonEmpty a -> [a]
List.NonEmpty.toList (Name -> NonEmpty NameSegment
Name.reverseSegments Name
shortname),
                    Type v
typ <- Maybe (Type v) -> [Type v]
forall a. Maybe a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Maybe (Type v) -> [Type v]) -> Maybe (Type v) -> [Type v]
forall a b. (a -> b) -> a -> b
$ TypeLookup v Ann -> Referent -> Maybe (Type v)
forall v a. TypeLookup v a -> Referent -> Maybe (Type v a)
TL.typeOfReferent TypeLookup v Ann
tl Referent
r,
                    let nr :: NamedReference v Ann
nr = Name -> Type v -> Replacement v -> NamedReference v Ann
forall v loc.
Name -> Type v loc -> Replacement v -> NamedReference v loc
Typechecker.NamedReference Name
name Type v
typ (Referent -> Replacement v
forall v. Referent -> Replacement v
Context.ReplacementRef Referent
r)
                ]
      Env v Ann -> m (Env v Ann)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        Typechecker.Env
          { [Type v]
ambientAbilities :: [Type v]
$sel:ambientAbilities:Env :: [Type v]
ambientAbilities,
            $sel:typeLookup:Env :: TypeLookup v Ann
typeLookup = TypeLookup v Ann
tl,
            $sel:termsByShortname:Env :: Map Name [NamedReference v Ann]
termsByShortname = Map Name [NamedReference v Ann]
fqnsByShortName
          }

synthesizeFile ::
  forall m v.
  (Monad m, Var v) =>
  Typechecker.Env v Ann ->
  UnisonFile v ->
  ResultT (Seq (Note v Ann)) m (UF.TypecheckedUnisonFile v Ann)
synthesizeFile :: forall (m :: * -> *) v.
(Monad m, Var v) =>
Env v Ann
-> UnisonFile v
-> ResultT (Seq (Note v Ann)) m (TypecheckedUnisonFile v Ann)
synthesizeFile Env v Ann
env0 UnisonFile v
uf = do
  let term :: Term v Ann
term = UnisonFile v -> Term v Ann
forall v a. (Var v, Monoid a) => UnisonFile v a -> Term v a
UF.typecheckingTerm UnisonFile v
uf
      -- substitute Blanks for any remaining free vars in UF body
      tdnrTerm :: Term v Ann
tdnrTerm = Term v Ann -> Term v Ann
forall v vt b ap.
Var v =>
Term (F vt b ap) v b -> Term (F vt b ap) v b
Term.prepareTDNR Term v Ann
term
      unisonFilePPE :: PrettyPrintEnv
unisonFilePPE = Namer -> Suffixifier -> PrettyPrintEnv
PPE.makePPE (Int -> Names -> Namer
PPE.hqNamer Int
10 (Names -> Names -> Names
Names.shadowing (UnisonFile v -> Names
forall v a. Var v => UnisonFile v a -> Names
UF.toNames UnisonFile v
uf) Names
Builtin.names)) Suffixifier
PPE.dontSuffixify
      Result Notes v Ann
notes Maybe (Type v Ann)
mayType =
        StateT (Term v Ann) (ResultT (Notes v Ann) Identity) (Type v Ann)
-> Term v Ann
-> MaybeT (WriterT (Notes v Ann) Identity) (Type v Ann)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (PrettyPrintEnv
-> Env v Ann
-> StateT
     (Term v Ann) (ResultT (Notes v Ann) Identity) (Type v Ann)
forall (f :: * -> *) v loc.
(Monad f, Var v, Monoid loc, BuiltinAnnotation loc, Ord loc,
 Show loc) =>
PrettyPrintEnv -> Env v loc -> TDNR f v loc (Type v loc)
Typechecker.synthesizeAndResolve PrettyPrintEnv
unisonFilePPE Env v Ann
env0) Term v Ann
tdnrTerm
  -- If typechecking succeeded, reapply the TDNR decisions to user's term:
  Seq (Note v Ann)
-> Maybe (Type v Ann) -> ResultT (Seq (Note v Ann)) m (Type v Ann)
forall (m :: * -> *) notes a.
Applicative m =>
notes -> Maybe a -> ResultT notes m a
Result.makeResult (Notes v Ann -> Seq (Note v Ann)
forall v ann. Ord v => Notes v ann -> Seq (Note v ann)
convertNotes Notes v Ann
notes) Maybe (Type v Ann)
mayType ResultT (Seq (Note v Ann)) m (Type v Ann)
-> (Type v Ann
    -> ResultT (Seq (Note v Ann)) m (TypecheckedUnisonFile v Ann))
-> ResultT (Seq (Note v Ann)) m (TypecheckedUnisonFile v Ann)
forall a b.
MaybeT (WriterT (Seq (Note v Ann)) m) a
-> (a -> MaybeT (WriterT (Seq (Note v Ann)) m) b)
-> MaybeT (WriterT (Seq (Note v Ann)) m) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Type v Ann
_typ -> do
    let infos :: [InfoNote v Ann]
infos = Seq (InfoNote v Ann) -> [InfoNote v Ann]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList (Seq (InfoNote v Ann) -> [InfoNote v Ann])
-> Seq (InfoNote v Ann) -> [InfoNote v Ann]
forall a b. (a -> b) -> a -> b
$ Notes v Ann -> Seq (InfoNote v Ann)
forall v loc. Notes v loc -> Seq (InfoNote v loc)
Typechecker.infos Notes v Ann
notes
    ([[(v, Term v Ann, Type v Ann)]]
topLevelComponents :: [[(v, Term v, Type v)]]) <-
      let topLevelBindings :: Map v (Term v)
          topLevelBindings :: Map v (Term v Ann)
topLevelBindings = (v -> v) -> Map v (Term v Ann) -> Map v (Term v Ann)
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys v -> v
forall v. Var v => v -> v
Var.reset (Map v (Term v Ann) -> Map v (Term v Ann))
-> Map v (Term v Ann) -> Map v (Term v Ann)
forall a b. (a -> b) -> a -> b
$ Term v Ann -> Map v (Term v Ann)
forall a. Term v a -> Map v (Term v a)
extractTopLevelBindings Term v Ann
tdnrTerm
          extractTopLevelBindings :: (Term.Term v a -> Map v (Term.Term v a))
          extractTopLevelBindings :: forall a. Term v a -> Map v (Term v a)
extractTopLevelBindings (Term.LetRecNamedAnnotatedTop' RedundantTypeAnnotation
True a
_ [((a, v), Term v a)]
bs Term v a
body) =
            [(v, Term v a)] -> Map v (Term v a)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (((a, v) -> v) -> ((a, v), Term v a) -> (v, Term v a)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (a, v) -> v
forall a b. (a, b) -> b
snd (((a, v), Term v a) -> (v, Term v a))
-> [((a, v), Term v a)] -> [(v, Term v a)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [((a, v), Term v a)]
bs) Map v (Term v a) -> Map v (Term v a) -> Map v (Term v a)
forall a. Semigroup a => a -> a -> a
<> Term v a -> Map v (Term v a)
forall a. Term v a -> Map v (Term v a)
extractTopLevelBindings Term v a
body
          extractTopLevelBindings Term v a
_ = Map v (Term v a)
forall k a. Map k a
Map.empty
          tlcsFromTypechecker :: [[(v, Type.Type v Ann, RedundantTypeAnnotation)]]
          tlcsFromTypechecker :: [[(v, Type v Ann, RedundantTypeAnnotation)]]
tlcsFromTypechecker =
            ([(v, Type v Ann, RedundantTypeAnnotation)] -> [v])
-> [[(v, Type v Ann, RedundantTypeAnnotation)]]
-> [[(v, Type v Ann, RedundantTypeAnnotation)]]
forall (f :: * -> *) b a.
(Foldable f, Ord b) =>
(a -> b) -> f a -> [a]
List.uniqueBy'
              (((v, Type v Ann, RedundantTypeAnnotation) -> v)
-> [(v, Type v Ann, RedundantTypeAnnotation)] -> [v]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (v, Type v Ann, RedundantTypeAnnotation) -> v
forall {a} {b} {c}. (a, b, c) -> a
vars)
              [[(v, Type v Ann, RedundantTypeAnnotation)]
t | Context.TopLevelComponent [(v, Type v Ann, RedundantTypeAnnotation)]
t <- [InfoNote v Ann]
infos]
            where
              vars :: (a, b, c) -> a
vars (a
v, b
_, c
_) = a
v
          addTypesToTopLevelBindings :: (v, c, c1) -> ResultT (Seq (Note v Ann)) m (v, Term v, c)
          addTypesToTopLevelBindings :: forall c c1.
(v, c, c1) -> ResultT (Seq (Note v Ann)) m (v, Term v Ann, c)
addTypesToTopLevelBindings (v
v, c
typ, c1
_redundant) = do
            Term v Ann
tm <- case v -> Map v (Term v Ann) -> Maybe (Term v Ann)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup v
v Map v (Term v Ann)
topLevelBindings of
              Maybe (Term v Ann)
Nothing -> CompilerBug v Ann
-> MaybeT (WriterT (Seq (Note v Ann)) m) (Term v Ann)
forall (f :: * -> *) v loc a.
Monad f =>
CompilerBug v loc -> ResultT (Seq (Note v loc)) f a
Result.compilerBug (CompilerBug v Ann
 -> MaybeT (WriterT (Seq (Note v Ann)) m) (Term v Ann))
-> CompilerBug v Ann
-> MaybeT (WriterT (Seq (Note v Ann)) m) (Term v Ann)
forall a b. (a -> b) -> a -> b
$ v -> Term v Ann -> CompilerBug v Ann
forall v loc. v -> Term v loc -> CompilerBug v loc
Result.TopLevelComponentNotFound v
v Term v Ann
term
              Just Term v Ann
x -> Term v Ann -> MaybeT (WriterT (Seq (Note v Ann)) m) (Term v Ann)
forall a. a -> MaybeT (WriterT (Seq (Note v Ann)) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term v Ann
x
            -- The Var.reset removes any freshening added during typechecking
            pure (v -> v
forall v. Var v => v -> v
Var.reset v
v, Term v Ann
tm, c
typ)
       in ([(v, Type v Ann, RedundantTypeAnnotation)]
 -> MaybeT
      (WriterT (Seq (Note v Ann)) m) [(v, Term v Ann, Type v Ann)])
-> [[(v, Type v Ann, RedundantTypeAnnotation)]]
-> MaybeT
     (WriterT (Seq (Note v Ann)) m) [[(v, Term v Ann, Type v Ann)]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (((v, Type v Ann, RedundantTypeAnnotation)
 -> MaybeT
      (WriterT (Seq (Note v Ann)) m) (v, Term v Ann, Type v Ann))
-> [(v, Type v Ann, RedundantTypeAnnotation)]
-> MaybeT
     (WriterT (Seq (Note v Ann)) m) [(v, Term v Ann, Type v Ann)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (v, Type v Ann, RedundantTypeAnnotation)
-> MaybeT
     (WriterT (Seq (Note v Ann)) m) (v, Term v Ann, Type v Ann)
forall c c1.
(v, c, c1) -> ResultT (Seq (Note v Ann)) m (v, Term v Ann, c)
addTypesToTopLevelBindings) [[(v, Type v Ann, RedundantTypeAnnotation)]]
tlcsFromTypechecker
    let doTdnr :: Term v Ann -> Term v Ann
doTdnr = [InfoNote v Ann] -> Term v Ann -> Term v Ann
applyTdnrDecisions [InfoNote v Ann]
infos
    let doTdnrInComponent :: (v, Term v Ann, Type v Ann) -> (v, Term v Ann, Type v Ann)
doTdnrInComponent (v
v, Term v Ann
t, Type v Ann
tp) = (v
v, Term v Ann -> Term v Ann
doTdnr Term v Ann
t, Type v Ann
tp)
    let tdnredTlcs :: [[(v, Ann, Term v Ann, Type v Ann)]]
tdnredTlcs =
          [[(v, Term v Ann, Type v Ann)]]
topLevelComponents
            [[(v, Term v Ann, Type v Ann)]]
-> ([[(v, Term v Ann, Type v Ann)]]
    -> [[(v, Ann, Term v Ann, Type v Ann)]])
-> [[(v, Ann, Term v Ann, Type v Ann)]]
forall a b. a -> (a -> b) -> b
& (([(v, Term v Ann, Type v Ann)]
 -> [(v, Ann, Term v Ann, Type v Ann)])
-> [[(v, Term v Ann, Type v Ann)]]
-> [[(v, Ann, Term v Ann, Type v Ann)]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([(v, Term v Ann, Type v Ann)]
  -> [(v, Ann, Term v Ann, Type v Ann)])
 -> [[(v, Term v Ann, Type v Ann)]]
 -> [[(v, Ann, Term v Ann, Type v Ann)]])
-> (((v, Term v Ann, Type v Ann)
     -> (v, Ann, Term v Ann, Type v Ann))
    -> [(v, Term v Ann, Type v Ann)]
    -> [(v, Ann, Term v Ann, Type v Ann)])
-> ((v, Term v Ann, Type v Ann)
    -> (v, Ann, Term v Ann, Type v Ann))
-> [[(v, Term v Ann, Type v Ann)]]
-> [[(v, Ann, Term v Ann, Type v Ann)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((v, Term v Ann, Type v Ann) -> (v, Ann, Term v Ann, Type v Ann))
-> [(v, Term v Ann, Type v Ann)]
-> [(v, Ann, Term v Ann, Type v Ann)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap)
              ( \(v, Term v Ann, Type v Ann)
vtt ->
                  (v, Term v Ann, Type v Ann)
vtt
                    (v, Term v Ann, Type v Ann)
-> ((v, Term v Ann, Type v Ann) -> (v, Term v Ann, Type v Ann))
-> (v, Term v Ann, Type v Ann)
forall a b. a -> (a -> b) -> b
& (v, Term v Ann, Type v Ann) -> (v, Term v Ann, Type v Ann)
doTdnrInComponent
                    (v, Term v Ann, Type v Ann)
-> ((v, Term v Ann, Type v Ann)
    -> (v, Ann, Term v Ann, Type v Ann))
-> (v, Ann, Term v Ann, Type v Ann)
forall a b. a -> (a -> b) -> b
& \(v
v, Term v Ann
t, Type v Ann
tp) -> (v
v, Ann -> Maybe Ann -> Ann
forall a. a -> Maybe a -> a
fromMaybe (String -> Ann
forall a. HasCallStack => String -> a
error (String -> Ann) -> String -> Ann
forall a b. (a -> b) -> a -> b
$ String
"Symbol from typechecked file not present in parsed file" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> v -> String
forall a. Show a => a -> String
show v
v) (v -> UnisonFile v -> Maybe Ann
forall v a. Var v => v -> UnisonFile v a -> Maybe a
definitionLocation v
v UnisonFile v
uf), Term v Ann
t, Type v Ann
tp)
              )
    let ([[(v, Ann, Term v Ann, Type v Ann)]]
watches', [[(v, Ann, Term v Ann, Type v Ann)]]
terms') = ([(v, Ann, Term v Ann, Type v Ann)] -> RedundantTypeAnnotation)
-> [[(v, Ann, Term v Ann, Type v Ann)]]
-> ([[(v, Ann, Term v Ann, Type v Ann)]],
    [[(v, Ann, Term v Ann, Type v Ann)]])
forall a. (a -> RedundantTypeAnnotation) -> [a] -> ([a], [a])
partition [(v, Ann, Term v Ann, Type v Ann)] -> RedundantTypeAnnotation
isWatch [[(v, Ann, Term v Ann, Type v Ann)]]
tdnredTlcs
        isWatch :: [(v, Ann, Term v Ann, Type v Ann)] -> RedundantTypeAnnotation
isWatch = ((v, Ann, Term v Ann, Type v Ann) -> RedundantTypeAnnotation)
-> [(v, Ann, Term v Ann, Type v Ann)] -> RedundantTypeAnnotation
forall (t :: * -> *) a.
Foldable t =>
(a -> RedundantTypeAnnotation) -> t a -> RedundantTypeAnnotation
all (\(v
v, Ann
_, Term v Ann
_, Type v Ann
_) -> v -> Set v -> RedundantTypeAnnotation
forall a. Ord a => a -> Set a -> RedundantTypeAnnotation
Set.member v
v Set v
watchedVars)
        watchedVars :: Set v
watchedVars = [v] -> Set v
forall a. Ord a => [a] -> Set a
Set.fromList [v
v | (v
v, Ann
_a, Term v Ann
_) <- UnisonFile v -> [(v, Ann, Term v Ann)]
forall v a. UnisonFile v a -> [(v, a, Term v a)]
UF.allWatches UnisonFile v
uf]
        tlcKind :: [(v, Ann, Term v Ann, Type v Ann)]
-> (String, [(v, Ann, Term v Ann, Type v Ann)])
tlcKind [] = String -> (String, [(v, Ann, Term v Ann, Type v Ann)])
forall a. HasCallStack => String -> a
error String
"empty TLC, should never occur"
        tlcKind tlc :: [(v, Ann, Term v Ann, Type v Ann)]
tlc@((v
v, Ann
_, Term v Ann
_, Type v Ann
_) : [(v, Ann, Term v Ann, Type v Ann)]
_) =
          let hasE :: WatchKind -> Bool
              hasE :: String -> RedundantTypeAnnotation
hasE String
k = v -> [v] -> RedundantTypeAnnotation
forall a. Eq a => a -> [a] -> RedundantTypeAnnotation
forall (t :: * -> *) a.
(Foldable t, Eq a) =>
a -> t a -> RedundantTypeAnnotation
elem v
v ([v] -> RedundantTypeAnnotation)
-> ([(v, Ann, Term v Ann)] -> [v])
-> [(v, Ann, Term v Ann)]
-> RedundantTypeAnnotation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((v, Ann, Term v Ann) -> v) -> [(v, Ann, Term v Ann)] -> [v]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Getting v (v, Ann, Term v Ann) v -> (v, Ann, Term v Ann) -> v
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting v (v, Ann, Term v Ann) v
forall s t a b. Field1 s t a b => Lens s t a b
Lens (v, Ann, Term v Ann) (v, Ann, Term v Ann) v v
_1) ([(v, Ann, Term v Ann)] -> RedundantTypeAnnotation)
-> [(v, Ann, Term v Ann)] -> RedundantTypeAnnotation
forall a b. (a -> b) -> a -> b
$ [(v, Ann, Term v Ann)]
-> String
-> Map String [(v, Ann, Term v Ann)]
-> [(v, Ann, Term v Ann)]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] String
k (UnisonFile v -> Map String [(v, Ann, Term v Ann)]
forall v a. UnisonFile v a -> Map String [(v, a, Term v a)]
UF.watches UnisonFile v
uf)
           in case (String -> RedundantTypeAnnotation) -> [String] -> Maybe String
forall (t :: * -> *) a.
Foldable t =>
(a -> RedundantTypeAnnotation) -> t a -> Maybe a
Foldable.find String -> RedundantTypeAnnotation
hasE (Map String [(v, Ann, Term v Ann)] -> [String]
forall k a. Map k a -> [k]
Map.keys (Map String [(v, Ann, Term v Ann)] -> [String])
-> Map String [(v, Ann, Term v Ann)] -> [String]
forall a b. (a -> b) -> a -> b
$ UnisonFile v -> Map String [(v, Ann, Term v Ann)]
forall v a. UnisonFile v a -> Map String [(v, a, Term v a)]
UF.watches UnisonFile v
uf) of
                Maybe String
Nothing -> String -> (String, [(v, Ann, Term v Ann, Type v Ann)])
forall a. HasCallStack => String -> a
error String
"wat"
                Just String
kind -> (String
kind, [(v, Ann, Term v Ann, Type v Ann)]
tlc)
    TypecheckedUnisonFile v Ann
-> ResultT (Seq (Note v Ann)) m (TypecheckedUnisonFile v Ann)
forall a. a -> MaybeT (WriterT (Seq (Note v Ann)) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypecheckedUnisonFile v Ann
 -> ResultT (Seq (Note v Ann)) m (TypecheckedUnisonFile v Ann))
-> TypecheckedUnisonFile v Ann
-> ResultT (Seq (Note v Ann)) m (TypecheckedUnisonFile v Ann)
forall a b. (a -> b) -> a -> b
$
      Map v (Id, DataDeclaration v Ann)
-> Map v (Id, EffectDeclaration v Ann)
-> [[(v, Ann, Term v Ann, Type v Ann)]]
-> [(String, [(v, Ann, Term v Ann, Type v Ann)])]
-> TypecheckedUnisonFile v Ann
forall v a.
Var v =>
Map v (Id, DataDeclaration v a)
-> Map v (Id, EffectDeclaration v a)
-> [[(v, a, Term v a, Type v a)]]
-> [(String, [(v, a, Term v a, Type v a)])]
-> TypecheckedUnisonFile v a
UF.typecheckedUnisonFile
        (UnisonFile v -> Map v (Id, DataDeclaration v Ann)
forall v a. UnisonFile v a -> Map v (Id, DataDeclaration v a)
UF.dataDeclarationsId UnisonFile v
uf)
        (UnisonFile v -> Map v (Id, EffectDeclaration v Ann)
forall v a. UnisonFile v a -> Map v (Id, EffectDeclaration v a)
UF.effectDeclarationsId UnisonFile v
uf)
        [[(v, Ann, Term v Ann, Type v Ann)]]
terms'
        (([(v, Ann, Term v Ann, Type v Ann)]
 -> (String, [(v, Ann, Term v Ann, Type v Ann)]))
-> [[(v, Ann, Term v Ann, Type v Ann)]]
-> [(String, [(v, Ann, Term v Ann, Type v Ann)])]
forall a b. (a -> b) -> [a] -> [b]
map [(v, Ann, Term v Ann, Type v Ann)]
-> (String, [(v, Ann, Term v Ann, Type v Ann)])
tlcKind [[(v, Ann, Term v Ann, Type v Ann)]]
watches')
  where
    applyTdnrDecisions ::
      [Context.InfoNote v Ann] ->
      Term v ->
      Term v
    applyTdnrDecisions :: [InfoNote v Ann] -> Term v Ann -> Term v Ann
applyTdnrDecisions [InfoNote v Ann]
infos Term v Ann
tdnrTerm = (Term v Ann -> Maybe (Term v Ann)) -> Term v Ann -> Term v Ann
forall (f :: * -> *) v a.
(Traversable f, Ord v) =>
(Term f v a -> Maybe (Term f v a)) -> Term f v a -> Term f v a
ABT.visitPure Term v Ann -> Maybe (Term v Ann)
resolve Term v Ann
tdnrTerm
      where
        decisions :: Map (String, Ann) (Term v Ann)
decisions = [((String, Ann), Term v Ann)] -> Map (String, Ann) (Term v Ann)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [((v -> String
forall v. Var v => v -> String
Var.nameStr v
v, Ann
loc), Term v Ann
replacement) | Context.Decision v
v Ann
loc Term v Ann
replacement <- [InfoNote v Ann]
infos]
        -- resolve (v,loc) in a matching Blank to whatever `fqn` maps to in `names`
        resolve :: Term v Ann -> Maybe (Term v Ann)
resolve Term v Ann
t = case Term v Ann
t of
          Term.Blank' (Blank.Recorded (Blank.Resolve Ann
loc' String
name))
            | Just Term v Ann
replacement <- (String, Ann)
-> Map (String, Ann) (Term v Ann) -> Maybe (Term v Ann)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (String
name, Ann
loc') Map (String, Ann) (Term v Ann)
decisions ->
                -- loc of replacement already chosen correctly by whatever made the
                -- Decision
                Term v Ann -> Maybe (Term v Ann)
forall a. a -> Maybe a
Just (Term v Ann -> Maybe (Term v Ann))
-> Term v Ann -> Maybe (Term v Ann)
forall a b. (a -> b) -> a -> b
$ Term v Ann
replacement
          Term v Ann
_ -> Maybe (Term v Ann)
forall a. Maybe a
Nothing