1
1
mirror of https://github.com/anoma/juvix.git synced 2024-12-12 04:43:18 +03:00

Add non-dependent default values to the new typechecking algorithm (#2516)

This pr adds default values (that don't depend on previous default
values) under the new `--new-typechecker` flag.
This commit is contained in:
Jan Mas Rovira 2023-11-23 11:42:58 +01:00 committed by GitHub
parent 1c1a5b7117
commit f610518449
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
7 changed files with 295 additions and 85 deletions

View File

@ -292,7 +292,7 @@ inductiveTypeVarsAssoc def l
vars :: [VarName] vars :: [VarName]
vars = def ^.. inductiveParameters . each . inductiveParamName vars = def ^.. inductiveParameters . each . inductiveParamName
substitutionApp :: forall r. (Member NameIdGen r) => (Maybe Name, Expression) -> Expression -> Sem r Expression substitutionApp :: forall r expr. (Member NameIdGen r, HasExpressions expr) => (Maybe Name, Expression) -> expr -> Sem r expr
substitutionApp (mv, ty) = case mv of substitutionApp (mv, ty) = case mv of
Nothing -> return Nothing -> return
Just v -> substitutionE (HashMap.singleton v ty) Just v -> substitutionE (HashMap.singleton v ty)
@ -300,7 +300,7 @@ substitutionApp (mv, ty) = case mv of
localsToSubsE :: LocalVars -> Subs localsToSubsE :: LocalVars -> Subs
localsToSubsE l = ExpressionIden . IdenVar <$> l ^. localTyMap localsToSubsE l = ExpressionIden . IdenVar <$> l ^. localTyMap
substitutionE :: forall r. (Member NameIdGen r) => Subs -> Expression -> Sem r Expression substitutionE :: forall r expr. (Member NameIdGen r, HasExpressions expr) => Subs -> expr -> Sem r expr
substitutionE m = leafExpressions goLeaf substitutionE m = leafExpressions goLeaf
where where
goLeaf :: Expression -> Sem r Expression goLeaf :: Expression -> Sem r Expression

View File

@ -331,6 +331,16 @@ instance PrettyCode Module where
instance PrettyCode Interval where instance PrettyCode Interval where
ppCode = return . annotate AnnCode . pretty ppCode = return . annotate AnnCode . pretty
instance PrettyCode New.ArgId where
ppCode a = case a ^. New.argIdName . unIrrelevant of
Nothing -> do
f' <- ppCode (a ^. New.argIdFunctionName)
return (ordinal (a ^. New.argIdIx) <+> "argument of" <+> f')
Just n -> do
n' <- ppCode n
loc' <- ppCode (getLoc n)
return (n' <+> "at" <+> loc')
instance PrettyCode New.ArityParameter where instance PrettyCode New.ArityParameter where
ppCode = return . pretty ppCode = return . pretty

View File

@ -9,6 +9,7 @@ where
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 Data.List.NonEmpty qualified as NonEmpty
import Juvix.Compiler.Builtins.Effect import Juvix.Compiler.Builtins.Effect
import Juvix.Compiler.Concrete.Data.Highlight.Input import Juvix.Compiler.Concrete.Data.Highlight.Input
import Juvix.Compiler.Internal.Data.Cast import Juvix.Compiler.Internal.Data.Cast
@ -33,13 +34,35 @@ import Juvix.Prelude hiding (fromEither)
type MCache = Cache ModuleIndex Module type MCache = Cache ModuleIndex Module
data FunctionDefault = FunctionDefault
{ _functionDefaultLeft :: FunctionParameter,
_functionDefaultDefault :: Maybe (ArgId, Expression),
_functionDefaultRight :: BuilderType
}
-- TODO better name
data BuilderType
= BuilderTypeNoDefaults Expression
| BuilderTypeDefaults FunctionDefault
data IsDefault
= ItIsDefault ArgId
| ItIsNotDefault
data AppBuilderArg = AppBuilderArg
{ _appBuilderArgIsDefault :: IsDefault,
_appBuilderArg :: ApplicationArg
}
data AppBuilder = AppBuilder data AppBuilder = AppBuilder
{ _appBuilder :: Expression, { _appBuilder :: Expression,
_appBuilderType :: Expression, _appBuilderType :: BuilderType,
_appBuilderArgs :: [ApplicationArg] _appBuilderArgs :: [AppBuilderArg]
} }
makeLenses ''AppBuilder makeLenses ''AppBuilder
makeLenses ''AppBuilderArg
makeLenses ''FunctionDefault
registerConstructor :: (Members '[HighlightBuilder, State TypesTable, Reader InfoTable] r) => ConstructorDef -> Sem r () registerConstructor :: (Members '[HighlightBuilder, State TypesTable, Reader InfoTable] r) => ConstructorDef -> Sem r ()
registerConstructor ctr = do registerConstructor ctr = do
@ -78,7 +101,7 @@ checkModuleNoCache ::
(Members '[HighlightBuilder, Reader EntryPoint, Reader InfoTable, Error TypeCheckerError, NameIdGen, State TypesTable, State FunctionsTable, Output Example, Builtins, MCache, Termination] r) => (Members '[HighlightBuilder, Reader EntryPoint, Reader InfoTable, Error TypeCheckerError, NameIdGen, State TypesTable, State FunctionsTable, Output Example, Builtins, MCache, Termination] r) =>
ModuleIndex -> ModuleIndex ->
Sem r Module Sem r Module
checkModuleNoCache (ModuleIndex Module {..}) = do checkModuleNoCache (ModuleIndex Module {..}) = runReader (mempty @InsertedArgsStack) $ do
_moduleBody' <- _moduleBody' <-
evalState (mempty :: NegativeTypeParameters) evalState (mempty :: NegativeTypeParameters)
. checkModuleBody . checkModuleBody
@ -93,7 +116,7 @@ checkModuleNoCache (ModuleIndex Module {..}) = do
} }
checkModuleBody :: checkModuleBody ::
(Members '[HighlightBuilder, Reader EntryPoint, State NegativeTypeParameters, Reader InfoTable, Error TypeCheckerError, NameIdGen, State TypesTable, State FunctionsTable, Output Example, Builtins, MCache, Termination] r) => (Members '[HighlightBuilder, Reader EntryPoint, State NegativeTypeParameters, Reader InfoTable, Error TypeCheckerError, NameIdGen, State TypesTable, State FunctionsTable, Output Example, Builtins, MCache, Termination, Reader InsertedArgsStack] r) =>
ModuleBody -> ModuleBody ->
Sem r ModuleBody Sem r ModuleBody
checkModuleBody ModuleBody {..} = do checkModuleBody ModuleBody {..} = do
@ -112,14 +135,14 @@ checkImport ::
checkImport = traverseOf importModule checkModuleIndex checkImport = traverseOf importModule checkModuleIndex
checkMutualBlock :: checkMutualBlock ::
(Members '[HighlightBuilder, Reader EntryPoint, State NegativeTypeParameters, Reader InfoTable, Error TypeCheckerError, NameIdGen, State TypesTable, State FunctionsTable, Output Example, Builtins, Termination] r) => (Members '[HighlightBuilder, Reader EntryPoint, State NegativeTypeParameters, Reader InfoTable, Error TypeCheckerError, NameIdGen, State TypesTable, State FunctionsTable, Output Example, Builtins, Termination, Reader InsertedArgsStack] r) =>
MutualBlock -> MutualBlock ->
Sem r MutualBlock Sem r MutualBlock
checkMutualBlock s = runReader emptyLocalVars (checkTopMutualBlock s) checkMutualBlock s = runReader emptyLocalVars (checkTopMutualBlock s)
checkInductiveDef :: checkInductiveDef ::
forall r. forall r.
(Members '[HighlightBuilder, Reader EntryPoint, Reader InfoTable, State FunctionsTable, Error TypeCheckerError, NameIdGen, State TypesTable, State NegativeTypeParameters, Output Example, Builtins, Termination, Output TypedHole, Output CastHole, Reader LocalVars] r) => (Members '[HighlightBuilder, Reader EntryPoint, Reader InfoTable, State FunctionsTable, Error TypeCheckerError, NameIdGen, State TypesTable, State NegativeTypeParameters, Output Example, Builtins, Termination, Output TypedHole, Output CastHole, Reader InsertedArgsStack, Reader LocalVars] r) =>
InductiveDef -> InductiveDef ->
Sem r InductiveDef Sem r InductiveDef
checkInductiveDef InductiveDef {..} = runInferenceDef $ do checkInductiveDef InductiveDef {..} = runInferenceDef $ do
@ -185,7 +208,7 @@ withEmptyVars :: Sem (Reader LocalVars ': r) a -> Sem r a
withEmptyVars = runReader emptyLocalVars withEmptyVars = runReader emptyLocalVars
checkTopMutualBlock :: checkTopMutualBlock ::
(Members '[HighlightBuilder, State NegativeTypeParameters, Reader EntryPoint, Reader LocalVars, Reader InfoTable, Error TypeCheckerError, NameIdGen, State TypesTable, State FunctionsTable, Output Example, Builtins, Termination] r) => (Members '[HighlightBuilder, State NegativeTypeParameters, Reader EntryPoint, Reader LocalVars, Reader InfoTable, Error TypeCheckerError, NameIdGen, State TypesTable, State FunctionsTable, Output Example, Builtins, Termination, Reader InsertedArgsStack] r) =>
MutualBlock -> MutualBlock ->
Sem r MutualBlock Sem r MutualBlock
checkTopMutualBlock (MutualBlock ds) = checkTopMutualBlock (MutualBlock ds) =
@ -193,7 +216,7 @@ checkTopMutualBlock (MutualBlock ds) =
resolveCastHoles :: resolveCastHoles ::
forall a r. forall a r.
(Members '[HighlightBuilder, Reader InfoTable, State FunctionsTable, Error TypeCheckerError, Builtins, NameIdGen, Inference, Output Example, Output TypedHole, State TypesTable, Termination] r) => (Members '[HighlightBuilder, Reader InfoTable, State FunctionsTable, Error TypeCheckerError, Builtins, NameIdGen, Inference, Output Example, Output TypedHole, State TypesTable, Termination, Reader InsertedArgsStack] r) =>
Sem (Output CastHole ': r) a -> Sem (Output CastHole ': r) a ->
Sem r a Sem r a
resolveCastHoles s = do resolveCastHoles s = do
@ -222,7 +245,7 @@ resolveCastHoles s = do
getNatTy = mkBuiltinInductive BuiltinNat getNatTy = mkBuiltinInductive BuiltinNat
checkMutualStatement :: checkMutualStatement ::
(Members '[HighlightBuilder, State NegativeTypeParameters, Reader EntryPoint, Inference, Reader LocalVars, Reader InfoTable, Error TypeCheckerError, NameIdGen, State TypesTable, State FunctionsTable, Output Example, Builtins, Termination] r) => (Members '[HighlightBuilder, State NegativeTypeParameters, Reader EntryPoint, Inference, Reader LocalVars, Reader InfoTable, Error TypeCheckerError, NameIdGen, State TypesTable, State FunctionsTable, Output Example, Builtins, Termination, Reader InsertedArgsStack] r) =>
MutualStatement -> MutualStatement ->
Sem r MutualStatement Sem r MutualStatement
checkMutualStatement = \case checkMutualStatement = \case
@ -250,7 +273,7 @@ unfoldFunType' e = do
checkFunctionDef :: checkFunctionDef ::
forall r. forall r.
(Members '[HighlightBuilder, Reader LocalVars, Reader InfoTable, Error TypeCheckerError, NameIdGen, State TypesTable, State FunctionsTable, Output Example, Builtins, Inference, Termination, Output TypedHole, Output CastHole] r) => (Members '[HighlightBuilder, Reader LocalVars, Reader InfoTable, Error TypeCheckerError, NameIdGen, State TypesTable, State FunctionsTable, Output Example, Builtins, Inference, Termination, Output TypedHole, Output CastHole, Reader InsertedArgsStack] r) =>
FunctionDef -> FunctionDef ->
Sem r FunctionDef Sem r FunctionDef
checkFunctionDef FunctionDef {..} = do checkFunctionDef FunctionDef {..} = do
@ -300,7 +323,7 @@ checkFunctionDef FunctionDef {..} = do
withLocalTypeMaybe (p ^. paramName) (p ^. paramType) (go rest) withLocalTypeMaybe (p ^. paramName) (p ^. paramType) (go rest)
checkIsType :: checkIsType ::
(Members '[HighlightBuilder, Reader InfoTable, State FunctionsTable, Error TypeCheckerError, NameIdGen, Reader LocalVars, Inference, Builtins, Output Example, State TypesTable, Termination, Output TypedHole, Output CastHole] r) => (Members '[HighlightBuilder, Reader InfoTable, State FunctionsTable, Error TypeCheckerError, NameIdGen, Reader LocalVars, Inference, Builtins, Output Example, State TypesTable, Termination, Output TypedHole, Output CastHole, Reader InsertedArgsStack] r) =>
Interval -> Interval ->
Expression -> Expression ->
Sem r Expression Sem r Expression
@ -308,7 +331,7 @@ checkIsType = checkExpression . smallUniverseE
checkDefType :: checkDefType ::
forall r. forall r.
(Members '[HighlightBuilder, Reader InfoTable, State FunctionsTable, Error TypeCheckerError, NameIdGen, Reader LocalVars, Inference, Builtins, Output Example, State TypesTable, Termination, Output TypedHole, Output CastHole] r) => (Members '[HighlightBuilder, Reader InfoTable, State FunctionsTable, Error TypeCheckerError, NameIdGen, Reader LocalVars, Inference, Builtins, Output Example, State TypesTable, Termination, Output TypedHole, Output CastHole, Reader InsertedArgsStack] r) =>
Expression -> Expression ->
Sem r Expression Sem r Expression
checkDefType ty = checkIsType loc ty checkDefType ty = checkIsType loc ty
@ -388,7 +411,7 @@ checkCoercionType FunctionDef {..} = case mi of
ImplicitInstance -> throw (ErrWrongCoercionArgument (WrongCoercionArgument fp)) ImplicitInstance -> throw (ErrWrongCoercionArgument (WrongCoercionArgument fp))
checkExample :: checkExample ::
(Members '[HighlightBuilder, Reader InfoTable, State FunctionsTable, Error TypeCheckerError, Builtins, NameIdGen, Output Example, State TypesTable, Termination] r) => (Members '[HighlightBuilder, Reader InfoTable, State FunctionsTable, Error TypeCheckerError, Builtins, NameIdGen, Output Example, State TypesTable, Termination, Reader InsertedArgsStack] r) =>
Example -> Example ->
Sem r Example Sem r Example
checkExample e = do checkExample e = do
@ -398,7 +421,7 @@ checkExample e = do
checkExpression :: checkExpression ::
forall r. forall r.
(Members '[HighlightBuilder, Reader InfoTable, State FunctionsTable, Error TypeCheckerError, Builtins, NameIdGen, Reader LocalVars, Inference, Output Example, Output TypedHole, State TypesTable, Termination, Output CastHole] r) => (Members '[HighlightBuilder, Reader InfoTable, State FunctionsTable, Error TypeCheckerError, Builtins, NameIdGen, Reader LocalVars, Inference, Output Example, Output TypedHole, State TypesTable, Termination, Output CastHole, Reader InsertedArgsStack] r) =>
Expression -> Expression ->
Expression -> Expression ->
Sem r Expression Sem r Expression
@ -425,7 +448,7 @@ checkExpression expectedTy e = do
resolveInstanceHoles :: resolveInstanceHoles ::
forall a r. forall a r.
(HasExpressions a) => (HasExpressions a) =>
(Members '[HighlightBuilder, Reader InfoTable, State FunctionsTable, Error TypeCheckerError, Builtins, NameIdGen, Inference, Output Example, State TypesTable, Termination] r) => (Members '[HighlightBuilder, Reader InfoTable, State FunctionsTable, Error TypeCheckerError, Builtins, NameIdGen, Inference, Output Example, State TypesTable, Termination, Reader InsertedArgsStack] r) =>
Sem (Output TypedHole ': r) a -> Sem (Output TypedHole ': r) a ->
Sem r a Sem r a
resolveInstanceHoles s = do resolveInstanceHoles s = do
@ -443,7 +466,7 @@ resolveInstanceHoles s = do
$ checkExpression _typedHoleType t $ checkExpression _typedHoleType t
checkFunctionParameter :: checkFunctionParameter ::
(Members '[HighlightBuilder, Reader InfoTable, State FunctionsTable, Error TypeCheckerError, NameIdGen, Reader LocalVars, Inference, Builtins, Output Example, State TypesTable, Termination, Output TypedHole, Output CastHole] r) => (Members '[HighlightBuilder, Reader InfoTable, State FunctionsTable, Error TypeCheckerError, NameIdGen, Reader LocalVars, Inference, Builtins, Output Example, State TypesTable, Termination, Output TypedHole, Output CastHole, Reader InsertedArgsStack] r) =>
FunctionParameter -> FunctionParameter ->
Sem r FunctionParameter Sem r FunctionParameter
checkFunctionParameter FunctionParameter {..} = do checkFunctionParameter FunctionParameter {..} = do
@ -460,7 +483,7 @@ checkFunctionParameter FunctionParameter {..} = do
} }
inferExpression :: inferExpression ::
(Members '[HighlightBuilder, Reader InfoTable, State FunctionsTable, Error TypeCheckerError, NameIdGen, Reader LocalVars, Inference, Builtins, Output Example, State TypesTable, Termination] r) => (Members '[HighlightBuilder, Reader InfoTable, State FunctionsTable, Error TypeCheckerError, NameIdGen, Reader LocalVars, Inference, Builtins, Output Example, State TypesTable, Termination, Reader InsertedArgsStack] r) =>
-- | type hint -- | type hint
Maybe Expression -> Maybe Expression ->
Expression -> Expression ->
@ -475,7 +498,7 @@ lookupVar v = do
err = error $ "internal error: could not find var " <> ppTrace v <> " at " <> ppTrace (getLoc v) err = error $ "internal error: could not find var " <> ppTrace v <> " at " <> ppTrace (getLoc v)
checkFunctionBody :: checkFunctionBody ::
(Members '[Reader LocalVars, Reader InfoTable, NameIdGen, Error TypeCheckerError, Output Example, Output TypedHole, State TypesTable, State HighlightInput, State FunctionsTable, Builtins, Inference, Termination, Output CastHole] r) => (Members '[Reader LocalVars, Reader InfoTable, NameIdGen, Error TypeCheckerError, Output Example, Output TypedHole, State TypesTable, State HighlightInput, State FunctionsTable, Builtins, Inference, Termination, Output CastHole, Reader InsertedArgsStack] r) =>
Expression -> Expression ->
Expression -> Expression ->
Sem r Expression Sem r Expression
@ -501,7 +524,7 @@ checkFunctionBody expectedTy body =
-- | helper function for lambda functions and case branches -- | helper function for lambda functions and case branches
checkClause :: checkClause ::
forall r. forall r.
(Members '[HighlightBuilder, Reader InfoTable, State FunctionsTable, Reader LocalVars, Error TypeCheckerError, NameIdGen, Inference, Builtins, Output Example, State TypesTable, Termination, Output TypedHole, Output CastHole] r) => (Members '[HighlightBuilder, Reader InfoTable, State FunctionsTable, Reader LocalVars, Error TypeCheckerError, NameIdGen, Inference, Builtins, Output Example, State TypesTable, Termination, Output TypedHole, Output CastHole, Reader InsertedArgsStack] r) =>
Interval -> Interval ->
-- | Type -- | Type
Expression -> Expression ->
@ -754,7 +777,7 @@ checkPattern = go
inferExpression' :: inferExpression' ::
forall r. forall r.
(Members '[HighlightBuilder, Reader InfoTable, State FunctionsTable, State TypesTable, Reader LocalVars, Error TypeCheckerError, NameIdGen, Inference, Output Example, Output TypedHole, Builtins, Termination, Output CastHole] r) => (Members '[HighlightBuilder, Reader InfoTable, State FunctionsTable, State TypesTable, Reader LocalVars, Error TypeCheckerError, NameIdGen, Inference, Output Example, Output TypedHole, Builtins, Termination, Output CastHole, Reader InsertedArgsStack, Reader InsertedArgsStack] r) =>
Maybe Expression -> Maybe Expression ->
Expression -> Expression ->
Sem r TypedExpression Sem r TypedExpression
@ -763,7 +786,7 @@ inferExpression' = holesHelper
-- | Checks anything but an Application. Does not insert holes -- | Checks anything but an Application. Does not insert holes
inferLeftAppExpression :: inferLeftAppExpression ::
forall r. forall r.
(Members '[HighlightBuilder, Reader InfoTable, State FunctionsTable, State TypesTable, Reader LocalVars, Error TypeCheckerError, NameIdGen, Inference, Output Example, Output TypedHole, Builtins, Termination, Output CastHole] r) => (Members '[HighlightBuilder, Reader InfoTable, State FunctionsTable, State TypesTable, Reader LocalVars, Error TypeCheckerError, NameIdGen, Inference, Output Example, Output TypedHole, Builtins, Termination, Output CastHole, Reader InsertedArgsStack] r) =>
Maybe Expression -> Maybe Expression ->
Expression -> Expression ->
Sem r TypedExpression Sem r TypedExpression
@ -991,7 +1014,7 @@ inferLeftAppExpression mhint e = case e of
return (TypedExpression kind (ExpressionIden i)) return (TypedExpression kind (ExpressionIden i))
-- | The hint is used for trailing holes only -- | The hint is used for trailing holes only
holesHelper :: forall r. (Members '[HighlightBuilder, Reader InfoTable, State FunctionsTable, State TypesTable, Reader LocalVars, Error TypeCheckerError, NameIdGen, Inference, Output Example, Output TypedHole, Builtins, Termination, Output CastHole] r) => Maybe Expression -> Expression -> Sem r TypedExpression holesHelper :: forall r. (Members '[HighlightBuilder, Reader InfoTable, State FunctionsTable, State TypesTable, Reader LocalVars, Error TypeCheckerError, NameIdGen, Inference, Output Example, Output TypedHole, Builtins, Termination, Output CastHole, Reader InsertedArgsStack] r) => Maybe Expression -> Expression -> Sem r TypedExpression
holesHelper mhint expr = do holesHelper mhint expr = do
let (f, args) = unfoldExpressionApp expr let (f, args) = unfoldExpressionApp expr
hint hint
@ -999,19 +1022,78 @@ holesHelper mhint expr = do
| otherwise = Nothing | otherwise = Nothing
arityCheckBuiltins f args arityCheckBuiltins f args
fTy <- inferLeftAppExpression hint f fTy <- inferLeftAppExpression hint f
let iniBuilder = iniBuilderType <- mkInitBuilderType fTy
let iniArg :: ApplicationArg -> AppBuilderArg
iniArg a =
AppBuilderArg
{ _appBuilderArgIsDefault = ItIsNotDefault,
_appBuilderArg = a
}
iniBuilder =
AppBuilder AppBuilder
{ _appBuilder = fTy ^. typedExpression, { _appBuilder = fTy ^. typedExpression,
_appBuilderType = fTy ^. typedType, _appBuilderType = iniBuilderType,
_appBuilderArgs = args _appBuilderArgs = map iniArg args
} }
st' <- execState iniBuilder goArgs st' <- execState iniBuilder goArgs
let ty' = mkFinalBuilderType (st' ^. appBuilderType)
return return
TypedExpression TypedExpression
{ _typedType = st' ^. appBuilderType, { _typedType = ty',
_typedExpression = st' ^. appBuilder _typedExpression = st' ^. appBuilder
} }
where where
mkFinalBuilderType :: BuilderType -> Expression
mkFinalBuilderType = \case
BuilderTypeNoDefaults e -> e
BuilderTypeDefaults f ->
ExpressionFunction
Function
{ _functionLeft = f ^. functionDefaultLeft,
_functionRight = mkFinalBuilderType (f ^. functionDefaultRight)
}
getFunctionName :: Expression -> Maybe Name
getFunctionName = \case
ExpressionIden (IdenFunction fun) -> Just fun
_ -> Nothing
mkInitBuilderType :: TypedExpression -> Sem r BuilderType
mkInitBuilderType fTy = do
let ty = fTy ^. typedType
case getFunctionName (fTy ^. typedExpression) of
Just fun -> do
infos <- (^. functionInfoDef . funDefArgsInfo) <$> lookupFunction fun
return $ toFunctionDefaultMay fun ty infos
Nothing -> return (BuilderTypeNoDefaults ty)
where
toFunctionDefaultMay :: Name -> Expression -> [ArgInfo] -> BuilderType
toFunctionDefaultMay funName ty infos =
let ixInfos = nonEmpty (indexFrom 0 infos)
in maybe (BuilderTypeNoDefaults ty) (BuilderTypeDefaults . toFunctionDefault funName ty) ixInfos
toFunctionDefault :: Name -> Expression -> NonEmpty (Indexed ArgInfo) -> FunctionDefault
toFunctionDefault _argIdFunctionName e (Indexed _argIdIx a :| as) = case e of
ExpressionFunction f ->
FunctionDefault
{ _functionDefaultLeft = f ^. functionLeft,
_functionDefaultRight =
toFunctionDefaultMay
_argIdFunctionName
(f ^. functionRight)
(map (^. indexedThing) as),
_functionDefaultDefault =
let uid =
ArgId
{ _argIdDefinitionLoc = Irrelevant (getLoc f),
_argIdName = Irrelevant (a ^. argInfoName),
_argIdFunctionName,
_argIdIx
}
in (uid,) <$> a ^. argInfoDefault
}
_ -> impossible
arityCheckBuiltins :: Expression -> [ApplicationArg] -> Sem r () arityCheckBuiltins :: Expression -> [ApplicationArg] -> Sem r ()
arityCheckBuiltins f args = do arityCheckBuiltins f args = do
case f of case f of
@ -1060,57 +1142,121 @@ holesHelper mhint expr = do
insertTrailingHoles hintTy = do insertTrailingHoles hintTy = do
builderTy <- gets (^. appBuilderType) builderTy <- gets (^. appBuilderType)
ariHint <- typeArity hintTy ariHint <- typeArity hintTy
ariExpr <- typeArity builderTy (defaults, restExprTy) <- peelDefault builderTy
restExprAri <- typeArity restExprTy
let preImplicits :: Arity -> [IsImplicit] let preImplicits :: Arity -> [IsImplicit]
preImplicits = takeWhile isImplicitOrInstance . map (^. arityParameterImplicit) . unfoldArity preImplicits = takeWhile isImplicitOrInstance . map (^. arityParameterImplicit) . unfoldArity
preAriExpr = preImplicits ariExpr preImplicitsTypeRest = preImplicits restExprAri
preAriHint = preImplicits ariHint preAriHint = preImplicits ariHint
preImplicitsInType =
length
( takeWhile
isImplicitOrInstance
(map fst defaults ++ preImplicitsTypeRest)
)
loc <- getLoc <$> gets (^. appBuilder) loc <- getLoc <$> gets (^. appBuilder)
let toBeInserted :: [IsImplicit] = take (length preAriExpr - length preAriHint) preAriExpr let numberOfExtraHoles = preImplicitsInType - length preAriHint
mkHoleArg :: IsImplicit -> Sem r' ApplicationArg toBeInserted :: [(IsImplicit, Maybe (ArgId, Expression))] =
mkHoleArg i = take numberOfExtraHoles (defaults <> (map (,Nothing) preImplicitsTypeRest))
ApplicationArg i <$> case i of mkHoleArg :: (IsImplicit, Maybe (ArgId, Expression)) -> Sem r' AppBuilderArg
mkHoleArg (i, mdef) = do
(_appArg, _appBuilderArgIsDefault) <- case i of
Explicit -> impossible Explicit -> impossible
Implicit -> newHoleImplicit loc Implicit -> case mdef of
ImplicitInstance -> newHoleInstance loc Nothing -> (,ItIsNotDefault) <$> newHoleImplicit loc
Just (uid, def) -> return (def, ItIsDefault uid)
ImplicitInstance -> (,ItIsNotDefault) <$> newHoleInstance loc
return
AppBuilderArg
{ _appBuilderArg =
ApplicationArg
{ _appArgIsImplicit = i,
_appArg
},
_appBuilderArgIsDefault
}
trailingHoles <- mapM mkHoleArg toBeInserted trailingHoles <- mapM mkHoleArg toBeInserted
mapM_ addTrailingHole trailingHoles mapM_ addTrailingHole trailingHoles
where where
addTrailingHole :: ApplicationArg -> Sem r' () peelDefault :: BuilderType -> Sem r' ([(IsImplicit, Maybe (ArgId, Expression))], Expression)
addTrailingHole a = do peelDefault bty = runOutputList (go bty)
fun <- peekFunctionType (a ^. appArgIsImplicit) where
modify' (over appBuilderArgs (a :)) go :: BuilderType -> Sem (Output (IsImplicit, Maybe (ArgId, Expression)) ': r') Expression
checkMatchingArg a fun go = \case
BuilderTypeNoDefaults e -> return e
BuilderTypeDefaults d -> do
let impl = d ^. functionDefaultLeft . paramImplicit
output (impl, d ^. functionDefaultDefault)
go (d ^. functionDefaultRight)
checkMatchingArg :: ApplicationArg -> Function -> Sem r' () addTrailingHole :: AppBuilderArg -> Sem r' ()
addTrailingHole holeArg = do
fun <- peekFunctionType (holeArg ^. appBuilderArg . appArgIsImplicit)
modify' (over appBuilderArgs (holeArg :))
checkMatchingArg holeArg fun
checkLoop :: AppBuilderArg -> Sem r' ()
checkLoop arg = case arg ^. appBuilderArgIsDefault of
ItIsNotDefault -> return ()
ItIsDefault uid -> do
st <- asks (^. insertedArgsStack)
case span (/= uid) st of
(_, []) -> return ()
(c, _) ->
let cyc = NonEmpty.reverse (uid :| c)
in throw (ErrDefaultArgLoop (DefaultArgLoop cyc))
checkMatchingArg :: AppBuilderArg -> FunctionDefault -> Sem r' ()
checkMatchingArg arg fun = do checkMatchingArg arg fun = do
dropArg dropArg
let funParam = fun ^. functionLeft let funParam = fun ^. functionDefaultLeft
funL = funParam ^. paramType funL = funParam ^. paramType
funR = fun ^. functionRight funR = fun ^. functionDefaultRight
arg' <- checkExpression funL (arg ^. appArg) checkLeft :: Sem r' Expression
let subs :: Expression -> Sem r' Expression = substitutionApp (funParam ^. paramName, arg') checkLeft = do
checkLoop arg
let adjustCtx = case fun ^. functionDefaultDefault of
Nothing -> id
Just (uid, _) -> local (over insertedArgsStack (uid :))
adjustCtx (checkExpression funL (arg ^. appBuilderArg . appArg))
arg' <- checkLeft
let subsE :: (HasExpressions expr) => expr -> Sem r' expr
subsE = substitutionApp (funParam ^. paramName, arg')
subsBuilderType :: BuilderType -> Sem r' BuilderType = \case
BuilderTypeNoDefaults e -> BuilderTypeNoDefaults <$> subsE e
BuilderTypeDefaults FunctionDefault {..} -> do
def' <- mapM (secondM subsE) _functionDefaultDefault
l' <- subsE _functionDefaultLeft
r' <- subsBuilderType _functionDefaultRight
return
( BuilderTypeDefaults
FunctionDefault
{ _functionDefaultLeft = l',
_functionDefaultDefault = def',
_functionDefaultRight = r'
}
)
applyArg :: Expression -> Expression applyArg :: Expression -> Expression
applyArg l = applyArg l =
ExpressionApplication ExpressionApplication
Application Application
{ _appLeft = l, { _appLeft = l,
_appRight = arg', _appRight = arg',
_appImplicit = arg ^. appArgIsImplicit _appImplicit = arg ^. appBuilderArg . appArgIsImplicit
} }
funR' <- subs funR funR' <- subsBuilderType funR
modify' (set appBuilderType funR') modify' (set appBuilderType funR')
modify' (over appBuilder applyArg) modify' (over appBuilder applyArg)
goNextArg :: ApplicationArg -> Sem r' () goNextArg :: AppBuilderArg -> Sem r' ()
goNextArg arg = do goNextArg arg = do
let i = arg ^. appArgIsImplicit let i = arg ^. appBuilderArg . appArgIsImplicit
fun <- peekFunctionType i fun <- peekFunctionType i
insertMiddleHoleOrCheck fun i insertMiddleHoleOrCheck fun i
where where
insertMiddleHoleOrCheck :: Function -> IsImplicit -> Sem r' () insertMiddleHoleOrCheck :: FunctionDefault -> IsImplicit -> Sem r' ()
insertMiddleHoleOrCheck fun argImpl = insertMiddleHoleOrCheck fun argImpl =
let funParam = fun ^. functionLeft let funParam = fun ^. functionDefaultLeft
funImpl = funParam ^. paramImplicit funImpl = funParam ^. paramImplicit
checkThisArg = checkMatchingArg arg fun >> goArgs checkThisArg = checkMatchingArg arg fun >> goArgs
in case (argImpl, funImpl) of in case (argImpl, funImpl) of
@ -1128,11 +1274,18 @@ holesHelper mhint expr = do
insertMiddleHole impl = do insertMiddleHole impl = do
l <- gets (^. appBuilder) l <- gets (^. appBuilder)
let loc = getLoc l let loc = getLoc l
h <- case impl of (h, _appBuilderArgIsDefault) <- case impl of
Implicit -> newHoleImplicit loc ImplicitInstance -> (,ItIsNotDefault) <$> newHoleInstance loc
ImplicitInstance -> newHoleInstance loc
Explicit -> impossible Explicit -> impossible
modify' (over appBuilderArgs (ApplicationArg impl h :)) Implicit -> case fun ^. functionDefaultDefault of
Nothing -> (,ItIsNotDefault) <$> newHoleImplicit loc
Just (uid, e) -> return (e, ItIsDefault uid)
let a =
AppBuilderArg
{ _appBuilderArg = ApplicationArg impl h,
_appBuilderArgIsDefault
}
modify' (over appBuilderArgs (a :))
goArgs goArgs
throwExpectedExplicit :: Sem r' a throwExpectedExplicit :: Sem r' a
@ -1146,32 +1299,46 @@ holesHelper mhint expr = do
_expectedExplicitArgumentIx = error "FIXME" _expectedExplicitArgumentIx = error "FIXME"
} }
peekFunctionType :: IsImplicit -> Sem r' Function peekFunctionType :: IsImplicit -> Sem r' FunctionDefault
peekFunctionType impl = do peekFunctionType impl = do
ty <- gets (^. appBuilderType) >>= weakNormalize bty <- gets (^. appBuilderType)
case ty of case bty of
ExpressionFunction f -> return f BuilderTypeNoDefaults ty -> fromNoDefault <$> peekFunctionNoDefaults ty
ExpressionHole h -> holeRefineToFunction impl h BuilderTypeDefaults s -> return s
_ -> throwExpectedFunTy where
where fromNoDefault :: Function -> FunctionDefault
throwExpectedFunTy :: Sem r' a fromNoDefault f =
throwExpectedFunTy = do FunctionDefault
l <- gets (^. appBuilder) { _functionDefaultLeft = f ^. functionLeft,
builderTy <- gets (^. appBuilderType) _functionDefaultDefault = Nothing,
args <- gets (^. appBuilderArgs) _functionDefaultRight = BuilderTypeNoDefaults (f ^. functionRight)
let a :: Expression = foldApplication l args }
throw $ peekFunctionNoDefaults :: Expression -> Sem r' Function
ErrExpectedFunctionType peekFunctionNoDefaults ty0 = do
ExpectedFunctionType ty <- weakNormalize ty0
{ _expectedFunctionTypeExpression = a, case ty of
_expectedFunctionTypeLeft = l, ExpressionFunction f -> return f
_expectedFunctionTypeType = builderTy ExpressionHole h -> holeRefineToFunction impl h
} _ -> throwExpectedFunTy
where
throwExpectedFunTy :: Sem r' a
throwExpectedFunTy = do
l <- gets (^. appBuilder)
builderTy <- gets (^. appBuilderType)
args <- gets (^. appBuilderArgs)
let a :: Expression = foldApplication l (map (^. appBuilderArg) args)
throw $
ErrExpectedFunctionType
ExpectedFunctionType
{ _expectedFunctionTypeExpression = a,
_expectedFunctionTypeLeft = l,
_expectedFunctionTypeType = (mkFinalBuilderType builderTy)
}
dropArg :: Sem r' () dropArg :: Sem r' ()
dropArg = modify' (over appBuilderArgs (drop 1)) dropArg = modify' (over appBuilderArgs (drop 1))
peekArg :: Sem r' (Maybe ApplicationArg) peekArg :: Sem r' (Maybe AppBuilderArg)
peekArg = do peekArg = do
b <- get b <- get
return (head <$> nonEmpty (b ^. appBuilderArgs)) return (head <$> nonEmpty (b ^. appBuilderArgs))

