1
1
mirror of https://github.com/anoma/juvix.git synced 2024-12-14 17:32:00 +03:00

Refresh bound variable ids when substituting in Internal (#2501)

* Closes #2476 

Bound variable ids need to be refreshed to maintain the invariant that
each bound variable has a unique id.
This commit is contained in:
Łukasz Czajka 2023-11-07 15:26:18 +01:00 committed by GitHub
parent 5948a38a54
commit 473ed259a5
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
11 changed files with 183 additions and 177 deletions

View File

@ -49,7 +49,7 @@ unsupported thing = error ("Internal to Core: Not yet supported: " <> thing)
mkIdentIndex :: Name -> Text mkIdentIndex :: Name -> Text
mkIdentIndex = show . (^. Internal.nameId . Internal.unNameId) mkIdentIndex = show . (^. Internal.nameId . Internal.unNameId)
fromInternal :: Internal.InternalTypedResult -> Sem k CoreResult fromInternal :: (Member NameIdGen k) => Internal.InternalTypedResult -> Sem k CoreResult
fromInternal i = do fromInternal i = do
res <- res <-
execInfoTableBuilder emptyInfoTable execInfoTableBuilder emptyInfoTable
@ -62,7 +62,7 @@ fromInternal i = do
_coreResultInternalTypedResult = i _coreResultInternalTypedResult = i
} }
where where
f :: (Members '[InfoTableBuilder, Reader InternalTyped.TypesTable, State InternalTyped.FunctionsTable, State InternalTyped.FunctionsTable] r) => Sem r () f :: (Members '[InfoTableBuilder, Reader InternalTyped.TypesTable, State InternalTyped.FunctionsTable, State InternalTyped.FunctionsTable, NameIdGen] r) => Sem r ()
f = do f = do
reserveLiteralIntToNatSymbol reserveLiteralIntToNatSymbol
reserveLiteralIntToIntSymbol reserveLiteralIntToIntSymbol
@ -77,7 +77,7 @@ fromInternal i = do
setupLiteralIntToNat literalIntToNatNode setupLiteralIntToNat literalIntToNatNode
setupLiteralIntToInt literalIntToIntNode setupLiteralIntToInt literalIntToIntNode
fromInternalExpression :: CoreResult -> Internal.Expression -> Sem r Node fromInternalExpression :: (Member NameIdGen r) => CoreResult -> Internal.Expression -> Sem r Node
fromInternalExpression res exp = do fromInternalExpression res exp = do
let modules = res ^. coreResultInternalTypedResult . InternalTyped.resultModules let modules = res ^. coreResultInternalTypedResult . InternalTyped.resultModules
fmap snd fmap snd
@ -96,7 +96,7 @@ goModule = visit . Internal.ModuleIndex
goModuleNoVisit :: goModuleNoVisit ::
forall r. forall r.
(Members '[InfoTableBuilder, Reader InternalTyped.TypesTable, State InternalTyped.FunctionsTable, Reader Internal.InfoTable, MVisit] r) => (Members '[InfoTableBuilder, Reader InternalTyped.TypesTable, State InternalTyped.FunctionsTable, Reader Internal.InfoTable, NameIdGen, MVisit] r) =>
Internal.ModuleIndex -> Internal.ModuleIndex ->
Sem r () Sem r ()
goModuleNoVisit (Internal.ModuleIndex m) = do goModuleNoVisit (Internal.ModuleIndex m) = do
@ -109,7 +109,7 @@ goModuleNoVisit (Internal.ModuleIndex m) = do
-- | predefine an inductive definition -- | predefine an inductive definition
preInductiveDef :: preInductiveDef ::
forall r. forall r.
(Members '[InfoTableBuilder, Reader InternalTyped.TypesTable, State InternalTyped.FunctionsTable, Reader Internal.InfoTable] r) => (Members '[InfoTableBuilder, Reader InternalTyped.TypesTable, State InternalTyped.FunctionsTable, Reader Internal.InfoTable, NameIdGen] r) =>
Internal.InductiveDef -> Internal.InductiveDef ->
Sem r PreInductiveDef Sem r PreInductiveDef
preInductiveDef i = do preInductiveDef i = do
@ -150,7 +150,7 @@ preInductiveDef i = do
goInductiveDef :: goInductiveDef ::
forall r. forall r.
(Members '[InfoTableBuilder, Reader InternalTyped.TypesTable, State InternalTyped.FunctionsTable, Reader Internal.InfoTable] r) => (Members '[InfoTableBuilder, Reader InternalTyped.TypesTable, State InternalTyped.FunctionsTable, Reader Internal.InfoTable, NameIdGen] r) =>
PreInductiveDef -> PreInductiveDef ->
Sem r () Sem r ()
goInductiveDef PreInductiveDef {..} = do goInductiveDef PreInductiveDef {..} = do
@ -164,7 +164,7 @@ goInductiveDef PreInductiveDef {..} = do
goConstructor :: goConstructor ::
forall r. forall r.
(Members '[InfoTableBuilder, Reader Internal.InfoTable, Reader InternalTyped.TypesTable, State InternalTyped.FunctionsTable] r) => (Members '[InfoTableBuilder, Reader Internal.InfoTable, Reader InternalTyped.TypesTable, State InternalTyped.FunctionsTable, NameIdGen] r) =>
Symbol -> Symbol ->
Internal.ConstructorDef -> Internal.ConstructorDef ->
Sem r ConstructorInfo Sem r ConstructorInfo
@ -226,7 +226,7 @@ goConstructor sym ctor = do
goMutualBlock :: goMutualBlock ::
forall r. forall r.
(Members '[InfoTableBuilder, Reader InternalTyped.TypesTable, State InternalTyped.FunctionsTable, Reader Internal.InfoTable] r) => (Members '[InfoTableBuilder, Reader InternalTyped.TypesTable, State InternalTyped.FunctionsTable, Reader Internal.InfoTable, NameIdGen] r) =>
Internal.MutualBlock -> Internal.MutualBlock ->
Sem r () Sem r ()
goMutualBlock (Internal.MutualBlock m) = preMutual m >>= goMutual goMutualBlock (Internal.MutualBlock m) = preMutual m >>= goMutual
@ -265,7 +265,7 @@ goMutualBlock (Internal.MutualBlock m) = preMutual m >>= goMutual
preFunctionDef :: preFunctionDef ::
forall r. forall r.
(Members '[InfoTableBuilder, Reader Internal.InfoTable, Reader InternalTyped.TypesTable, State InternalTyped.FunctionsTable] r) => (Members '[InfoTableBuilder, Reader Internal.InfoTable, Reader InternalTyped.TypesTable, State InternalTyped.FunctionsTable, NameIdGen] r) =>
Internal.FunctionDef -> Internal.FunctionDef ->
Sem r PreFunctionDef Sem r PreFunctionDef
preFunctionDef f = do preFunctionDef f = do
@ -334,7 +334,7 @@ preFunctionDef f = do
goFunctionDef :: goFunctionDef ::
forall r. forall r.
(Members '[InfoTableBuilder, Reader Internal.InfoTable, Reader InternalTyped.TypesTable, State InternalTyped.FunctionsTable] r) => (Members '[InfoTableBuilder, Reader Internal.InfoTable, Reader InternalTyped.TypesTable, State InternalTyped.FunctionsTable, NameIdGen] r) =>
PreFunctionDef -> PreFunctionDef ->
Sem r () Sem r ()
goFunctionDef PreFunctionDef {..} = do goFunctionDef PreFunctionDef {..} = do
@ -353,12 +353,12 @@ goFunctionDef PreFunctionDef {..} = do
let (is, _) = unfoldLambdas node let (is, _) = unfoldLambdas node
setIdentArgs _preFunSym (map (^. lambdaLhsBinder) is) setIdentArgs _preFunSym (map (^. lambdaLhsBinder) is)
strongNormalizeHelper :: (Member (State InternalTyped.FunctionsTable) r) => Internal.Expression -> Sem r Internal.Expression strongNormalizeHelper :: (Members '[State InternalTyped.FunctionsTable, NameIdGen] r) => Internal.Expression -> Sem r Internal.Expression
strongNormalizeHelper ty = evalState InternalTyped.iniState (InternalTyped.strongNormalize' ty) strongNormalizeHelper ty = evalState InternalTyped.iniState (InternalTyped.strongNormalize' ty)
goType :: goType ::
forall r. forall r.
(Members '[InfoTableBuilder, Reader Internal.InfoTable, Reader InternalTyped.TypesTable, State InternalTyped.FunctionsTable, Reader IndexTable] r) => (Members '[InfoTableBuilder, Reader Internal.InfoTable, Reader InternalTyped.TypesTable, State InternalTyped.FunctionsTable, NameIdGen, Reader IndexTable] r) =>
Internal.Expression -> Internal.Expression ->
Sem r Type Sem r Type
goType ty = do goType ty = do
@ -368,7 +368,7 @@ goType ty = do
mkFunBody :: mkFunBody ::
forall r. forall r.
(Members '[InfoTableBuilder, Reader InternalTyped.TypesTable, State InternalTyped.FunctionsTable, Reader Internal.InfoTable, Reader IndexTable] r) => (Members '[InfoTableBuilder, Reader InternalTyped.TypesTable, State InternalTyped.FunctionsTable, Reader Internal.InfoTable, Reader IndexTable, NameIdGen] r) =>
Type -> -- converted type of the function Type -> -- converted type of the function
Internal.FunctionDef -> Internal.FunctionDef ->
Sem r Node Sem r Node
@ -380,7 +380,7 @@ mkFunBody ty f =
mkBody :: mkBody ::
forall r. forall r.
(Members '[InfoTableBuilder, Reader InternalTyped.TypesTable, State InternalTyped.FunctionsTable, Reader Internal.InfoTable, Reader IndexTable] r) => (Members '[InfoTableBuilder, Reader InternalTyped.TypesTable, State InternalTyped.FunctionsTable, Reader Internal.InfoTable, Reader IndexTable, NameIdGen] r) =>
Type -> -- type of the function Type -> -- type of the function
Location -> Location ->
NonEmpty ([Internal.PatternArg], Internal.Expression) -> NonEmpty ([Internal.PatternArg], Internal.Expression) ->
@ -467,7 +467,7 @@ mkBody ty loc clauses
goCase :: goCase ::
forall r. forall r.
(Members '[InfoTableBuilder, Reader InternalTyped.TypesTable, State InternalTyped.FunctionsTable, Reader Internal.InfoTable, Reader IndexTable] r) => (Members '[InfoTableBuilder, Reader InternalTyped.TypesTable, State InternalTyped.FunctionsTable, Reader Internal.InfoTable, Reader IndexTable, NameIdGen] r) =>
Internal.Case -> Internal.Case ->
Sem r Node Sem r Node
goCase c = do goCase c = do
@ -501,7 +501,7 @@ goCase c = do
goLambda :: goLambda ::
forall r. forall r.
(Members '[InfoTableBuilder, Reader InternalTyped.TypesTable, State InternalTyped.FunctionsTable, Reader Internal.InfoTable, Reader IndexTable] r) => (Members '[InfoTableBuilder, Reader InternalTyped.TypesTable, State InternalTyped.FunctionsTable, Reader Internal.InfoTable, Reader IndexTable, NameIdGen] r) =>
Internal.Lambda -> Internal.Lambda ->
Sem r Node Sem r Node
goLambda l = do goLambda l = do
@ -510,7 +510,7 @@ goLambda l = do
goLet :: goLet ::
forall r. forall r.
(Members '[InfoTableBuilder, Reader InternalTyped.TypesTable, State InternalTyped.FunctionsTable, Reader Internal.InfoTable, Reader IndexTable] r) => (Members '[InfoTableBuilder, Reader InternalTyped.TypesTable, State InternalTyped.FunctionsTable, Reader Internal.InfoTable, Reader IndexTable, NameIdGen] r) =>
Internal.Let -> Internal.Let ->
Sem r Node Sem r Node
goLet l = goClauses (toList (l ^. Internal.letClauses)) goLet l = goClauses (toList (l ^. Internal.letClauses))
@ -548,7 +548,7 @@ goLet l = goClauses (toList (l ^. Internal.letClauses))
goAxiomInductive :: goAxiomInductive ::
forall r. forall r.
(Members '[InfoTableBuilder, Reader InternalTyped.TypesTable, State InternalTyped.FunctionsTable, Reader Internal.InfoTable] r) => (Members '[InfoTableBuilder, Reader InternalTyped.TypesTable, State InternalTyped.FunctionsTable, Reader Internal.InfoTable, NameIdGen] r) =>
Internal.AxiomDef -> Internal.AxiomDef ->
Sem r () Sem r ()
goAxiomInductive a = whenJust (a ^. Internal.axiomBuiltin) builtinInductive goAxiomInductive a = whenJust (a ^. Internal.axiomBuiltin) builtinInductive
@ -598,7 +598,7 @@ fromTopIndex = runReader initIndexTable
goAxiomDef :: goAxiomDef ::
forall r. forall r.
(Members '[InfoTableBuilder, Reader InternalTyped.TypesTable, State InternalTyped.FunctionsTable, Reader Internal.InfoTable] r) => (Members '[InfoTableBuilder, Reader InternalTyped.TypesTable, State InternalTyped.FunctionsTable, Reader Internal.InfoTable, NameIdGen] r) =>
Internal.AxiomDef -> Internal.AxiomDef ->
Sem r () Sem r ()
goAxiomDef a = maybe goAxiomNotBuiltin builtinBody (a ^. Internal.axiomBuiltin) goAxiomDef a = maybe goAxiomNotBuiltin builtinBody (a ^. Internal.axiomBuiltin)
@ -701,7 +701,7 @@ goAxiomDef a = maybe goAxiomNotBuiltin builtinBody (a ^. Internal.axiomBuiltin)
fromPatternArg :: fromPatternArg ::
forall r. forall r.
(Members '[InfoTableBuilder, Reader InternalTyped.TypesTable, State InternalTyped.FunctionsTable, Reader Internal.InfoTable, State IndexTable] r) => (Members '[InfoTableBuilder, Reader InternalTyped.TypesTable, State InternalTyped.FunctionsTable, Reader Internal.InfoTable, State IndexTable, NameIdGen] r) =>
Internal.PatternArg -> Internal.PatternArg ->
Sem r Pattern Sem r Pattern
fromPatternArg pa = case pa ^. Internal.patternArgName of fromPatternArg pa = case pa ^. Internal.patternArgName of
@ -785,7 +785,7 @@ fromPatternArg pa = case pa ^. Internal.patternArgName of
goPatternArgs :: goPatternArgs ::
forall r. forall r.
(Members '[InfoTableBuilder, Reader InternalTyped.TypesTable, State InternalTyped.FunctionsTable, Reader Internal.InfoTable, Reader IndexTable] r) => (Members '[InfoTableBuilder, Reader InternalTyped.TypesTable, State InternalTyped.FunctionsTable, Reader Internal.InfoTable, Reader IndexTable, NameIdGen] r) =>
Level -> -- the level of the first binder for the matched value Level -> -- the level of the first binder for the matched value
Internal.Expression -> Internal.Expression ->
[Internal.PatternArg] -> [Internal.PatternArg] ->
@ -918,7 +918,7 @@ goIden i = do
goExpression :: goExpression ::
forall r. forall r.
(Members '[InfoTableBuilder, Reader InternalTyped.TypesTable, State InternalTyped.FunctionsTable, Reader Internal.InfoTable, Reader IndexTable] r) => (Members '[InfoTableBuilder, Reader InternalTyped.TypesTable, State InternalTyped.FunctionsTable, Reader Internal.InfoTable, Reader IndexTable, NameIdGen] r) =>
Internal.Expression -> Internal.Expression ->
Sem r Node Sem r Node
goExpression = \case goExpression = \case
@ -938,7 +938,7 @@ goExpression = \case
goFunction :: goFunction ::
forall r. forall r.
(Members '[InfoTableBuilder, Reader InternalTyped.TypesTable, State InternalTyped.FunctionsTable, Reader Internal.InfoTable, Reader IndexTable] r) => (Members '[InfoTableBuilder, Reader InternalTyped.TypesTable, State InternalTyped.FunctionsTable, Reader Internal.InfoTable, Reader IndexTable, NameIdGen] r) =>
([Internal.FunctionParameter], Internal.Expression) -> ([Internal.FunctionParameter], Internal.Expression) ->
Sem r Node Sem r Node
goFunction (params, returnTypeExpr) = go params goFunction (params, returnTypeExpr) = go params
@ -961,7 +961,7 @@ goFunction (params, returnTypeExpr) = go params
goSimpleLambda :: goSimpleLambda ::
forall r. forall r.
(Members '[InfoTableBuilder, Reader InternalTyped.TypesTable, State InternalTyped.FunctionsTable, Reader Internal.InfoTable, Reader IndexTable] r) => (Members '[InfoTableBuilder, Reader InternalTyped.TypesTable, State InternalTyped.FunctionsTable, Reader Internal.InfoTable, Reader IndexTable, NameIdGen] r) =>
Internal.SimpleLambda -> Internal.SimpleLambda ->
Sem r Node Sem r Node
goSimpleLambda l = do goSimpleLambda l = do
@ -973,7 +973,7 @@ goSimpleLambda l = do
goApplication :: goApplication ::
forall r. forall r.
(Members '[InfoTableBuilder, Reader InternalTyped.TypesTable, State InternalTyped.FunctionsTable, Reader Internal.InfoTable, Reader IndexTable] r) => (Members '[InfoTableBuilder, Reader InternalTyped.TypesTable, State InternalTyped.FunctionsTable, Reader Internal.InfoTable, Reader IndexTable, NameIdGen] r) =>
Internal.Application -> Internal.Application ->
Sem r Node Sem r Node
goApplication a = do goApplication a = do

View File

@ -4,6 +4,7 @@ import Data.Generics.Uniplate.Data hiding (holes)
import Data.HashMap.Strict qualified as HashMap import Data.HashMap.Strict qualified as HashMap
import Data.HashSet qualified as HashSet import Data.HashSet qualified as HashSet
import Juvix.Compiler.Internal.Data.LocalVars import Juvix.Compiler.Internal.Data.LocalVars
import Juvix.Compiler.Internal.Extra.Clonable
import Juvix.Compiler.Internal.Language import Juvix.Compiler.Internal.Language
import Juvix.Prelude import Juvix.Prelude
@ -153,14 +154,14 @@ holes = leafExpressions . _ExpressionHole
hasHoles :: (HasExpressions a) => a -> Bool hasHoles :: (HasExpressions a) => a -> Bool
hasHoles = has holes hasHoles = has holes
subsHoles :: (HasExpressions a) => HashMap Hole Expression -> a -> a subsHoles :: forall a r. (HasExpressions a, Member NameIdGen r) => HashMap Hole Expression -> a -> Sem r a
subsHoles s = over leafExpressions helper subsHoles s = leafExpressions helper
where where
helper :: Expression -> Expression helper :: Expression -> Sem r Expression
helper e = case e of helper e = case e of
ExpressionHole h -> fromMaybe e (s ^. at h) ExpressionHole h -> maybe (clone e) return (s ^. at h)
ExpressionInstanceHole h -> fromMaybe e (s ^. at h) ExpressionInstanceHole h -> maybe (clone e) return (s ^. at h)
_ -> e _ -> return e
instance HasExpressions Example where instance HasExpressions Example where
leafExpressions f = traverseOf exampleExpression (leafExpressions f) leafExpressions f = traverseOf exampleExpression (leafExpressions f)
@ -246,7 +247,7 @@ instance HasExpressions ConstructorDef where
_inductiveConstructorPragmas _inductiveConstructorPragmas
} }
substituteIndParams :: [(InductiveParameter, Expression)] -> Expression -> Expression substituteIndParams :: forall r. (Member NameIdGen r) => [(InductiveParameter, Expression)] -> Expression -> Sem r Expression
substituteIndParams = substitutionE . HashMap.fromList . map (first (^. inductiveParamName)) substituteIndParams = substitutionE . HashMap.fromList . map (first (^. inductiveParamName))
typeAbstraction :: IsImplicit -> Name -> FunctionParameter typeAbstraction :: IsImplicit -> Name -> FunctionParameter
@ -275,41 +276,6 @@ renameKind k l = HashMap.fromList [(n, toExpression (set nameKind k n)) | n <- l
renameToSubsE :: Rename -> Subs renameToSubsE :: Rename -> Subs
renameToSubsE = fmap (ExpressionIden . IdenVar) renameToSubsE = fmap (ExpressionIden . IdenVar)
class HasBinders a where
bindersTraversal :: Traversal' a VarName
instance HasBinders PatternArg where
bindersTraversal f (PatternArg i n p) = PatternArg i <$> traverse f n <*> bindersTraversal f p
instance HasBinders Pattern where
bindersTraversal f p = case p of
PatternVariable v -> PatternVariable <$> f v
PatternWildcardConstructor {} -> pure p
PatternConstructorApp a -> PatternConstructorApp <$> goApp f a
where
goApp :: Traversal' ConstructorApp VarName
goApp g = traverseOf constrAppParameters (traverse (bindersTraversal g))
instance HasBinders FunctionParameter where
bindersTraversal = paramName . _Just
instance HasBinders InductiveParameter where
bindersTraversal = inductiveParamName
instance HasBinders SimpleBinder where
bindersTraversal = sbinderVar
instance HasBinders FunctionDef where
bindersTraversal = funDefName
instance HasBinders MutualBlockLet where
bindersTraversal = mutualLet . each . bindersTraversal
instance HasBinders LetClause where
bindersTraversal f = \case
LetFunDef fun -> LetFunDef <$> bindersTraversal f fun
LetMutualBlock b -> LetMutualBlock <$> bindersTraversal f b
inductiveTypeVarsAssoc :: (Foldable f) => InductiveDef -> f a -> HashMap VarName a inductiveTypeVarsAssoc :: (Foldable f) => InductiveDef -> f a -> HashMap VarName a
inductiveTypeVarsAssoc def l inductiveTypeVarsAssoc def l
| length vars < n = impossible | length vars < n = impossible
@ -319,26 +285,26 @@ inductiveTypeVarsAssoc def l
vars :: [VarName] vars :: [VarName]
vars = def ^.. inductiveParameters . each . inductiveParamName vars = def ^.. inductiveParameters . each . inductiveParamName
substitutionApp :: (Maybe Name, Expression) -> Expression -> Expression substitutionApp :: forall r. (Member NameIdGen r) => (Maybe Name, Expression) -> Expression -> Sem r Expression
substitutionApp (mv, ty) = case mv of substitutionApp (mv, ty) = case mv of
Nothing -> id Nothing -> return
Just v -> substitutionE (HashMap.singleton v ty) Just v -> substitutionE (HashMap.singleton v ty)
localsToSubsE :: LocalVars -> Subs localsToSubsE :: LocalVars -> Subs
localsToSubsE l = ExpressionIden . IdenVar <$> l ^. localTyMap localsToSubsE l = ExpressionIden . IdenVar <$> l ^. localTyMap
substitutionE :: Subs -> Expression -> Expression substitutionE :: forall r. (Member NameIdGen r) => Subs -> Expression -> Sem r Expression
substitutionE m = over leafExpressions goLeaf substitutionE m = leafExpressions goLeaf
where where
goLeaf :: Expression -> Expression goLeaf :: Expression -> Sem r Expression
goLeaf = \case goLeaf = \case
ExpressionIden i -> goIden i ExpressionIden i -> goIden i
e -> e e -> return e
goIden :: Iden -> Expression goIden :: Iden -> Sem r Expression
goIden i = case i of goIden i = case i of
IdenVar v IdenVar v
| Just e <- HashMap.lookup v m -> e | Just e <- HashMap.lookup v m -> clone e
_ -> ExpressionIden i _ -> return $ ExpressionIden i
smallUniverseE :: Interval -> Expression smallUniverseE :: Interval -> Expression
smallUniverseE = ExpressionUniverse . SmallUniverse smallUniverseE = ExpressionUniverse . SmallUniverse
@ -742,14 +708,6 @@ allTypeSignatures a =
<> [f ^. axiomType | f@AxiomDef {} <- universeBi a] <> [f ^. axiomType | f@AxiomDef {} <- universeBi a]
<> [f ^. inductiveType | f@InductiveDef {} <- universeBi a] <> [f ^. inductiveType | f@InductiveDef {} <- universeBi a]
idenName :: Lens' Iden Name
idenName f = \case
IdenFunction g -> IdenFunction <$> f g
IdenConstructor c -> IdenConstructor <$> f c
IdenVar v -> IdenVar <$> f v
IdenInductive i -> IdenInductive <$> f i
IdenAxiom a -> IdenAxiom <$> f a
explicitPatternArg :: Pattern -> PatternArg explicitPatternArg :: Pattern -> PatternArg
explicitPatternArg _patternArgPattern = explicitPatternArg _patternArgPattern =
PatternArg PatternArg

View File

@ -0,0 +1,39 @@
module Juvix.Compiler.Internal.Extra.Binders where
import Juvix.Compiler.Internal.Language
import Juvix.Prelude
class HasBinders a where
bindersTraversal :: Traversal' a VarName
instance HasBinders PatternArg where
bindersTraversal f (PatternArg i n p) = PatternArg i <$> traverse f n <*> bindersTraversal f p
instance HasBinders Pattern where
bindersTraversal f p = case p of
PatternVariable v -> PatternVariable <$> f v
PatternWildcardConstructor {} -> pure p
PatternConstructorApp a -> PatternConstructorApp <$> goApp f a
where
goApp :: Traversal' ConstructorApp VarName
goApp g = traverseOf constrAppParameters (traverse (bindersTraversal g))
instance HasBinders FunctionParameter where
bindersTraversal = paramName . _Just
instance HasBinders InductiveParameter where
bindersTraversal = inductiveParamName
instance HasBinders SimpleBinder where
bindersTraversal = sbinderVar
instance HasBinders FunctionDef where
bindersTraversal = funDefName
instance HasBinders MutualBlockLet where
bindersTraversal = mutualLet . each . bindersTraversal
instance HasBinders LetClause where
bindersTraversal f = \case
LetFunDef fun -> LetFunDef <$> bindersTraversal f fun
LetMutualBlock b -> LetMutualBlock <$> bindersTraversal f b

View File

@ -5,24 +5,20 @@ module Juvix.Compiler.Internal.Extra.Clonable
where where
import Data.HashMap.Strict qualified as HashMap import Data.HashMap.Strict qualified as HashMap
import Juvix.Compiler.Internal.Extra.Base import Juvix.Compiler.Internal.Extra.Binders
import Juvix.Compiler.Internal.Language import Juvix.Compiler.Internal.Language
import Juvix.Prelude import Juvix.Prelude
type FreshBindersContext = HashMap NameId NameId type FreshBindersContext = HashMap NameId NameId
type HolesState = HashMap Hole Hole
clone :: (Clonable a, Members '[NameIdGen] r) => a -> Sem r a clone :: (Clonable a, Members '[NameIdGen] r) => a -> Sem r a
clone = evalState iniState . runReader iniCtx . freshNameIds clone = runReader iniCtx . freshNameIds
where where
iniState :: HolesState
iniState = mempty
iniCtx :: FreshBindersContext iniCtx :: FreshBindersContext
iniCtx = mempty iniCtx = mempty
class Clonable a where class Clonable a where
freshNameIds :: (Members '[State HolesState, Reader FreshBindersContext, NameIdGen] r) => a -> Sem r a freshNameIds :: (Members '[Reader FreshBindersContext, NameIdGen] r) => a -> Sem r a
instance Clonable Name where instance Clonable Name where
freshNameIds n = do freshNameIds n = do
@ -52,15 +48,7 @@ instance Clonable Literal where
freshNameIds = return freshNameIds = return
instance Clonable Hole where instance Clonable Hole where
freshNameIds h = do freshNameIds = return
tbl <- get @HolesState
case tbl ^. at h of
Just h' -> return h'
Nothing -> do
uid' <- freshNameId
let h' = set holeId uid' h
modify' @HolesState (set (at h) (Just h'))
return h'
instance Clonable SmallUniverse where instance Clonable SmallUniverse where
freshNameIds = return freshNameIds = return
@ -73,7 +61,7 @@ instance (Clonable a) => Clonable (Maybe a) where
underBinder :: underBinder ::
forall r a binding. forall r a binding.
(HasBinders binding, Members '[State HolesState, Reader FreshBindersContext, NameIdGen] r) => (HasBinders binding, Members '[Reader FreshBindersContext, NameIdGen] r) =>
binding -> binding ->
(binding -> Sem r a) -> (binding -> Sem r a) ->
Sem r a Sem r a
@ -81,16 +69,16 @@ underBinder p f = underBinders [p] (f . headDef impossible)
underBindersNonEmpty :: underBindersNonEmpty ::
forall r a binding. forall r a binding.
(HasBinders binding, Members '[State HolesState, Reader FreshBindersContext, NameIdGen] r) => (HasBinders binding, Members '[Reader FreshBindersContext, NameIdGen] r) =>
NonEmpty binding -> NonEmpty binding ->
(NonEmpty binding -> Sem r a) -> (NonEmpty binding -> Sem r a) ->
Sem r a Sem r a
underBindersNonEmpty p f = underBinders (toList p) (f . nonEmpty') underBindersNonEmpty p f = underBinders (toList p) (f . nonEmpty')
underClonableBindersNonEmpty :: forall r a binding. (Clonable binding, HasBinders binding, Members '[State HolesState, Reader FreshBindersContext, NameIdGen] r) => NonEmpty binding -> (NonEmpty binding -> Sem r a) -> Sem r a underClonableBindersNonEmpty :: forall r a binding. (Clonable binding, HasBinders binding, Members '[Reader FreshBindersContext, NameIdGen] r) => NonEmpty binding -> (NonEmpty binding -> Sem r a) -> Sem r a
underClonableBindersNonEmpty ps0 f = underClonableBinders (toList ps0) (f . nonEmpty') underClonableBindersNonEmpty ps0 f = underClonableBinders (toList ps0) (f . nonEmpty')
underClonableBinders :: forall r a binding. (Clonable binding, HasBinders binding, Members '[State HolesState, Reader FreshBindersContext, NameIdGen] r) => [binding] -> ([binding] -> Sem r a) -> Sem r a underClonableBinders :: forall r a binding. (Clonable binding, HasBinders binding, Members '[Reader FreshBindersContext, NameIdGen] r) => [binding] -> ([binding] -> Sem r a) -> Sem r a
underClonableBinders binders f = do underClonableBinders binders f = do
ctx <- ask @FreshBindersContext ctx <- ask @FreshBindersContext
let bindersIds :: [NameId] = binders ^.. each . bindersTraversal . nameId let bindersIds :: [NameId] = binders ^.. each . bindersTraversal . nameId
@ -100,7 +88,7 @@ underClonableBinders binders f = do
binders' <- freshNameIds binders binders' <- freshNameIds binders
f binders' f binders'
underBinders :: forall r a binding. (HasBinders binding, Members '[State HolesState, Reader FreshBindersContext, NameIdGen] r) => [binding] -> ([binding] -> Sem r a) -> Sem r a underBinders :: forall r a binding. (HasBinders binding, Members '[Reader FreshBindersContext, NameIdGen] r) => [binding] -> ([binding] -> Sem r a) -> Sem r a
underBinders ps f = do underBinders ps f = do
ctx <- ask @FreshBindersContext ctx <- ask @FreshBindersContext
(ctx', ps') <- runState ctx (mapM goBinders ps) (ctx', ps') <- runState ctx (mapM goBinders ps)
@ -169,7 +157,7 @@ instance Clonable LetClause where
LetMutualBlock m -> LetMutualBlock <$> freshNameIds m LetMutualBlock m -> LetMutualBlock <$> freshNameIds m
instance Clonable Let where instance Clonable Let where
freshNameIds :: (Members '[State HolesState, Reader FreshBindersContext, NameIdGen] r) => Let -> Sem r Let freshNameIds :: (Members '[Reader FreshBindersContext, NameIdGen] r) => Let -> Sem r Let
freshNameIds Let {..} = do freshNameIds Let {..} = do
underClonableBindersNonEmpty _letClauses $ \clauses' -> do underClonableBindersNonEmpty _letClauses $ \clauses' -> do
e' <- freshNameIds _letExpression e' <- freshNameIds _letExpression
@ -220,7 +208,7 @@ instance Clonable Lambda where
} }
instance Clonable Expression where instance Clonable Expression where
freshNameIds :: (Members '[State HolesState, Reader FreshBindersContext, NameIdGen] r) => Expression -> Sem r Expression freshNameIds :: (Members '[Reader FreshBindersContext, NameIdGen] r) => Expression -> Sem r Expression
freshNameIds = \case freshNameIds = \case
ExpressionIden i -> ExpressionIden <$> freshNameIds i ExpressionIden i -> ExpressionIden <$> freshNameIds i
ExpressionApplication a -> ExpressionApplication <$> freshNameIds a ExpressionApplication a -> ExpressionApplication <$> freshNameIds a
@ -244,7 +232,7 @@ instance Clonable ArgInfo where
} }
instance Clonable FunctionDef where instance Clonable FunctionDef where
freshNameIds :: (Members '[State HolesState, Reader FreshBindersContext, NameIdGen] r) => FunctionDef -> Sem r FunctionDef freshNameIds :: (Members '[Reader FreshBindersContext, NameIdGen] r) => FunctionDef -> Sem r FunctionDef
freshNameIds fun@FunctionDef {..} = do freshNameIds fun@FunctionDef {..} = do
ty' <- freshNameIds _funDefType ty' <- freshNameIds _funDefType
underBinder fun $ \fun' -> do underBinder fun $ \fun' -> do

