mirror of
https://github.com/anoma/juvix.git
synced 2024-12-12 14:28:08 +03:00
Remove dead code in Internal (#1891)
- This has become dead code after #1862
This commit is contained in:
janmasrovira
GitHub
parent
1eadbc4f81
commit
e9672e6d09
@ -10,214 +10,14 @@ import Juvix.Compiler.Internal.Data.LocalVars
|
||||
import Juvix.Compiler.Internal.Language
|
||||
import Juvix.Prelude
|
||||
|
||||
data Caller
|
||||
= CallerInductive InductiveName
|
||||
| CallerFunction FunctionName
|
||||
| CallerAxiom AxiomName
|
||||
deriving stock (Eq, Ord, Generic)
|
||||
|
||||
data TypeCallIden
|
||||
= InductiveIden InductiveName
|
||||
| FunctionIden FunctionName
|
||||
deriving stock (Eq, Ord, Generic)
|
||||
|
||||
data TypeCall' a = TypeCall'
|
||||
{ _typeCallIden :: TypeCallIden,
|
||||
_typeCallArguments :: NonEmpty a
|
||||
}
|
||||
deriving stock (Eq, Generic)
|
||||
|
||||
newtype TypeCallsMap = TypeCallsMap
|
||||
{ _typeCallsMap :: HashMap Caller (HashSet TypeCall)
|
||||
}
|
||||
|
||||
instance Functor TypeCall' where
|
||||
fmap f (TypeCall' i args) = TypeCall' i (fmap f args)
|
||||
|
||||
newtype ConcreteType = ConcreteType {_unconcreteType :: Expression}
|
||||
deriving stock (Eq, Generic)
|
||||
|
||||
type ConcreteTypeCall = TypeCall' ConcreteType
|
||||
|
||||
type TypeCall = TypeCall' Expression
|
||||
|
||||
type SubsE = HashMap VarName Expression
|
||||
|
||||
type Rename = HashMap VarName VarName
|
||||
|
||||
type Subs = HashMap VarName Expression
|
||||
|
||||
type ConcreteSubs = HashMap VarName ConcreteType
|
||||
|
||||
-- | Indexed by _typeCallIden
|
||||
newtype TypeCalls = TypeCalls
|
||||
{ _typeCallSet :: HashMap TypeCallIden (HashMap ConcreteTypeCall ConcreteSubs)
|
||||
}
|
||||
|
||||
type VarMap = HashMap VarName VarName
|
||||
|
||||
emptyCalls :: TypeCalls
|
||||
emptyCalls = TypeCalls mempty
|
||||
|
||||
instance Hashable TypeCallIden
|
||||
|
||||
instance Hashable TypeCall
|
||||
|
||||
instance Hashable Caller
|
||||
|
||||
instance Hashable ConcreteTypeCall
|
||||
|
||||
instance Hashable ConcreteType
|
||||
|
||||
makeLenses ''TypeCalls
|
||||
makeLenses ''TypeCall'
|
||||
makeLenses ''TypeCallsMap
|
||||
makeLenses ''ConcreteType
|
||||
|
||||
typeCallIdenToCaller :: TypeCallIden -> Caller
|
||||
typeCallIdenToCaller = \case
|
||||
InductiveIden i -> CallerInductive i
|
||||
FunctionIden i -> CallerFunction i
|
||||
|
||||
mkConcreteType' :: Expression -> ConcreteType
|
||||
mkConcreteType' =
|
||||
fromMaybe (error "the given type is not concrete")
|
||||
. mkConcreteType
|
||||
|
||||
-- TODO: consider using traversals to simplify
|
||||
mkConcreteType :: Expression -> Maybe ConcreteType
|
||||
mkConcreteType = fmap ConcreteType . go
|
||||
where
|
||||
go :: Expression -> Maybe Expression
|
||||
go t = case t of
|
||||
ExpressionApplication (Application l r i) -> do
|
||||
l' <- go l
|
||||
r' <- go r
|
||||
return (ExpressionApplication (Application l' r' i))
|
||||
ExpressionUniverse {} -> return t
|
||||
ExpressionLet l -> ExpressionLet <$> goLet l
|
||||
ExpressionCase l -> ExpressionCase <$> goCase l
|
||||
ExpressionSimpleLambda (SimpleLambda v ty b) -> do
|
||||
b' <- go b
|
||||
ty' <- go ty
|
||||
return (ExpressionSimpleLambda (SimpleLambda v ty' b'))
|
||||
ExpressionLambda (Lambda c ty) -> do
|
||||
let _lambdaType = ty >>= go
|
||||
_lambdaClauses <- mapM goClause c
|
||||
return (ExpressionLambda Lambda {..})
|
||||
ExpressionFunction (Function l r) -> do
|
||||
l' <- goParam l
|
||||
r' <- go r
|
||||
return (ExpressionFunction (Function l' r'))
|
||||
ExpressionHole {} -> Nothing
|
||||
ExpressionLiteral {} -> return t
|
||||
ExpressionIden i -> case i of
|
||||
IdenFunction {} -> return t
|
||||
IdenInductive {} -> return t
|
||||
IdenConstructor {} -> return t
|
||||
IdenAxiom {} -> return t
|
||||
IdenVar {} -> Nothing
|
||||
|
||||
goClause :: LambdaClause -> Maybe LambdaClause
|
||||
goClause (LambdaClause ps b) = do
|
||||
b' <- go b
|
||||
return (LambdaClause ps b')
|
||||
|
||||
goParam :: FunctionParameter -> Maybe FunctionParameter
|
||||
goParam (FunctionParameter m i e) = do
|
||||
guard (isNothing m)
|
||||
e' <- go e
|
||||
return (FunctionParameter m i e')
|
||||
|
||||
goCase :: Case -> Maybe Case
|
||||
goCase =
|
||||
traverseOf (caseBranches . each) goCaseBranch
|
||||
>=> traverseOf caseExpression go
|
||||
|
||||
goCaseBranch :: CaseBranch -> Maybe CaseBranch
|
||||
goCaseBranch = traverseOf caseBranchExpression go
|
||||
|
||||
goLet :: Let -> Maybe Let
|
||||
goLet =
|
||||
traverseOf (letClauses . each) goLetClause
|
||||
>=> traverseOf letExpression go
|
||||
|
||||
goLetClause :: LetClause -> Maybe LetClause
|
||||
goLetClause = \case
|
||||
LetFunDef f -> LetFunDef <$> goFunctionDef f
|
||||
|
||||
goFunctionDef :: FunctionDef -> Maybe FunctionDef
|
||||
goFunctionDef f = do
|
||||
let _funDefName = f ^. funDefName
|
||||
_funDefBuiltin = f ^. funDefBuiltin
|
||||
_funDefExamples <- mapM goExample (f ^. funDefExamples)
|
||||
_funDefClauses <- mapM goFunctionClause (f ^. funDefClauses)
|
||||
_funDefType <- go (f ^. funDefType)
|
||||
return FunctionDef {..}
|
||||
|
||||
goFunctionClause :: FunctionClause -> Maybe FunctionClause
|
||||
goFunctionClause c = do
|
||||
let _clauseName = c ^. clauseName
|
||||
_clausePatterns = c ^. clausePatterns
|
||||
_clauseBody <- go (c ^. clauseBody)
|
||||
return FunctionClause {..}
|
||||
|
||||
goExample :: Example -> Maybe Example
|
||||
goExample = traverseOf exampleExpression go
|
||||
|
||||
newtype PolyType = PolyType {_unpolyType :: Expression}
|
||||
deriving stock (Eq, Generic)
|
||||
|
||||
instance Hashable PolyType
|
||||
|
||||
makeLenses ''PolyType
|
||||
|
||||
mkPolyType' :: Expression -> PolyType
|
||||
mkPolyType' =
|
||||
fromMaybe (error "the given type contains holes")
|
||||
. mkPolyType
|
||||
|
||||
-- | mkPolyType removes all named function parameters; currently the assumption in
|
||||
-- InternalToMiniC.hs is that these coincide with type parameters
|
||||
mkPolyType :: Expression -> Maybe PolyType
|
||||
mkPolyType = fmap PolyType . go
|
||||
where
|
||||
go :: Expression -> Maybe Expression
|
||||
go t = case t of
|
||||
ExpressionApplication (Application l r i) -> do
|
||||
l' <- go l
|
||||
r' <- go r
|
||||
return (ExpressionApplication (Application l' r' i))
|
||||
ExpressionUniverse {} -> return t
|
||||
ExpressionFunction (Function (FunctionParameter m i e) r)
|
||||
| isNothing m -> do
|
||||
e' <- go e
|
||||
r' <- go r
|
||||
return (ExpressionFunction (Function (FunctionParameter m i e') r'))
|
||||
| otherwise -> go r
|
||||
ExpressionHole {} -> Nothing
|
||||
ExpressionLiteral {} -> return t
|
||||
ExpressionLet {} -> error "Lets are not supported in the old backend"
|
||||
ExpressionCase {} -> error "Cases are not supported in the old backend"
|
||||
ExpressionIden IdenFunction {} -> return t
|
||||
ExpressionIden IdenInductive {} -> return t
|
||||
ExpressionIden IdenConstructor {} -> return t
|
||||
ExpressionIden IdenAxiom {} -> return t
|
||||
ExpressionIden IdenVar {} -> return t
|
||||
ExpressionLambda (Lambda c ty) -> do
|
||||
let _lambdaType = ty >>= go
|
||||
_lambdaClauses <- mapM goClause c
|
||||
return (ExpressionLambda Lambda {..})
|
||||
ExpressionSimpleLambda (SimpleLambda v ty b) -> do
|
||||
b' <- go b
|
||||
ty' <- go ty
|
||||
return (ExpressionSimpleLambda (SimpleLambda v ty' b'))
|
||||
where
|
||||
goClause :: LambdaClause -> Maybe LambdaClause
|
||||
goClause (LambdaClause ps b) = do
|
||||
b' <- go b
|
||||
return (LambdaClause ps b')
|
||||
|
||||
class HasExpressions a where
|
||||
leafExpressions :: Traversal' a Expression
|
||||
|
||||
@ -417,9 +217,6 @@ unnamedParameter ty =
|
||||
renameToSubsE :: Rename -> SubsE
|
||||
renameToSubsE = fmap (ExpressionIden . IdenVar)
|
||||
|
||||
renameExpression :: Rename -> Expression -> Expression
|
||||
renameExpression r = substitutionE (renameToSubsE r)
|
||||
|
||||
patternArgVariables :: Traversal' PatternArg VarName
|
||||
patternArgVariables f (PatternArg i n p) = PatternArg i <$> traverse f n <*> patternVariables f p
|
||||
|
||||
@ -431,17 +228,6 @@ patternVariables f p = case p of
|
||||
goApp :: Traversal' ConstructorApp VarName
|
||||
goApp g = traverseOf constrAppParameters (traverse (patternArgVariables g))
|
||||
|
||||
renamePatternArg :: Rename -> PatternArg -> PatternArg
|
||||
renamePatternArg = over patternArgPattern . renamePattern
|
||||
|
||||
renamePattern :: Rename -> Pattern -> Pattern
|
||||
renamePattern m = over patternVariables renameVar
|
||||
where
|
||||
renameVar :: VarName -> VarName
|
||||
renameVar v
|
||||
| Just v' <- m ^. at v = v'
|
||||
| otherwise = v
|
||||
|
||||
inductiveTypeVarsAssoc :: (Foldable f) => InductiveDef -> f a -> HashMap VarName a
|
||||
inductiveTypeVarsAssoc def l
|
||||
| length vars < n = impossible
|
||||
@ -451,15 +237,6 @@ inductiveTypeVarsAssoc def l
|
||||
vars :: [VarName]
|
||||
vars = def ^.. inductiveParameters . each . inductiveParamName
|
||||
|
||||
substitutionConcrete :: ConcreteSubs -> Expression -> ConcreteType
|
||||
substitutionConcrete m = mkConcreteType' . substitutionE ((^. unconcreteType) <$> m)
|
||||
|
||||
concreteTypeToExpr :: ConcreteType -> Expression
|
||||
concreteTypeToExpr = (^. unconcreteType)
|
||||
|
||||
concreteSubsToSubsE :: ConcreteSubs -> SubsE
|
||||
concreteSubsToSubsE = fmap concreteTypeToExpr
|
||||
|
||||
substitutionApp :: (Maybe Name, Expression) -> Expression -> Expression
|
||||
substitutionApp (mv, ty) = case mv of
|
||||
Nothing -> id
|
||||
|
||||
@ -5,7 +5,6 @@ module Juvix.Compiler.Internal.Pretty.Base
|
||||
)
|
||||
where
|
||||
|
||||
import Data.HashMap.Strict qualified as HashMap
|
||||
import Juvix.Compiler.Internal.Extra
|
||||
import Juvix.Compiler.Internal.Pretty.Options
|
||||
import Juvix.Data.CodeAnn
|
||||
@ -234,48 +233,6 @@ instance PrettyCode Module where
|
||||
<> body'
|
||||
<> line
|
||||
|
||||
instance PrettyCode TypeCallIden where
|
||||
ppCode = \case
|
||||
InductiveIden n -> ppCode n
|
||||
FunctionIden n -> ppCode n
|
||||
|
||||
instance PrettyCode Caller where
|
||||
ppCode = \case
|
||||
CallerInductive n -> ppCode n
|
||||
CallerAxiom n -> ppCode n
|
||||
CallerFunction n -> ppCode n
|
||||
|
||||
instance PrettyCode ConcreteTypeCall where
|
||||
ppCode = ppCode . fmap (^. unconcreteType)
|
||||
|
||||
instance PrettyCode TypeCall where
|
||||
ppCode (TypeCall' f args) = do
|
||||
f' <- ppCode f
|
||||
args' <- mapM ppCodeAtom args
|
||||
return $ f' <+> hsep args'
|
||||
|
||||
instance PrettyCode TypeCallsMap where
|
||||
ppCode m = do
|
||||
let title = keyword "Type Calls Map:"
|
||||
elems :: [(Caller, TypeCall)]
|
||||
elems =
|
||||
[(caller, t) | (caller, l) <- HashMap.toList (m ^. typeCallsMap), t <- toList l]
|
||||
elems' <- mapM ppCodeElem (sortOn fst elems)
|
||||
return $ title <> line <> vsep elems' <> line
|
||||
where
|
||||
ppCodeElem :: (Member (Reader Options) r) => (Caller, TypeCall) -> Sem r (Doc Ann)
|
||||
ppCodeElem (caller, t) = do
|
||||
caller' <- ppCode caller
|
||||
t' <- ppCode t
|
||||
return $ caller' <+> kwMapsto <+> t'
|
||||
|
||||
instance PrettyCode TypeCalls where
|
||||
ppCode m = do
|
||||
let title = keyword "Propagated Type Calls:"
|
||||
elems = sortOn (^. typeCallIden) (concatMap HashMap.keys (toList (m ^. typeCallSet)))
|
||||
elems' <- mapM ppCode elems
|
||||
return $ title <> line <> vsep elems' <> line
|
||||
|
||||
ppPostExpression ::
|
||||
(PrettyCode a, HasAtomicity a, Member (Reader Options) r) =>
|
||||
Fixity ->
|
||||
@ -330,6 +287,3 @@ instance (PrettyCode a) => PrettyCode [a] where
|
||||
|
||||
instance (PrettyCode a) => PrettyCode (NonEmpty a) where
|
||||
ppCode x = ppCode (toList x)
|
||||
|
||||
instance PrettyCode ConcreteType where
|
||||
ppCode ConcreteType {..} = ppCode _unconcreteType
|
||||
|
||||
Loading…
Reference in New Issue
Block a user