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:
parent
ad0333467b
commit
5fea31eec6
@ -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
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
@ -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 ::
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
}
|
||||
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
@ -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'
|
||||
|
@ -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
|
||||
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
}
|
||||
)
|
||||
|
||||
|
Loading…
Reference in New Issue
Block a user