View File

@ -530,3 +530,11 @@ instance HasLoc ConstructorApp where
case last <$> nonEmpty _constrAppParameters of case last <$> nonEmpty _constrAppParameters of
Just p -> getLoc _constrAppConstructor <> getLoc p Just p -> getLoc _constrAppConstructor <> getLoc p
Nothing -> getLoc _constrAppConstructor Nothing -> getLoc _constrAppConstructor
idenName :: Lens' Iden Name
idenName f = \case
IdenFunction g -> IdenFunction <$> f g
IdenConstructor c -> IdenConstructor <$> f c
IdenVar v -> IdenVar <$> f v
IdenInductive i -> IdenInductive <$> f i
IdenAxiom a -> IdenAxiom <$> f a

View File

@ -784,7 +784,7 @@ goExpression = \case
_namedAppArgs = nonEmpty' $ createArgumentBlocks (sig ^. nameSignatureArgs) _namedAppArgs = nonEmpty' $ createArgumentBlocks (sig ^. nameSignatureArgs)
} }
e <- goNamedApplication napp' e <- goNamedApplication napp'
let expr = expr <-
Internal.substitutionE updateKind Internal.substitutionE updateKind
. Internal.ExpressionLet . Internal.ExpressionLet
$ Internal.Let $ Internal.Let
@ -849,7 +849,7 @@ goExpression = \case
argNames :: NonEmpty Internal.ApplicationArg = mkAppArg <$> a ^. dnamedAppArgs argNames :: NonEmpty Internal.ApplicationArg = mkAppArg <$> a ^. dnamedAppArgs
app = Internal.foldApplication (Internal.toExpression fun) (toList argNames) app = Internal.foldApplication (Internal.toExpression fun) (toList argNames)
clauses <- mapM mkClause (a ^. dnamedAppArgs) clauses <- mapM mkClause (a ^. dnamedAppArgs)
let expr = expr <-
Internal.substitutionE updateKind $ Internal.substitutionE updateKind $
Internal.ExpressionLet Internal.ExpressionLet
Internal.Let Internal.Let