View File

@ -4,9 +4,17 @@ import Juvix.Compiler.Internal.Extra
import Juvix.Prelude import Juvix.Prelude
import Juvix.Prelude.Pretty import Juvix.Prelude.Pretty
data ArgId = ArgId
{ _argIdFunctionName :: Name,
_argIdIx :: Int,
_argIdDefinitionLoc :: Irrelevant Interval,
_argIdName :: Irrelevant (Maybe Name)
}
deriving stock (Eq, Ord)
-- | Used to detect of cycles of default arguments in the arity checker. -- | Used to detect of cycles of default arguments in the arity checker.
newtype InsertedArgsStack = InsertedArgsStack newtype InsertedArgsStack = InsertedArgsStack
{ _insertedArgsStack :: [Name] { _insertedArgsStack :: [ArgId]
} }
deriving newtype (Monoid, Semigroup) deriving newtype (Monoid, Semigroup)
@ -20,9 +28,6 @@ data InsertedArg = InsertedArg
_insertedArgDefault :: Bool _insertedArgDefault :: Bool
} }
-- pattern ArityParam :: IsImplicit -> ArityParameter
-- pattern ArityParam impl <- ArityParameter {_arityParameterImplicit = impl}
data Blocking data Blocking
= BlockingVar VarName = BlockingVar VarName
| BlockingHole Hole | BlockingHole Hole
@ -65,11 +70,15 @@ instance Eq ArityParameter where
(ari, impl) == (ari', impl') (ari, impl) == (ari', impl')
makeLenses ''UnfoldedArity makeLenses ''UnfoldedArity
makeLenses ''ArgId
makeLenses ''FunctionArity makeLenses ''FunctionArity
makeLenses ''InsertedArg makeLenses ''InsertedArg
makeLenses ''ArityParameter makeLenses ''ArityParameter
makeLenses ''InsertedArgsStack makeLenses ''InsertedArgsStack
instance HasLoc ArgId where
getLoc = (^. argIdDefinitionLoc . unIrrelevant)
arityParameterName :: Lens' ArityParameter (Maybe Name) arityParameterName :: Lens' ArityParameter (Maybe Name)
arityParameterName = arityParameterInfo . argInfoName arityParameterName = arityParameterInfo . argInfoName

