From 019bc07b35309956e7173fdab2d7d79d49508d83 Mon Sep 17 00:00:00 2001 From: Jan Mas Rovira Date: Fri, 29 Nov 2024 17:58:36 +0100 Subject: [PATCH] make FunctionLhs a field of FunctionDef --- .../Backend/Html/Translation/FromTyped.hs | 2 +- .../Concrete/Data/NameSignature/Builder.hs | 2 +- src/Juvix/Compiler/Concrete/Extra.hs | 2 +- src/Juvix/Compiler/Concrete/Gen.hs | 36 ++++++----- src/Juvix/Compiler/Concrete/Language/Base.hs | 62 ++++++++----------- src/Juvix/Compiler/Concrete/Print/Base.hs | 2 +- .../FromParsed/Analysis/Scoping.hs | 22 ++++--- .../Concrete/Translation/FromSource.hs | 15 ++--- .../Internal/Translation/FromConcrete.hs | 20 +++--- src/Juvix/Compiler/Pipeline/Package/Loader.hs | 22 ++++--- 10 files changed, 93 insertions(+), 92 deletions(-) diff --git a/src/Juvix/Compiler/Backend/Html/Translation/FromTyped.hs b/src/Juvix/Compiler/Backend/Html/Translation/FromTyped.hs index 920469c05e..447b6f286d 100644 --- a/src/Juvix/Compiler/Backend/Html/Translation/FromTyped.hs +++ b/src/Juvix/Compiler/Backend/Html/Translation/FromTyped.hs @@ -545,7 +545,7 @@ goDeriving def = do goFunctionDef :: forall r. (Members '[Reader HtmlOptions] r) => FunctionDef 'Scoped -> Sem r Html goFunctionDef def = do - sig <- ppHelper (ppCode (functionDefLhs def)) + sig <- ppHelper (ppCode (def ^. functionDefLhs)) defHeader (def ^. functionDefName . functionDefNameScoped) sig (def ^. functionDefDoc) goInductive :: forall r. (Members '[Reader HtmlOptions] r) => InductiveDef 'Scoped -> Sem r Html diff --git a/src/Juvix/Compiler/Concrete/Data/NameSignature/Builder.hs b/src/Juvix/Compiler/Concrete/Data/NameSignature/Builder.hs index ace4a4ec24..001dc016e5 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 61bbdd0072..42859b64a3 100644 --- a/src/Juvix/Compiler/Concrete/Extra.hs +++ b/src/Juvix/Compiler/Concrete/Extra.hs @@ -115,4 +115,4 @@ isLhsFunctionLike FunctionLhs {..} = notNull (_funLhsTypeSig ^. typeSigArgs) isFunctionLike :: FunctionDef 'Parsed -> Bool isFunctionLike d@FunctionDef {..} = - isLhsFunctionLike (functionDefLhs d) || (not . isBodyExpression) _functionDefBody + isLhsFunctionLike (d ^. functionDefLhs) || (not . isBodyExpression) _functionDefBody diff --git a/src/Juvix/Compiler/Concrete/Gen.hs b/src/Juvix/Compiler/Concrete/Gen.hs index 2775dda9f6..828f67bfeb 100644 --- a/src/Juvix/Compiler/Concrete/Gen.hs +++ b/src/Juvix/Compiler/Concrete/Gen.hs @@ -26,22 +26,26 @@ simplestFunctionDefParsed funNameTxt funBody = do simplestFunctionDef :: forall s. (SingI s) => FunctionName s -> ExpressionType s -> FunctionDef s simplestFunctionDef funName funBody = - FunctionDef - { _functionDefName = name, - _functionDefBody = SigBodyExpression funBody, - _functionDefTypesig = - TypeSig - { _typeSigColonKw = Irrelevant Nothing, - _typeSigArgs = [], - _typeSigRetType = Nothing - }, - _functionDefDoc = Nothing, - _functionDefPragmas = Nothing, - _functionDefBuiltin = Nothing, - _functionDefTerminating = Nothing, - _functionDefInstance = Nothing, - _functionDefCoercion = 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 diff --git a/src/Juvix/Compiler/Concrete/Language/Base.hs b/src/Juvix/Compiler/Concrete/Language/Base.hs index 8af981974c..a93ebe0e1e 100644 --- a/src/Juvix/Compiler/Concrete/Language/Base.hs +++ b/src/Juvix/Compiler/Concrete/Language/Base.hs @@ -725,27 +725,11 @@ instance Serialize FunctionDefNameScoped instance NFData FunctionDefNameScoped --- functionDefLhs :: FunctionDef s -> FunctionLhs s --- functionDefLhs FunctionDef {..} = --- FunctionLhs --- { _funLhsBuiltin = _functionDefBuiltin, --- _funLhsTerminating = _functionDefTerminating, --- _funLhsInstance = _functionDefInstance, --- _funLhsCoercion = _functionDefCoercion, --- _funLhsName = _signName, --- _funLhsTypeSig = _functionDefTypesig --- } - data FunctionDef (s :: Stage) = FunctionDef - { _functionDefName :: FunctionSymbolType s, - _functionDefTypesig :: TypeSig s, - _functionDefDoc :: Maybe (Judoc s), + { _functionDefDoc :: Maybe (Judoc s), _functionDefPragmas :: Maybe ParsedPragmas, - _functionDefBuiltin :: Maybe (WithLoc BuiltinFunction), - _functionDefBody :: FunctionDefBody s, - _functionDefTerminating :: Maybe KeywordRef, - _functionDefInstance :: Maybe KeywordRef, - _functionDefCoercion :: Maybe KeywordRef + _functionDefLhs :: FunctionLhs s, + _functionDefBody :: FunctionDefBody s } deriving stock (Generic) @@ -3068,16 +3052,23 @@ makePrisms ''NamedArgumentNew makePrisms ''ConstructorRhs makePrisms ''FunctionDefNameParsed -functionDefLhs :: FunctionDef s -> FunctionLhs s -functionDefLhs FunctionDef {..} = - FunctionLhs - { _funLhsBuiltin = _functionDefBuiltin, - _funLhsTerminating = _functionDefTerminating, - _funLhsInstance = _functionDefInstance, - _funLhsCoercion = _functionDefCoercion, - _funLhsName = _functionDefName, - _funLhsTypeSig = _functionDefTypesig - } +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) @@ -3536,12 +3527,13 @@ instance (SingI s) => HasLoc (FunctionDefBody s) where instance (SingI s) => HasLoc (FunctionDef s) where getLoc FunctionDef {..} = - (getLoc <$> _functionDefDoc) - ?<> (getLoc <$> _functionDefPragmas) - ?<> (getLoc <$> _functionDefBuiltin) - ?<> (getLoc <$> _functionDefTerminating) - ?<> (getLocFunctionSymbolType _functionDefName) - <> getLoc _functionDefBody + 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 diff --git a/src/Juvix/Compiler/Concrete/Print/Base.hs b/src/Juvix/Compiler/Concrete/Print/Base.hs index 50148e9674..8f61ac9c28 100644 --- a/src/Juvix/Compiler/Concrete/Print/Base.hs +++ b/src/Juvix/Compiler/Concrete/Print/Base.hs @@ -1207,7 +1207,7 @@ instance (SingI s) => PrettyPrint (FunctionDef s) where ppCode fun@FunctionDef {..} = do let doc' :: Maybe (Sem r ()) = ppCode <$> _functionDefDoc pragmas' :: Maybe (Sem r ()) = ppCode <$> _functionDefPragmas - sig' = ppCode (functionDefLhs fun) + sig' = ppCode (fun ^. functionDefLhs) body' = case _functionDefBody of SigBodyExpression e -> space <> ppCode Kw.kwAssign <> oneLineOrNext (ppTopExpressionType e) SigBodyClauses k -> ppPipeBranches False Top ppFunctionClause k diff --git a/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping.hs b/src/Juvix/Compiler/Concrete/Translation/FromParsed/Analysis/Scoping.hs index 3bbd409adc..901d37ce8b 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) => @@ -1192,18 +1192,19 @@ checkFunctionDef :: FunctionDef 'Parsed -> Sem r (FunctionDef 'Scoped) checkFunctionDef fdef@FunctionDef {..} = do + let FunctionLhs {..} = _functionDefLhs sigDoc' <- mapM checkJudoc _functionDefDoc (sig', sigBody') <- withLocalScope $ do - a' <- checkTypeSig _functionDefTypesig + a' <- checkTypeSig _funLhsTypeSig b' <- checkBody return (a', b') - whenJust (functionSymbolPattern _functionDefName) reservePatternFunctionSymbols - sigName' <- case _functionDefName 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 { _functionDefNameScoped = name', @@ -1217,12 +1218,17 @@ checkFunctionDef fdef@FunctionDef {..} = do { _functionDefNameScoped = name', _functionDefNamePattern = Just p' } - let def = + let lhs' = + FunctionLhs + { _funLhsName = sigName', + _funLhsTypeSig = sig', + .. + } + def = FunctionDef - { _functionDefName = sigName', + { _functionDefLhs = lhs', _functionDefDoc = sigDoc', _functionDefBody = sigBody', - _functionDefTypesig = sig', .. } registerNameSignature (sigName' ^. functionDefNameScoped . S.nameId) def diff --git a/src/Juvix/Compiler/Concrete/Translation/FromSource.hs b/src/Juvix/Compiler/Concrete/Translation/FromSource.hs index 7b9100cbf2..744a2f17c1 100644 --- a/src/Juvix/Compiler/Concrete/Translation/FromSource.hs +++ b/src/Juvix/Compiler/Concrete/Translation/FromSource.hs @@ -1433,29 +1433,24 @@ functionDefinition :: ParsecS r (FunctionDef 'Parsed) functionDefinition opts _functionDefBuiltin = P.label "" $ do off0 <- P.getOffset - FunctionLhs {..} <- functionDefinitionLhs opts _functionDefBuiltin + lhs <- functionDefinitionLhs opts _functionDefBuiltin off <- P.getOffset _functionDefDoc <- getJudoc _functionDefPragmas <- getPragmas _functionDefBody <- parseBody unless - ( isJust (_funLhsTypeSig ^. typeSigColonKw . unIrrelevant) - || (P.isBodyExpression _functionDefBody && null (_funLhsTypeSig ^. typeSigArgs)) + ( isJust (lhs ^. funLhsTypeSig . typeSigColonKw . unIrrelevant) + || (P.isBodyExpression _functionDefBody && null (lhs ^. funLhsTypeSig . typeSigArgs)) ) $ parseFailure off "expected result type" let fdef = FunctionDef - { _functionDefName = _funLhsName, - _functionDefTypesig = _funLhsTypeSig, - _functionDefTerminating = _funLhsTerminating, - _functionDefInstance = _funLhsInstance, - _functionDefCoercion = _funLhsCoercion, - _functionDefBuiltin = _funLhsBuiltin, + { _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 74cf0c73d7..505f9678b1 100644 --- a/src/Juvix/Compiler/Internal/Translation/FromConcrete.hs +++ b/src/Juvix/Compiler/Internal/Translation/FromConcrete.hs @@ -893,22 +893,22 @@ goFunctionDef :: FunctionDef 'Scoped -> Sem r [Internal.FunctionDef] goFunctionDef def@FunctionDef {..} = do - let _funDefName = goSymbol (_functionDefName ^. functionDefNameScoped) - _funDefTerminating = isJust _functionDefTerminating + let _funDefName = goSymbol (def ^. functionDefName . functionDefNameScoped) + _funDefTerminating = isJust (def ^. functionDefTerminating) _funDefIsInstanceCoercion - | isJust _functionDefCoercion = Just Internal.IsInstanceCoercionCoercion - | isJust _functionDefInstance = Just Internal.IsInstanceCoercionInstance + | isJust (def ^. functionDefCoercion) = Just Internal.IsInstanceCoercionCoercion + | isJust (def ^. functionDefInstance) = Just Internal.IsInstanceCoercionInstance | otherwise = Nothing - _funDefCoercion = isJust _functionDefCoercion - _funDefBuiltin = (^. withLocParam) <$> _functionDefBuiltin - _funDefType <- goDefType (functionDefLhs def) + _funDefCoercion = isJust (def ^. functionDefCoercion) + _funDefBuiltin = (^. withLocParam) <$> (def ^. functionDefBuiltin) + _funDefType <- goDefType (def ^. functionDefLhs) _funDefPragmas <- goPragmas _functionDefPragmas _funDefBody <- goBody _funDefArgsInfo <- goArgsInfo _funDefName let _funDefDocComment = fmap ppPrintJudoc _functionDefDoc fun = Internal.FunctionDef {..} - whenJust _functionDefBuiltin (checkBuiltinFunction fun . (^. withLocParam)) - case _functionDefName ^. 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,7 +917,7 @@ goFunctionDef def@FunctionDef {..} = do where goBody :: Sem r Internal.Expression goBody = do - commonPatterns <- concatMapM (fmap toList . argToPattern) (_functionDefTypesig ^. typeSigArgs) + commonPatterns <- concatMapM (fmap toList . argToPattern) (def ^. functionDefTypeSig . typeSigArgs) let goClause :: FunctionClause 'Scoped -> Sem r Internal.LambdaClause goClause FunctionClause {..} = do _lambdaBody <- goExpression _clausenBody diff --git a/src/Juvix/Compiler/Pipeline/Package/Loader.hs b/src/Juvix/Compiler/Pipeline/Package/Loader.hs index 237aa6d397..41ef36dc1b 100644 --- a/src/Juvix/Compiler/Pipeline/Package/Loader.hs +++ b/src/Juvix/Compiler/Pipeline/Package/Loader.hs @@ -84,24 +84,28 @@ toConcrete t p = run . runReader l $ do name' <- symbol Str.package _typeSigColonKw <- Irrelevant . Just <$> kw kwColon let _functionDefBody = (t ^. packageDescriptionTypeTransform) p - _functionDefTypesig = + _funLhsTypeSig = TypeSig { _typeSigArgs = [], _typeSigRetType, _typeSigColonKw } + lhs = + FunctionLhs + { _funLhsTerminating = Nothing, + _funLhsCoercion = Nothing, + _funLhsBuiltin = Nothing, + _funLhsName = FunctionDefName name', + _funLhsInstance = Nothing, + _funLhsTypeSig + } return ( StatementFunctionDef FunctionDef - { _functionDefTerminating = Nothing, - _functionDefPragmas = Nothing, - _functionDefInstance = Nothing, + { _functionDefPragmas = Nothing, + _functionDefLhs = lhs, _functionDefDoc = Nothing, - _functionDefCoercion = Nothing, - _functionDefBuiltin = Nothing, - _functionDefName = FunctionDefName name', - _functionDefBody, - _functionDefTypesig + _functionDefBody } )