View File

@ -767,7 +767,7 @@ checkExpression hintArity expr = case expr of
} }
clauses :: NonEmpty Internal.LetClause <- nonEmpty' . Internal.mkLetClauses <$> mapM mkClause args' clauses :: NonEmpty Internal.LetClause <- nonEmpty' . Internal.mkLetClauses <$> mapM mkClause args'
let app = foldApplication (toExpression fun0) (map mkAppArg namedArgs) let app = foldApplication (toExpression fun0) (map mkAppArg namedArgs)
letexpr = letexpr <-
Internal.substitutionE (renameKind KNameFunction (map (^. insertedArgName) namedArgs)) $ Internal.substitutionE (renameKind KNameFunction (map (^. insertedArgName) namedArgs)) $
ExpressionLet ExpressionLet
Let Let

View File

@ -257,7 +257,7 @@ checkDefType ty = checkIsType loc ty
checkInstanceType :: checkInstanceType ::
forall r. forall r.
(Members '[Error TypeCheckerError, Reader InfoTable, Inference] r) => (Members '[Error TypeCheckerError, Reader InfoTable, Inference, NameIdGen] r) =>
FunctionDef -> FunctionDef ->
Sem r () Sem r ()
checkInstanceType FunctionDef {..} = case mi of checkInstanceType FunctionDef {..} = case mi of
@ -401,7 +401,7 @@ resolveInstanceHoles s = do
(hs, e) <- runOutputList s (hs, e) <- runOutputList s
ts <- mapM goResolve hs ts <- mapM goResolve hs
let subs = HashMap.fromList (zipExact (map (^. typedHoleHole) hs) ts) let subs = HashMap.fromList (zipExact (map (^. typedHoleHole) hs) ts)
return $ subsHoles subs e subsHoles subs e
where where
goResolve :: TypedHole -> Sem r Expression goResolve :: TypedHole -> Sem r Expression
goResolve h@TypedHole {..} = do goResolve h@TypedHole {..} = do
@ -494,7 +494,7 @@ checkClause clauseType clausePats body = do
locals0 <- ask locals0 <- ask
(localsPats, (checkedPatterns, bodyType)) <- helper clausePats clauseType (localsPats, (checkedPatterns, bodyType)) <- helper clausePats clauseType
let locals' = locals0 <> localsPats let locals' = locals0 <> localsPats
bodyTy' = substitutionE (localsToSubsE locals') bodyType bodyTy' <- substitutionE (localsToSubsE locals') bodyType
checkedBody <- local (const locals') (checkExpression bodyTy' body) checkedBody <- local (const locals') (checkExpression bodyTy' body)
return (checkedPatterns, checkedBody) return (checkedPatterns, checkedBody)
where where
@ -559,8 +559,8 @@ checkPattern = go
go argTy patArg = do go argTy patArg = do
matchIsImplicit (argTy ^. paramImplicit) patArg matchIsImplicit (argTy ^. paramImplicit) patArg
tyVarMap <- fmap (ExpressionIden . IdenVar) . (^. localTyMap) <$> get tyVarMap <- fmap (ExpressionIden . IdenVar) . (^. localTyMap) <$> get
let ty = substitutionE tyVarMap (argTy ^. paramType) ty <- substitutionE tyVarMap (argTy ^. paramType)
pat = patArg ^. patternArgPattern let pat = patArg ^. patternArgPattern
name = patArg ^. patternArgName name = patArg ^. patternArgName
whenJust name (\n -> addVar n ty argTy) whenJust name (\n -> addVar n ty argTy)
pat' <- case pat of pat' <- case pat of
@ -618,8 +618,8 @@ checkPattern = go
goConstr :: Iden -> ConstructorApp -> [(InductiveParameter, Expression)] -> Sem r ConstructorApp goConstr :: Iden -> ConstructorApp -> [(InductiveParameter, Expression)] -> Sem r ConstructorApp
goConstr inductivename app@(ConstructorApp c ps _) ctx = do goConstr inductivename app@(ConstructorApp c ps _) ctx = do
(_, psTys) <- constructorArgTypes <$> lookupConstructor c (_, psTys) <- constructorArgTypes <$> lookupConstructor c
let psTys' = map (substituteIndParams ctx) psTys psTys' <- mapM (substituteIndParams ctx) psTys
expectedNum = length psTys let expectedNum = length psTys
w = map unnamedParameter psTys' w = map unnamedParameter psTys'
when (expectedNum /= length ps) (throw (appErr app expectedNum)) when (expectedNum /= length ps) (throw (appErr app expectedNum))
pis <- zipWithM go w ps pis <- zipWithM go w ps
@ -912,6 +912,7 @@ inferExpression' hint e = case e of
<> ppTrace (Application l r iapp) <> ppTrace (Application l r iapp)
) )
) )
ty <- substitutionApp (paraName, r') funR
return return
TypedExpression TypedExpression
{ _typedExpression = { _typedExpression =
@ -921,7 +922,7 @@ inferExpression' hint e = case e of
_appRight = r', _appRight = r',
_appImplicit = iapp _appImplicit = iapp
}, },
_typedType = substitutionApp (paraName, r') funR _typedType = ty
} }
ExpressionHole h -> do ExpressionHole h -> do
fun <- ExpressionFunction <$> holeRefineToFunction h fun <- ExpressionFunction <$> holeRefineToFunction h