View File

@ -35,6 +35,7 @@ data TypeCheckerError
| ErrExplicitInstanceArgument ExplicitInstanceArgument | ErrExplicitInstanceArgument ExplicitInstanceArgument
| ErrTraitNotTerminating TraitNotTerminating | ErrTraitNotTerminating TraitNotTerminating
| ErrArityCheckerError ArityCheckerError | ErrArityCheckerError ArityCheckerError
| ErrDefaultArgLoop DefaultArgLoop
instance ToGenericError TypeCheckerError where instance ToGenericError TypeCheckerError where
genericError :: (Member (Reader GenericOptions) r) => TypeCheckerError -> Sem r GenericError genericError :: (Member (Reader GenericOptions) r) => TypeCheckerError -> Sem r GenericError
@ -62,3 +63,4 @@ instance ToGenericError TypeCheckerError where
ErrExplicitInstanceArgument e -> genericError e ErrExplicitInstanceArgument e -> genericError e
ErrTraitNotTerminating e -> genericError e ErrTraitNotTerminating e -> genericError e
ErrArityCheckerError e -> genericError e ErrArityCheckerError e -> genericError e
ErrDefaultArgLoop e -> genericError e

View File

@ -3,6 +3,7 @@ module Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.Er
import Juvix.Compiler.Internal.Data.InstanceInfo import Juvix.Compiler.Internal.Data.InstanceInfo
import Juvix.Compiler.Internal.Language import Juvix.Compiler.Internal.Language
import Juvix.Compiler.Internal.Pretty (fromGenericOptions) import Juvix.Compiler.Internal.Pretty (fromGenericOptions)
import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.CheckerNew.Arity
import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.Error.Pretty import Juvix.Compiler.Internal.Translation.FromInternal.Analysis.TypeChecking.Error.Pretty
import Juvix.Data.PPOutput import Juvix.Data.PPOutput
import Juvix.Prelude import Juvix.Prelude
@ -620,3 +621,27 @@ instance ToGenericError TraitNotTerminating where
<+> ppCode opts' (e ^. traitNotTerminating) <+> ppCode opts' (e ^. traitNotTerminating)
<> line <> line
<> "Each parameter of a trait in an instance argument must be structurally smaller than some parameter of the trait in the instance target" <> "Each parameter of a trait in an instance argument must be structurally smaller than some parameter of the trait in the instance target"
newtype DefaultArgLoop = DefaultArgLoop
{ _defaultArgLoop :: NonEmpty ArgId
}
makeLenses ''DefaultArgLoop
instance ToGenericError DefaultArgLoop where
genericError e = ask >>= generr
where
generr opts =
return
GenericError
{ _genericErrorLoc = i,
_genericErrorMessage = ppOutput msg,
_genericErrorIntervals = [i]
}
where
opts' = fromGenericOptions opts
i = getLoc (head (e ^. defaultArgLoop))
msg :: Doc Ann =
"Inserting default arguments caused a loop. The involved arguments are:"
<> line
<> itemize (ppCode opts' <$> e ^. defaultArgLoop)

View File

@ -56,10 +56,7 @@ extraTests =
ignored :: HashSet String ignored :: HashSet String
ignored = ignored =
HashSet.fromList HashSet.fromList
[ "Test066: Import function with a function call in default argument", [ "Test070: Nested default values and named arguments",
"Test068: Dependent default values inserted in the arity checker",
"Test069: Dependent default values for Ord trait",
"Test070: Nested default values and named arguments",
"Test071: Named application", "Test071: Named application",
-- This test does not pass with the new hole insertion algorithm -- This test does not pass with the new hole insertion algorithm
"Test046: Polymorphic type arguments" "Test046: Polymorphic type arguments"