From 5fea31eec61fed58a13ae0632949eefd79167a22 Mon Sep 17 00:00:00 2001 From: Jan Mas Rovira Date: Sun, 1 Dec 2024 16:34:27 +0100 Subject: [PATCH] Make FunctionLhs a field of FunctionDef (#3202) --- app/Commands/Repl.hs | 2 +- .../Backend/Html/Translation/FromTyped.hs | 6 +- .../Concrete/Data/InfoTableBuilder.hs | 4 +- .../Concrete/Data/NameSignature/Builder.hs | 2 +- src/Juvix/Compiler/Concrete/Extra.hs | 4 +- src/Juvix/Compiler/Concrete/Gen.hs | 38 ++++++----- src/Juvix/Compiler/Concrete/Language.hs | 2 +- src/Juvix/Compiler/Concrete/Language/Base.hs | 67 ++++++++++--------- src/Juvix/Compiler/Concrete/Print/Base.hs | 8 +-- .../FromParsed/Analysis/Scoping.hs | 40 ++++++----- .../Concrete/Translation/FromSource.hs | 29 ++++---- .../Internal/Translation/FromConcrete.hs | 32 ++++----- src/Juvix/Compiler/Pipeline/Package/Loader.hs | 26 ++++--- 13 files changed, 136 insertions(+), 124 deletions(-) diff --git a/app/Commands/Repl.hs b/app/Commands/Repl.hs index c7a87ffa9..1e84f298c 100644 --- a/app/Commands/Repl.hs +++ b/app/Commands/Repl.hs @@ -293,7 +293,7 @@ printDocumentation = replParseIdentifiers >=> printIdentifiers getDocFunction fun = do tbl :: Scoped.InfoTable <- getScopedInfoTable let def = tbl ^?! Scoped.infoFunctions . at fun . _Just - return (def ^. Concrete.signDoc) + return (def ^. Concrete.functionDefDoc) getDocInductive :: Scoped.NameId -> Repl (Maybe (Concrete.Judoc 'Concrete.Scoped)) getDocInductive ind = do diff --git a/src/Juvix/Compiler/Backend/Html/Translation/FromTyped.hs b/src/Juvix/Compiler/Backend/Html/Translation/FromTyped.hs index eec28fb65..447b6f286 100644 --- a/src/Juvix/Compiler/Backend/Html/Translation/FromTyped.hs +++ b/src/Juvix/Compiler/Backend/Html/Translation/FromTyped.hs @@ -541,12 +541,12 @@ goAxiom axiom = do goDeriving :: forall r. (Members '[Reader HtmlOptions] r) => Deriving 'Scoped -> Sem r Html goDeriving def = do sig <- ppHelper (ppCode def) - defHeader (def ^. derivingFunLhs . funLhsName . functionDefName) sig Nothing + defHeader (def ^. derivingFunLhs . funLhsName . functionDefNameScoped) sig Nothing goFunctionDef :: forall r. (Members '[Reader HtmlOptions] r) => FunctionDef 'Scoped -> Sem r Html goFunctionDef def = do - sig <- ppHelper (ppCode (functionDefLhs def)) - defHeader (def ^. signName . functionDefName) sig (def ^. signDoc) + sig <- ppHelper (ppCode (def ^. functionDefLhs)) + defHeader (def ^. functionDefName . functionDefNameScoped) sig (def ^. functionDefDoc) goInductive :: forall r. (Members '[Reader HtmlOptions] r) => InductiveDef 'Scoped -> Sem r Html goInductive def = do diff --git a/src/Juvix/Compiler/Concrete/Data/InfoTableBuilder.hs b/src/Juvix/Compiler/Concrete/Data/InfoTableBuilder.hs index 72a252a95..147a971e2 100644 --- a/src/Juvix/Compiler/Concrete/Data/InfoTableBuilder.hs +++ b/src/Juvix/Compiler/Concrete/Data/InfoTableBuilder.hs @@ -61,8 +61,8 @@ runInfoTableBuilder ini = reinterpret (runState ini) $ \case modify' (over infoInductives (HashMap.insert (ity ^. inductiveName . nameId) ity)) highlightDoc (ity ^. inductiveName . nameId) j RegisterFunctionDef f -> do - let j = f ^. signDoc - fid = f ^. signName . functionDefName . nameId + let j = f ^. functionDefDoc + fid = f ^. functionDefName . functionDefNameScoped . nameId modify' (over infoFunctions (HashMap.insert fid f)) highlightDoc fid j RegisterName n -> highlightName (S.anameFromName n) diff --git a/src/Juvix/Compiler/Concrete/Data/NameSignature/Builder.hs b/src/Juvix/Compiler/Concrete/Data/NameSignature/Builder.hs index ace4a4ec2..001dc016e 100644 --- a/src/Juvix/Compiler/Concrete/Data/NameSignature/Builder.hs +++ b/src/Juvix/Compiler/Concrete/Data/NameSignature/Builder.hs @@ -68,7 +68,7 @@ instance (SingI s) => HasNameSignature s (FunctionLhs s) where addArgs FunctionLhs {..} = addArgs _funLhsTypeSig instance (SingI s) => HasNameSignature s (FunctionDef s) where - addArgs = addArgs . functionDefLhs + addArgs = addArgs . (^. functionDefLhs) instance (SingI s) => HasNameSignature s (InductiveDef s, ConstructorDef s) where addArgs :: diff --git a/src/Juvix/Compiler/Concrete/Extra.hs b/src/Juvix/Compiler/Concrete/Extra.hs index 1484e573f..42859b64a 100644 --- a/src/Juvix/Compiler/Concrete/Extra.hs +++ b/src/Juvix/Compiler/Concrete/Extra.hs @@ -72,7 +72,7 @@ groupStatements = \case definesSymbol n s = case s of StatementInductive d -> n `elem` syms d StatementAxiom d -> n == symbolParsed (d ^. axiomName) - StatementFunctionDef d -> withFunctionSymbol False (\n' -> n == symbolParsed n') (d ^. signName) + StatementFunctionDef d -> withFunctionSymbol False (\n' -> n == symbolParsed n') (d ^. functionDefName) _ -> False where syms :: InductiveDef s -> [Symbol] @@ -115,4 +115,4 @@ isLhsFunctionLike FunctionLhs {..} = notNull (_funLhsTypeSig ^. typeSigArgs) isFunctionLike :: FunctionDef 'Parsed -> Bool isFunctionLike d@FunctionDef {..} = - isLhsFunctionLike (functionDefLhs d) || (not . isBodyExpression) _signBody + isLhsFunctionLike (d ^. functionDefLhs) || (not . isBodyExpression) _functionDefBody diff --git a/src/Juvix/Compiler/Concrete/Gen.hs b/src/Juvix/Compiler/Concrete/Gen.hs index 957a41d19..828f67bfe 100644 --- a/src/Juvix/Compiler/Concrete/Gen.hs +++ b/src/Juvix/Compiler/Concrete/Gen.hs @@ -26,29 +26,33 @@ simplestFunctionDefParsed funNameTxt funBody = do simplestFunctionDef :: forall s. (SingI s) => FunctionName s -> ExpressionType s -> FunctionDef s simplestFunctionDef funName funBody = - FunctionDef - { _signName = name, - _signBody = SigBodyExpression funBody, - _signTypeSig = - TypeSig - { _typeSigColonKw = Irrelevant Nothing, - _typeSigArgs = [], - _typeSigRetType = Nothing - }, - _signDoc = Nothing, - _signPragmas = Nothing, - _signBuiltin = Nothing, - _signTerminating = Nothing, - _signInstance = Nothing, - _signCoercion = Nothing - } + let lhs = + FunctionLhs + { _funLhsName = name, + _funLhsTypeSig = + TypeSig + { _typeSigColonKw = Irrelevant Nothing, + _typeSigArgs = [], + _typeSigRetType = Nothing + }, + _funLhsBuiltin = Nothing, + _funLhsTerminating = Nothing, + _funLhsInstance = Nothing, + _funLhsCoercion = Nothing + } + in FunctionDef + { _functionDefBody = SigBodyExpression funBody, + _functionDefLhs = lhs, + _functionDefDoc = Nothing, + _functionDefPragmas = Nothing + } where name :: FunctionSymbolType s name = case sing :: SStage s of SParsed -> FunctionDefName funName SScoped -> FunctionDefNameScoped - { _functionDefName = funName, + { _functionDefNameScoped = funName, _functionDefNamePattern = Nothing } diff --git a/src/Juvix/Compiler/Concrete/Language.hs b/src/Juvix/Compiler/Concrete/Language.hs index 47b7af06c..4ab99d87f 100644 --- a/src/Juvix/Compiler/Concrete/Language.hs +++ b/src/Juvix/Compiler/Concrete/Language.hs @@ -30,7 +30,7 @@ statementLabel = \case StatementSyntax s -> goSyntax s StatementOpenModule {} -> Nothing StatementProjectionDef {} -> Nothing - StatementFunctionDef f -> withFunctionSymbol Nothing (Just . (^. symbolTypeLabel)) (f ^. signName) + StatementFunctionDef f -> withFunctionSymbol Nothing (Just . (^. symbolTypeLabel)) (f ^. functionDefName) StatementDeriving f -> withFunctionSymbol Nothing (Just . (^. symbolTypeLabel)) (f ^. derivingFunLhs . funLhsName) StatementImport i -> Just (i ^. importModulePath . to modulePathTypeLabel) StatementInductive i -> Just (i ^. inductiveName . symbolTypeLabel) diff --git a/src/Juvix/Compiler/Concrete/Language/Base.hs b/src/Juvix/Compiler/Concrete/Language/Base.hs index cdbb055fd..a93ebe0e1 100644 --- a/src/Juvix/Compiler/Concrete/Language/Base.hs +++ b/src/Juvix/Compiler/Concrete/Language/Base.hs @@ -716,7 +716,7 @@ instance Serialize FunctionDefNameParsed instance NFData FunctionDefNameParsed data FunctionDefNameScoped = FunctionDefNameScoped - { _functionDefName :: S.Symbol, + { _functionDefNameScoped :: S.Symbol, _functionDefNamePattern :: Maybe PatternArg } deriving stock (Eq, Ord, Show, Generic) @@ -726,15 +726,10 @@ instance Serialize FunctionDefNameScoped instance NFData FunctionDefNameScoped data FunctionDef (s :: Stage) = FunctionDef - { _signName :: FunctionSymbolType s, - _signTypeSig :: TypeSig s, - _signDoc :: Maybe (Judoc s), - _signPragmas :: Maybe ParsedPragmas, - _signBuiltin :: Maybe (WithLoc BuiltinFunction), - _signBody :: FunctionDefBody s, - _signTerminating :: Maybe KeywordRef, - _signInstance :: Maybe KeywordRef, - _signCoercion :: Maybe KeywordRef + { _functionDefDoc :: Maybe (Judoc s), + _functionDefPragmas :: Maybe ParsedPragmas, + _functionDefLhs :: FunctionLhs s, + _functionDefBody :: FunctionDefBody s } deriving stock (Generic) @@ -3057,16 +3052,23 @@ makePrisms ''NamedArgumentNew makePrisms ''ConstructorRhs makePrisms ''FunctionDefNameParsed -functionDefLhs :: FunctionDef s -> FunctionLhs s -functionDefLhs FunctionDef {..} = - FunctionLhs - { _funLhsBuiltin = _signBuiltin, - _funLhsTerminating = _signTerminating, - _funLhsInstance = _signInstance, - _funLhsCoercion = _signCoercion, - _funLhsName = _signName, - _funLhsTypeSig = _signTypeSig - } +functionDefBuiltin :: Lens' (FunctionDef s) (Maybe (WithLoc BuiltinFunction)) +functionDefBuiltin = functionDefLhs . funLhsBuiltin + +functionDefTerminating :: Lens' (FunctionDef s) (Maybe KeywordRef) +functionDefTerminating = functionDefLhs . funLhsTerminating + +functionDefInstance :: Lens' (FunctionDef s) (Maybe KeywordRef) +functionDefInstance = functionDefLhs . funLhsInstance + +functionDefCoercion :: Lens' (FunctionDef s) (Maybe KeywordRef) +functionDefCoercion = functionDefLhs . funLhsCoercion + +functionDefName :: Lens' (FunctionDef s) (FunctionSymbolType s) +functionDefName = functionDefLhs . funLhsName + +functionDefTypeSig :: Lens' (FunctionDef s) (TypeSig s) +functionDefTypeSig = functionDefLhs . funLhsTypeSig fixityFieldHelper :: SimpleGetter (ParsedFixityFields s) (Maybe a) -> SimpleGetter (ParsedFixityInfo s) (Maybe a) fixityFieldHelper l = to (^? fixityFields . _Just . l . _Just) @@ -3263,7 +3265,7 @@ getLocFunctionSymbolType = case sing :: SStage s of instance HasLoc FunctionDefNameScoped where getLoc FunctionDefNameScoped {..} = - getLoc _functionDefName + getLoc _functionDefNameScoped <>? (getLoc <$> _functionDefNamePattern) instance HasLoc FunctionDefNameParsed where @@ -3525,12 +3527,13 @@ instance (SingI s) => HasLoc (FunctionDefBody s) where instance (SingI s) => HasLoc (FunctionDef s) where getLoc FunctionDef {..} = - (getLoc <$> _signDoc) - ?<> (getLoc <$> _signPragmas) - ?<> (getLoc <$> _signBuiltin) - ?<> (getLoc <$> _signTerminating) - ?<> (getLocFunctionSymbolType _signName) - <> getLoc _signBody + let FunctionLhs {..} = _functionDefLhs + in (getLoc <$> _functionDefDoc) + ?<> (getLoc <$> _functionDefPragmas) + ?<> (getLoc <$> _funLhsBuiltin) + ?<> (getLoc <$> _funLhsTerminating) + ?<> (getLocFunctionSymbolType _funLhsName) + <> getLoc _functionDefBody instance HasLoc (Example s) where getLoc e = e ^. exampleLoc @@ -3719,7 +3722,7 @@ getFunctionSymbol sym = case sing :: SStage s of SParsed -> case sym of FunctionDefName p -> p FunctionDefNamePattern {} -> impossibleError "invalid call" - SScoped -> sym ^. functionDefName + SScoped -> sym ^. functionDefNameScoped functionSymbolPattern :: forall s. (SingI s) => FunctionSymbolType s -> Maybe (PatternAtomType s) functionSymbolPattern f = case sing :: SStage s of @@ -3729,19 +3732,19 @@ functionSymbolPattern f = case sing :: SStage s of withFunctionSymbol :: forall s a. (SingI s) => a -> (SymbolType s -> a) -> FunctionSymbolType s -> a withFunctionSymbol a f sym = case sing :: SStage s of SParsed -> maybe a f (sym ^? _FunctionDefName) - SScoped -> f (sym ^. functionDefName) + SScoped -> f (sym ^. functionDefNameScoped) namedArgumentNewSymbolParsed :: (SingI s) => SimpleGetter (NamedArgumentNew s) Symbol namedArgumentNewSymbolParsed = to $ \case NamedArgumentItemPun a -> a ^. namedArgumentPunSymbol - NamedArgumentNewFunction a -> symbolParsed (getFunctionSymbol (a ^. namedArgumentFunctionDef . signName)) + NamedArgumentNewFunction a -> symbolParsed (getFunctionSymbol (a ^. namedArgumentFunctionDef . functionDefName)) namedArgumentNewSymbol :: Lens' (NamedArgumentNew 'Parsed) Symbol namedArgumentNewSymbol f = \case NamedArgumentItemPun a -> NamedArgumentItemPun <$> (namedArgumentPunSymbol f a) NamedArgumentNewFunction a -> do - a' <- f (a ^?! namedArgumentFunctionDef . signName . _FunctionDefName) - return $ NamedArgumentNewFunction (over namedArgumentFunctionDef (set signName (FunctionDefName a')) a) + a' <- f (a ^?! namedArgumentFunctionDef . functionDefName . _FunctionDefName) + return $ NamedArgumentNewFunction (over namedArgumentFunctionDef (set functionDefName (FunctionDefName a')) a) scopedIdenSrcName :: Lens' ScopedIden S.Name scopedIdenSrcName f n = case n ^. scopedIdenAlias of diff --git a/src/Juvix/Compiler/Concrete/Print/Base.hs b/src/Juvix/Compiler/Concrete/Print/Base.hs index d6368a2ae..8f61ac9c2 100644 --- a/src/Juvix/Compiler/Concrete/Print/Base.hs +++ b/src/Juvix/Compiler/Concrete/Print/Base.hs @@ -1205,10 +1205,10 @@ ppPipeBranches allowSameLine isTop ppBranch = \case instance (SingI s) => PrettyPrint (FunctionDef s) where ppCode :: forall r. (Members '[ExactPrint, Reader Options] r) => FunctionDef s -> Sem r () ppCode fun@FunctionDef {..} = do - let doc' :: Maybe (Sem r ()) = ppCode <$> _signDoc - pragmas' :: Maybe (Sem r ()) = ppCode <$> _signPragmas - sig' = ppCode (functionDefLhs fun) - body' = case _signBody of + let doc' :: Maybe (Sem r ()) = ppCode <$> _functionDefDoc + pragmas' :: Maybe (Sem r ()) = ppCode <$> _functionDefPragmas + sig' = ppCode (fun ^. functionDefLhs) + body' = case _functionDefBody of SigBodyExpression e -> space <> ppCode Kw.kwAssign <> oneLineOrNext (ppTopExpressionType e) SigBodyClauses k -> ppPipeBranches False Top ppFunctionClause k doc' diff --git a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping.hs b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping.hs index c26b0fdf0..901d37ce8 100644 --- a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping.hs +++ b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping.hs @@ -439,7 +439,7 @@ reserveFunctionLikeSymbol :: Sem r () reserveFunctionLikeSymbol f = when (P.isFunctionLike f) $ - void (reserveFunctionSymbol (functionDefLhs f)) + void (reserveFunctionSymbol (f ^. functionDefLhs)) bindFixitySymbol :: (Members '[Error ScoperError, NameIdGen, State ScoperSyntax, State Scope, InfoTableBuilder, Reader InfoTable, State ScoperState, Reader BindingStrategy] r) => @@ -1129,7 +1129,7 @@ checkDeriving Deriving {..} = do | otherwise -> reserveFunctionSymbol lhs let defname' = FunctionDefNameScoped - { _functionDefName = name', + { _functionDefNameScoped = name', _functionDefNamePattern = Nothing } let lhs' = @@ -1192,21 +1192,22 @@ checkFunctionDef :: FunctionDef 'Parsed -> Sem r (FunctionDef 'Scoped) checkFunctionDef fdef@FunctionDef {..} = do - sigDoc' <- mapM checkJudoc _signDoc + let FunctionLhs {..} = _functionDefLhs + sigDoc' <- mapM checkJudoc _functionDefDoc (sig', sigBody') <- withLocalScope $ do - a' <- checkTypeSig _signTypeSig + a' <- checkTypeSig _funLhsTypeSig b' <- checkBody return (a', b') - whenJust (functionSymbolPattern _signName) reservePatternFunctionSymbols - sigName' <- case _signName of + whenJust (functionSymbolPattern _funLhsName) reservePatternFunctionSymbols + sigName' <- case _funLhsName of FunctionDefName name -> do name' <- if | P.isFunctionLike fdef -> getReservedDefinitionSymbol name - | otherwise -> reserveFunctionSymbol (functionDefLhs fdef) + | otherwise -> reserveFunctionSymbol (fdef ^. functionDefLhs) return FunctionDefNameScoped - { _functionDefName = name', + { _functionDefNameScoped = name', _functionDefNamePattern = Nothing } FunctionDefNamePattern p -> do @@ -1214,22 +1215,27 @@ checkFunctionDef fdef@FunctionDef {..} = do p' <- runReader PatternNamesKindFunctions (checkParsePatternAtom p) return FunctionDefNameScoped - { _functionDefName = name', + { _functionDefNameScoped = name', _functionDefNamePattern = Just p' } - let def = - FunctionDef - { _signName = sigName', - _signDoc = sigDoc', - _signBody = sigBody', - _signTypeSig = sig', + let lhs' = + FunctionLhs + { _funLhsName = sigName', + _funLhsTypeSig = sig', .. } - registerNameSignature (sigName' ^. functionDefName . S.nameId) def + def = + FunctionDef + { _functionDefLhs = lhs', + _functionDefDoc = sigDoc', + _functionDefBody = sigBody', + .. + } + registerNameSignature (sigName' ^. functionDefNameScoped . S.nameId) def registerFunctionDef @$> def where checkBody :: Sem r (FunctionDefBody 'Scoped) - checkBody = case _signBody of + checkBody = case _functionDefBody of SigBodyExpression e -> SigBodyExpression <$> checkParseExpressionAtoms e SigBodyClauses cls -> SigBodyClauses <$> mapM checkClause cls diff --git a/src/Juvix/Compiler/Concrete/Translation/FromSource.hs b/src/Juvix/Compiler/Concrete/Translation/FromSource.hs index 24b48a0af..744a2f17c 100644 --- a/src/Juvix/Compiler/Concrete/Translation/FromSource.hs +++ b/src/Juvix/Compiler/Concrete/Translation/FromSource.hs @@ -1431,31 +1431,26 @@ functionDefinition :: FunctionSyntaxOptions -> Maybe (WithLoc BuiltinFunction) -> ParsecS r (FunctionDef 'Parsed) -functionDefinition opts _signBuiltin = P.label "" $ do +functionDefinition opts _functionDefBuiltin = P.label "" $ do off0 <- P.getOffset - FunctionLhs {..} <- functionDefinitionLhs opts _signBuiltin + lhs <- functionDefinitionLhs opts _functionDefBuiltin off <- P.getOffset - _signDoc <- getJudoc - _signPragmas <- getPragmas - _signBody <- parseBody + _functionDefDoc <- getJudoc + _functionDefPragmas <- getPragmas + _functionDefBody <- parseBody unless - ( isJust (_funLhsTypeSig ^. typeSigColonKw . unIrrelevant) - || (P.isBodyExpression _signBody && null (_funLhsTypeSig ^. typeSigArgs)) + ( isJust (lhs ^. funLhsTypeSig . typeSigColonKw . unIrrelevant) + || (P.isBodyExpression _functionDefBody && null (lhs ^. funLhsTypeSig . typeSigArgs)) ) $ parseFailure off "expected result type" let fdef = FunctionDef - { _signName = _funLhsName, - _signTypeSig = _funLhsTypeSig, - _signTerminating = _funLhsTerminating, - _signInstance = _funLhsInstance, - _signCoercion = _funLhsCoercion, - _signBuiltin = _funLhsBuiltin, - _signDoc, - _signPragmas, - _signBody + { _functionDefLhs = lhs, + _functionDefDoc, + _functionDefPragmas, + _functionDefBody } - when (isNothing (_funLhsName ^? _FunctionDefName) && P.isFunctionLike fdef) $ + when (isNothing (lhs ^? funLhsName . _FunctionDefName) && P.isFunctionLike fdef) $ parseFailure off0 "expected function name" return fdef where diff --git a/src/Juvix/Compiler/Internal/Translation/FromConcrete.hs b/src/Juvix/Compiler/Internal/Translation/FromConcrete.hs index db7e20af5..505f9678b 100644 --- a/src/Juvix/Compiler/Internal/Translation/FromConcrete.hs +++ b/src/Juvix/Compiler/Internal/Translation/FromConcrete.hs @@ -433,7 +433,7 @@ goDeriving :: Sem r Internal.FunctionDef goDeriving Deriving {..} = do let FunctionLhs {..} = _derivingFunLhs - name = goSymbol (_funLhsName ^. functionDefName) + name = goSymbol (_funLhsName ^. functionDefNameScoped) (funArgs, ret) <- Internal.unfoldFunType <$> goDefType _derivingFunLhs let (mtrait, traitArgs) = Internal.unfoldExpressionApp ret (n, der) <- findDerivingTrait mtrait @@ -893,22 +893,22 @@ goFunctionDef :: FunctionDef 'Scoped -> Sem r [Internal.FunctionDef] goFunctionDef def@FunctionDef {..} = do - let _funDefName = goSymbol (_signName ^. functionDefName) - _funDefTerminating = isJust _signTerminating + let _funDefName = goSymbol (def ^. functionDefName . functionDefNameScoped) + _funDefTerminating = isJust (def ^. functionDefTerminating) _funDefIsInstanceCoercion - | isJust _signCoercion = Just Internal.IsInstanceCoercionCoercion - | isJust _signInstance = Just Internal.IsInstanceCoercionInstance + | isJust (def ^. functionDefCoercion) = Just Internal.IsInstanceCoercionCoercion + | isJust (def ^. functionDefInstance) = Just Internal.IsInstanceCoercionInstance | otherwise = Nothing - _funDefCoercion = isJust _signCoercion - _funDefBuiltin = (^. withLocParam) <$> _signBuiltin - _funDefType <- goDefType (functionDefLhs def) - _funDefPragmas <- goPragmas _signPragmas + _funDefCoercion = isJust (def ^. functionDefCoercion) + _funDefBuiltin = (^. withLocParam) <$> (def ^. functionDefBuiltin) + _funDefType <- goDefType (def ^. functionDefLhs) + _funDefPragmas <- goPragmas _functionDefPragmas _funDefBody <- goBody _funDefArgsInfo <- goArgsInfo _funDefName - let _funDefDocComment = fmap ppPrintJudoc _signDoc + let _funDefDocComment = fmap ppPrintJudoc _functionDefDoc fun = Internal.FunctionDef {..} - whenJust _signBuiltin (checkBuiltinFunction fun . (^. withLocParam)) - case _signName ^. functionDefNamePattern of + whenJust (def ^. functionDefBuiltin) (checkBuiltinFunction fun . (^. withLocParam)) + case def ^. functionDefName . functionDefNamePattern of Just pat -> do pat' <- goPatternArg pat (fun :) <$> Internal.genPatternDefs _funDefName pat' @@ -917,14 +917,14 @@ goFunctionDef def@FunctionDef {..} = do where goBody :: Sem r Internal.Expression goBody = do - commonPatterns <- concatMapM (fmap toList . argToPattern) (_signTypeSig ^. typeSigArgs) + commonPatterns <- concatMapM (fmap toList . argToPattern) (def ^. functionDefTypeSig . typeSigArgs) let goClause :: FunctionClause 'Scoped -> Sem r Internal.LambdaClause goClause FunctionClause {..} = do _lambdaBody <- goExpression _clausenBody extraPatterns <- mapM goPatternArg _clausenPatterns let _lambdaPatterns = prependList commonPatterns extraPatterns return Internal.LambdaClause {..} - case _signBody of + case _functionDefBody of SigBodyExpression body -> do body' <- goExpression body return $ case nonEmpty commonPatterns of @@ -1319,7 +1319,7 @@ createArgumentBlocks appargs = where namedArgumentRefSymbol :: NamedArgumentNew 'Scoped -> S.Symbol namedArgumentRefSymbol = \case - NamedArgumentNewFunction p -> p ^. namedArgumentFunctionDef . signName . functionDefName + NamedArgumentNewFunction p -> p ^. namedArgumentFunctionDef . functionDefName . functionDefNameScoped NamedArgumentItemPun p -> over S.nameConcrete fromUnqualified' (p ^. namedArgumentReferencedSymbol . scopedIdenFinal) args0 :: HashSet S.Symbol = hashSet (namedArgumentRefSymbol <$> appargs) goBlock :: @@ -1416,8 +1416,8 @@ goExpression = \case funs ^.. each . namedArgumentFunctionDef - . signName . functionDefName + . functionDefNameScoped . to goSymbol -- changes the kind from Variable to Function updateKind :: Internal.Subs = Internal.subsKind funsNames KNameFunction diff --git a/src/Juvix/Compiler/Pipeline/Package/Loader.hs b/src/Juvix/Compiler/Pipeline/Package/Loader.hs index 7c24a72d3..41ef36dc1 100644 --- a/src/Juvix/Compiler/Pipeline/Package/Loader.hs +++ b/src/Juvix/Compiler/Pipeline/Package/Loader.hs @@ -83,25 +83,29 @@ toConcrete t p = run . runReader l $ do _typeSigRetType <- Just <$> expressionAtoms' (packageTypeIdentifier :| []) name' <- symbol Str.package _typeSigColonKw <- Irrelevant . Just <$> kw kwColon - let _signBody = (t ^. packageDescriptionTypeTransform) p - _signTypeSig = + let _functionDefBody = (t ^. packageDescriptionTypeTransform) p + _funLhsTypeSig = TypeSig { _typeSigArgs = [], _typeSigRetType, _typeSigColonKw } + lhs = + FunctionLhs + { _funLhsTerminating = Nothing, + _funLhsCoercion = Nothing, + _funLhsBuiltin = Nothing, + _funLhsName = FunctionDefName name', + _funLhsInstance = Nothing, + _funLhsTypeSig + } return ( StatementFunctionDef FunctionDef - { _signTerminating = Nothing, - _signPragmas = Nothing, - _signInstance = Nothing, - _signDoc = Nothing, - _signCoercion = Nothing, - _signBuiltin = Nothing, - _signName = FunctionDefName name', - _signBody, - _signTypeSig + { _functionDefPragmas = Nothing, + _functionDefLhs = lhs, + _functionDefDoc = Nothing, + _functionDefBody } )