View File

@ -125,7 +125,7 @@ queryMetavarFinal h = do
Just (ExpressionHole h') -> queryMetavarFinal h' Just (ExpressionHole h') -> queryMetavarFinal h'
_ -> return m _ -> return m
strongNormalize' :: forall r. (Members '[State FunctionsTable, State InferenceState] r) => Expression -> Sem r Expression strongNormalize' :: forall r. (Members '[State FunctionsTable, State InferenceState, NameIdGen] r) => Expression -> Sem r Expression
strongNormalize' = go strongNormalize' = go
where where
go :: Expression -> Sem r Expression go :: Expression -> Sem r Expression
@ -223,7 +223,8 @@ strongNormalize' = go
l' <- go l l' <- go l
case l' of case l' of
ExpressionSimpleLambda (SimpleLambda (SimpleBinder lamVar _) lamBody) -> do ExpressionSimpleLambda (SimpleLambda (SimpleBinder lamVar _) lamBody) -> do
go (substitutionE (HashMap.singleton lamVar r) lamBody) b' <- substitutionE (HashMap.singleton lamVar r) lamBody
go b'
_ -> do _ -> do
r' <- go r r' <- go r
return (ExpressionApplication (Application l' r' i)) return (ExpressionApplication (Application l' r' i))
@ -239,7 +240,7 @@ strongNormalize' = go
where where
i' = ExpressionIden i i' = ExpressionIden i
weakNormalize' :: forall r. (Members '[State FunctionsTable, State InferenceState] r) => Expression -> Sem r Expression weakNormalize' :: forall r. (Members '[State FunctionsTable, State InferenceState, NameIdGen] r) => Expression -> Sem r Expression
weakNormalize' = go weakNormalize' = go
where where
go :: Expression -> Sem r Expression go :: Expression -> Sem r Expression
@ -270,7 +271,8 @@ weakNormalize' = go
l' <- go l l' <- go l
case l' of case l' of
ExpressionSimpleLambda (SimpleLambda (SimpleBinder lamVar _) lamBody) -> do ExpressionSimpleLambda (SimpleLambda (SimpleBinder lamVar _) lamBody) -> do
go (substitutionE (HashMap.singleton lamVar r) lamBody) b' <- substitutionE (HashMap.singleton lamVar r) lamBody
go b'
_ -> return (ExpressionApplication (Application l' r i)) _ -> return (ExpressionApplication (Application l' r i))
goHole :: Hole -> Sem r Expression goHole :: Hole -> Sem r Expression
goHole h = do goHole h = do
@ -296,7 +298,7 @@ queryMetavar' h = do
Just (Refined e) -> return (Just e) Just (Refined e) -> return (Just e)
re :: re ::
(Members '[State FunctionsTable, Error TypeCheckerError] r) => (Members '[State FunctionsTable, Error TypeCheckerError, NameIdGen] r) =>
Sem (Inference ': r) a -> Sem (Inference ': r) a ->
Sem (State InferenceState ': r) a Sem (State InferenceState ': r) a
re = reinterpret $ \case re = reinterpret $ \case
@ -311,14 +313,14 @@ re = reinterpret $ \case
registerIdenType' i ty = modify (over inferenceIdens (HashMap.insert (i ^. nameId) ty)) registerIdenType' i ty = modify (over inferenceIdens (HashMap.insert (i ^. nameId) ty))
-- Supports alpha equivalence. -- Supports alpha equivalence.
matchTypes' :: (Members '[State InferenceState, State FunctionsTable, Error TypeCheckerError] r) => Expression -> Expression -> Sem r (Maybe MatchError) matchTypes' :: (Members '[State InferenceState, State FunctionsTable, Error TypeCheckerError, NameIdGen] r) => Expression -> Expression -> Sem r (Maybe MatchError)
matchTypes' ty = runReader ini . go ty matchTypes' ty = runReader ini . go ty
where where
ini :: HashMap VarName VarName ini :: HashMap VarName VarName
ini = mempty ini = mempty
go :: go ::
forall r. forall r.
(Members '[State InferenceState, Reader (HashMap VarName VarName), State FunctionsTable, Error TypeCheckerError] r) => (Members '[State InferenceState, Reader (HashMap VarName VarName), State FunctionsTable, Error TypeCheckerError, NameIdGen] r) =>
Expression -> Expression ->
Expression -> Expression ->
Sem r (Maybe MatchError) Sem r (Maybe MatchError)
@ -478,20 +480,20 @@ matchPatterns (PatternArg impl1 name1 pat1) (PatternArg impl2 name2 pat2) =
err = return False err = return False
runInferenceDefs :: runInferenceDefs ::
(Members '[Termination, HighlightBuilder, Error TypeCheckerError, State FunctionsTable, State TypesTable] r, HasExpressions funDef) => (Members '[Termination, HighlightBuilder, Error TypeCheckerError, State FunctionsTable, State TypesTable, NameIdGen] r, HasExpressions funDef) =>
Sem (Inference ': r) (NonEmpty funDef) -> Sem (Inference ': r) (NonEmpty funDef) ->
Sem r (NonEmpty funDef) Sem r (NonEmpty funDef)
runInferenceDefs a = do runInferenceDefs a = do
(finalState, expr) <- runState iniState (re a) (finalState, expr) <- runState iniState (re a)
(subs, idens) <- closeState finalState (subs, idens) <- closeState finalState
let idens' = subsHoles subs <$> idens idens' <- mapM (subsHoles subs) idens
stash' = map (subsHoles subs) (finalState ^. inferenceFunctionsStash) stash' <- mapM (subsHoles subs) (finalState ^. inferenceFunctionsStash)
forM_ stash' registerFunctionDef forM_ stash' registerFunctionDef
addIdens idens' addIdens idens'
return (subsHoles subs <$> expr) mapM (subsHoles subs) expr
runInferenceDef :: runInferenceDef ::
(Members '[Termination, HighlightBuilder, Error TypeCheckerError, State FunctionsTable, State TypesTable] r, HasExpressions funDef) => (Members '[Termination, HighlightBuilder, Error TypeCheckerError, State FunctionsTable, State TypesTable, NameIdGen] r, HasExpressions funDef) =>
Sem (Inference ': r) funDef -> Sem (Inference ': r) funDef ->
Sem r funDef Sem r funDef
runInferenceDef = fmap head . runInferenceDefs . fmap pure runInferenceDef = fmap head . runInferenceDefs . fmap pure
@ -510,14 +512,14 @@ addIdens idens = do
-- --
-- Throws an error if the return type is Type and it does not satisfy the -- Throws an error if the return type is Type and it does not satisfy the
-- above conditions. -- above conditions.
functionDefEval :: forall r'. (Members '[State FunctionsTable, Termination, Error TypeCheckerError] r') => FunctionDef -> Sem r' (Maybe Expression) functionDefEval :: forall r'. (Members '[State FunctionsTable, Termination, Error TypeCheckerError, NameIdGen] r') => FunctionDef -> Sem r' (Maybe Expression)
functionDefEval f = do functionDefEval f = do
(params :: [FunctionParameter], ret :: Expression) <- unfoldFunType <$> strongNorm (f ^. funDefType) (params :: [FunctionParameter], ret :: Expression) <- unfoldFunType <$> strongNorm (f ^. funDefType)
r <- runFail (goTop params (canBeUniverse ret)) r <- runFail (goTop params (canBeUniverse ret))
when (isNothing r && isUniverse ret) (throw (ErrUnsupportedTypeFunction (UnsupportedTypeFunction f))) when (isNothing r && isUniverse ret) (throw (ErrUnsupportedTypeFunction (UnsupportedTypeFunction f)))
return r return r
where where
strongNorm :: (Members '[State FunctionsTable] r) => Expression -> Sem r Expression strongNorm :: (Members '[State FunctionsTable, NameIdGen] r) => Expression -> Sem r Expression
strongNorm = evalState iniState . strongNormalize' strongNorm = evalState iniState . strongNormalize'
isUniverse :: Expression -> Bool isUniverse :: Expression -> Bool
@ -576,6 +578,6 @@ functionDefEval f = do
| Implicit <- p ^. patternArgIsImplicit -> fail | Implicit <- p ^. patternArgIsImplicit -> fail
| otherwise -> go ps >>= goPattern (p ^. patternArgPattern, ty) | otherwise -> go ps >>= goPattern (p ^. patternArgPattern, ty)
registerFunctionDef :: (Members '[State FunctionsTable, Error TypeCheckerError, Termination] r) => FunctionDef -> Sem r () registerFunctionDef :: (Members '[State FunctionsTable, Error TypeCheckerError, NameIdGen, Termination] r) => FunctionDef -> Sem r ()
registerFunctionDef f = whenJustM (functionDefEval f) $ \e -> registerFunctionDef f = whenJustM (functionDefEval f) $ \e ->
modify (over functionsTable (HashMap.insert (f ^. funDefName) e)) modify (over functionsTable (HashMap.insert (f ^. funDefName) e))

