mirror of
https://github.com/anoma/juvix.git
synced 2024-09-11 16:26:33 +03:00
parent
235d88f303
commit
33d565037d
@ -99,10 +99,13 @@ getInfoMain Module {..} =
|
||||
<|> _moduleImportsTable ^. infoMain
|
||||
|
||||
identName :: Module -> Symbol -> Text
|
||||
identName m = identName' (computeCombinedInfoTable m)
|
||||
identName md sym = lookupIdentifierInfo md sym ^. identifierName
|
||||
|
||||
typeName :: Module -> Symbol -> Text
|
||||
typeName m = typeName' (computeCombinedInfoTable m)
|
||||
typeName md sym = lookupInductiveInfo md sym ^. inductiveName
|
||||
|
||||
constrName :: Module -> Tag -> Text
|
||||
constrName md tag = lookupConstructorInfo md tag ^. constructorName
|
||||
|
||||
identNames :: Module -> HashSet Text
|
||||
identNames m = identNames' (computeCombinedInfoTable m)
|
||||
|
@ -16,6 +16,8 @@ disambiguateNodeNames' disambiguate md = dmapL go
|
||||
mkVar (setInfoName (BL.lookup _varIndex bl ^. binderName) _varInfo) _varIndex
|
||||
NIdt Ident {..} ->
|
||||
mkIdent (setInfoName (identName md _identSymbol) _identInfo) _identSymbol
|
||||
NCtr Constr {..} ->
|
||||
mkConstr (setInfoName (constrName md _constrTag) _constrInfo) _constrTag _constrArgs
|
||||
NLam lam ->
|
||||
NLam (over lambdaBinder (over binderName (disambiguate bl)) lam)
|
||||
NLet lt ->
|
||||
@ -35,7 +37,18 @@ disambiguateNodeNames' disambiguate md = dmapL go
|
||||
where
|
||||
vs = toList (lt ^. letRecValues)
|
||||
NCase c ->
|
||||
NCase (over caseBranches (map (over caseBranchBinders (disambiguateBinders bl))) c)
|
||||
NCase
|
||||
( over
|
||||
caseBranches
|
||||
( map
|
||||
( \br ->
|
||||
over caseBranchInfo (setInfoName (constrName md (br ^. caseBranchTag)))
|
||||
. over caseBranchBinders (disambiguateBinders bl)
|
||||
$ br
|
||||
)
|
||||
)
|
||||
c
|
||||
)
|
||||
NMatch m ->
|
||||
NMatch (over matchBranches (map (over matchBranchPatterns (NonEmpty.fromList . snd . disambiguatePatterns bl . toList))) m)
|
||||
NTyp TypeConstr {..} ->
|
||||
@ -64,7 +77,12 @@ disambiguateNodeNames' disambiguate md = dmapL go
|
||||
where
|
||||
b' = over binderName (disambiguate bl) (c ^. patternConstrBinder)
|
||||
(bl', args') = disambiguatePatterns (BL.cons b' bl) (c ^. patternConstrArgs)
|
||||
pat' = PatConstr $ set patternConstrBinder b' $ set patternConstrArgs args' c
|
||||
pat' =
|
||||
PatConstr
|
||||
. set patternConstrBinder b'
|
||||
. set patternConstrArgs args'
|
||||
. over patternConstrInfo (setInfoName (constrName md (c ^. patternConstrTag)))
|
||||
$ c
|
||||
|
||||
disambiguateNodeNames :: Module -> Node -> Node
|
||||
disambiguateNodeNames md = disambiguateNodeNames' disambiguate md
|
||||
|
@ -43,12 +43,12 @@ varFromHole h =
|
||||
_nameFixity = Nothing
|
||||
}
|
||||
where
|
||||
pp = "_ω" <> prettyText (h ^. holeId)
|
||||
pp :: Text = "_ω"
|
||||
|
||||
varFromWildcard :: (Members '[NameIdGen] r) => Wildcard -> Sem r VarName
|
||||
varFromWildcard w = do
|
||||
_nameId <- freshNameId
|
||||
let _nameText :: Text = "_ω" <> prettyText _nameId
|
||||
let _nameText :: Text = "_ω"
|
||||
_nameKind = KNameLocal
|
||||
_nameKindPretty = KNameLocal
|
||||
_namePretty = _nameText
|
||||
|
@ -461,8 +461,8 @@ goFunctionDef FunctionDef {..} = do
|
||||
argToPattern arg@SigArg {..} = do
|
||||
let _patternArgIsImplicit = _sigArgImplicit
|
||||
_patternArgName :: Maybe Internal.Name = Nothing
|
||||
noName = goWidlcard (Wildcard (getLoc arg))
|
||||
goWidlcard w = do
|
||||
noName = goWildcard (Wildcard (getLoc arg))
|
||||
goWildcard w = do
|
||||
_patternArgPattern <- Internal.PatternVariable <$> varFromWildcard w
|
||||
return Internal.PatternArg {..}
|
||||
mk :: Concrete.Argument 'Scoped -> Sem r Internal.PatternArg
|
||||
@ -470,7 +470,7 @@ goFunctionDef FunctionDef {..} = do
|
||||
Concrete.ArgumentSymbol s ->
|
||||
let _patternArgPattern = Internal.PatternVariable (goSymbol s)
|
||||
in return Internal.PatternArg {..}
|
||||
Concrete.ArgumentWildcard w -> goWidlcard w
|
||||
Concrete.ArgumentWildcard w -> goWildcard w
|
||||
maybe (pure <$> noName) (mapM mk) (nonEmpty _sigArgNames)
|
||||
|
||||
goInductiveParameters ::
|
||||
|
Loading…
Reference in New Issue
Block a user