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:
parent
5948a38a54
commit
473ed259a5
@ -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
|
||||||
|
@ -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
|
||||||
|
39
src/Juvix/Compiler/Internal/Extra/Binders.hs
Normal file
39
src/Juvix/Compiler/Internal/Extra/Binders.hs
Normal 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
|
@ -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
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
|
@ -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))
|
||||||
|
@ -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 ->
|
||||||
|
@ -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
|
||||||
|
Loading…
Reference in New Issue
Block a user