View File

@ -48,7 +48,7 @@ resolveTraitInstance TypedHole {..} = do
subsumingInstances :: subsumingInstances ::
forall r. forall r.
(Members '[Error TypeCheckerError, Inference] r) => (Members '[Error TypeCheckerError, Inference, NameIdGen] r) =>
InstanceTable -> InstanceTable ->
InstanceInfo -> InstanceInfo ->
Sem r [(InstanceInfo)] Sem r [(InstanceInfo)]
@ -62,29 +62,37 @@ subsumingInstances tab InstanceInfo {..} = do
-- Local functions -- Local functions
------------------------------------------------------------------------------------- -------------------------------------------------------------------------------------
substitutionI :: SubsI -> InstanceParam -> InstanceParam substitutionI :: (Member NameIdGen r) => SubsI -> InstanceParam -> Sem r InstanceParam
substitutionI subs p = case p of substitutionI subs p = case p of
InstanceParamVar {} -> p InstanceParamVar {} -> return p
InstanceParamApp InstanceApp {..} -> InstanceParamApp InstanceApp {..} -> do
args <- mapM (substitutionI subs) _instanceAppArgs
e <- substitutionE (subsIToE subs) _instanceAppExpression
return $
InstanceParamApp InstanceParamApp
InstanceApp InstanceApp
{ _instanceAppHead, { _instanceAppHead,
_instanceAppArgs = map (substitutionI subs) _instanceAppArgs, _instanceAppArgs = args,
_instanceAppExpression = substitutionE (subsIToE subs) _instanceAppExpression _instanceAppExpression = e
} }
InstanceParamFun InstanceFun {..} -> InstanceParamFun InstanceFun {..} -> do
l <- substitutionI subs _instanceFunLeft
r <- substitutionI subs _instanceFunRight
e <- substitutionE (subsIToE subs) _instanceFunExpression
return $
InstanceParamFun InstanceParamFun
InstanceFun InstanceFun
{ _instanceFunLeft = substitutionI subs _instanceFunLeft, { _instanceFunLeft = l,
_instanceFunRight = substitutionI subs _instanceFunRight, _instanceFunRight = r,
_instanceFunExpression = substitutionE (subsIToE subs) _instanceFunExpression _instanceFunExpression = e
} }
InstanceParamHole {} -> p InstanceParamHole {} -> return p
InstanceParamMeta v InstanceParamMeta v
| Just p' <- HashMap.lookup v subs -> | Just p' <- HashMap.lookup v subs ->
p' -- we don't need to clone here because `InstanceParam` doesn't have binders
return p'
| otherwise -> | otherwise ->
p return p
instanceFromTypedExpression' :: InfoTable -> TypedExpression -> Maybe InstanceInfo instanceFromTypedExpression' :: InfoTable -> TypedExpression -> Maybe InstanceInfo
instanceFromTypedExpression' tbl e = do instanceFromTypedExpression' tbl e = do
@ -155,7 +163,7 @@ expandArity loc subs params e = case params of
lookupInstance' :: lookupInstance' ::
forall r. forall r.
(Member Inference r) => (Members '[Inference, NameIdGen] r) =>
[Name] -> [Name] ->
Bool -> Bool ->
CoercionTable -> CoercionTable ->
@ -191,7 +199,7 @@ lookupInstance' visited canFillHoles ctab tab name params
and <$> sequence (zipWithExact goMatch _coercionInfoParams params) and <$> sequence (zipWithExact goMatch _coercionInfoParams params)
failUnless b failUnless b
let name' = _coercionInfoTarget ^. instanceAppHead let name' = _coercionInfoTarget ^. instanceAppHead
args' = map (substitutionI si) (_coercionInfoTarget ^. instanceAppArgs) args' <- mapM (substitutionI si) (_coercionInfoTarget ^. instanceAppArgs)
is <- lookupInstance' (name : visited) canFillHoles ctab tab name' args' is <- lookupInstance' (name : visited) canFillHoles ctab tab name' args'
return $ map (first3 ((ci, si) :)) is return $ map (first3 ((ci, si) :)) is
@ -238,7 +246,7 @@ lookupInstance' visited canFillHoles ctab tab name params
lookupInstance :: lookupInstance ::
forall r. forall r.
(Members '[Error TypeCheckerError, Inference] r) => (Members '[Error TypeCheckerError, Inference, NameIdGen] r) =>
CoercionTable -> CoercionTable ->
InstanceTable -> InstanceTable ->
Expression -> Expression ->

View File

@ -161,7 +161,8 @@ fromInternalImport :: (Members '[State Artifacts] r) => Internal.Import -> Sem r
fromInternalImport i = do fromInternalImport i = do
artiTable <- gets (^. artifactInternalTypedTable) artiTable <- gets (^. artifactInternalTypedTable)
let table = Internal.buildTable [i ^. Internal.importModule . Internal.moduleIxModule] <> artiTable let table = Internal.buildTable [i ^. Internal.importModule . Internal.moduleIxModule] <> artiTable
runReader table runNameIdGenArtifacts
. runReader table
. runCoreInfoTableBuilderArtifacts . runCoreInfoTableBuilderArtifacts
. runFunctionsTableArtifacts . runFunctionsTableArtifacts
. readerTypesTableArtifacts . readerTypesTableArtifacts
@ -173,7 +174,8 @@ fromInternalImport i = do
fromInternalExpression :: (Members '[State Artifacts] r) => Internal.Expression -> Sem r Core.Node fromInternalExpression :: (Members '[State Artifacts] r) => Internal.Expression -> Sem r Core.Node
fromInternalExpression exp = do fromInternalExpression exp = do
typedTable <- gets (^. artifactInternalTypedTable) typedTable <- gets (^. artifactInternalTypedTable)
runReader typedTable runNameIdGenArtifacts
. runReader typedTable
. tmpCoreInfoTableBuilderArtifacts . tmpCoreInfoTableBuilderArtifacts
. runFunctionsTableArtifacts . runFunctionsTableArtifacts
. readerTypesTableArtifacts . readerTypesTableArtifacts