make FunctionLhs a field of FunctionDef

anoma · Nov 29, 2024 · bb40dc1 · bb40dc1
1 parent 535d32f
commit bb40dc1
Show file tree

Hide file tree

Showing 10 changed files with 93 additions and 92 deletions.
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -1433,29 +1433,24 @@ functionDefinition ::
   ParsecS r (FunctionDef 'Parsed)
 functionDefinition opts _functionDefBuiltin = P.label "<function definition>" $ 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
@@ -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
@@ -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
               }
         )