1
1
mirror of https://github.com/anoma/juvix.git synced 2024-12-11 08:25:46 +03:00

Make FunctionLhs a field of FunctionDef (#3202)

This commit is contained in:
Jan Mas Rovira 2024-12-01 16:34:27 +01:00 committed by GitHub
parent ad0333467b
commit 5fea31eec6
No known key found for this signature in database
GPG Key ID: B5690EEEBB952194
13 changed files with 136 additions and 124 deletions

View File

@ -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

View File

@ -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

View File

@ -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)

View File

@ -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 ::

View File

@ -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

View File

@ -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
}

View File

@ -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)

View File

@ -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

View File

@ -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'

View File

@ -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

View File

@ -1431,31 +1431,26 @@ functionDefinition ::
FunctionSyntaxOptions ->
Maybe (WithLoc BuiltinFunction) ->
ParsecS r (FunctionDef 'Parsed)
functionDefinition opts _signBuiltin = P.label "<function definition>" $ do
functionDefinition opts _functionDefBuiltin = P.label "<function definition>" $ 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

View File

@ -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

View File

@ -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
}
)