mirror of
https://github.com/anoma/juvix.git
synced 2024-12-01 00:04:58 +03:00
Curly braces are allowed nested in patterns (#1380)
This commit is contained in:
parent
30ae6c76c4
commit
a8f4acaca2
@ -60,7 +60,7 @@ data FunctionDef = FunctionDef
|
|||||||
|
|
||||||
data FunctionClause = FunctionClause
|
data FunctionClause = FunctionClause
|
||||||
{ _clauseName :: FunctionName,
|
{ _clauseName :: FunctionName,
|
||||||
_clausePatterns :: [Pattern],
|
_clausePatterns :: [PatternArg],
|
||||||
_clauseBody :: Expression
|
_clauseBody :: Expression
|
||||||
}
|
}
|
||||||
deriving stock (Eq, Show)
|
deriving stock (Eq, Show)
|
||||||
@ -152,7 +152,13 @@ instance HasAtomicity Function where
|
|||||||
-- | Fully applied constructor in a pattern.
|
-- | Fully applied constructor in a pattern.
|
||||||
data ConstructorApp = ConstructorApp
|
data ConstructorApp = ConstructorApp
|
||||||
{ _constrAppConstructor :: ConstructorRef,
|
{ _constrAppConstructor :: ConstructorRef,
|
||||||
_constrAppParameters :: [Pattern]
|
_constrAppParameters :: [PatternArg]
|
||||||
|
}
|
||||||
|
deriving stock (Eq, Show)
|
||||||
|
|
||||||
|
data PatternArg = PatternArg
|
||||||
|
{ _patternArgIsImplicit :: IsImplicit,
|
||||||
|
_patternArgPattern :: Pattern
|
||||||
}
|
}
|
||||||
deriving stock (Eq, Show)
|
deriving stock (Eq, Show)
|
||||||
|
|
||||||
@ -161,7 +167,6 @@ data Pattern
|
|||||||
| PatternConstructorApp ConstructorApp
|
| PatternConstructorApp ConstructorApp
|
||||||
| PatternWildcard Wildcard
|
| PatternWildcard Wildcard
|
||||||
| PatternEmpty
|
| PatternEmpty
|
||||||
| PatternBraces Pattern
|
|
||||||
deriving stock (Eq, Show)
|
deriving stock (Eq, Show)
|
||||||
|
|
||||||
data InductiveDef = InductiveDef
|
data InductiveDef = InductiveDef
|
||||||
@ -187,6 +192,7 @@ data AxiomDef = AxiomDef
|
|||||||
deriving stock (Eq, Show)
|
deriving stock (Eq, Show)
|
||||||
|
|
||||||
makeLenses ''Module
|
makeLenses ''Module
|
||||||
|
makeLenses ''PatternArg
|
||||||
makeLenses ''FunctionParameter
|
makeLenses ''FunctionParameter
|
||||||
makeLenses ''Function
|
makeLenses ''Function
|
||||||
makeLenses ''FunctionDef
|
makeLenses ''FunctionDef
|
||||||
|
@ -17,16 +17,18 @@ data ApplicationArg = ApplicationArg
|
|||||||
|
|
||||||
makeLenses ''ApplicationArg
|
makeLenses ''ApplicationArg
|
||||||
|
|
||||||
patternVariables :: Pattern -> [VarName]
|
patternVariables :: Traversal' Pattern VarName
|
||||||
patternVariables = \case
|
patternVariables f p = case p of
|
||||||
PatternVariable v -> [v]
|
PatternVariable v -> PatternVariable <$> f v
|
||||||
PatternWildcard {} -> []
|
PatternWildcard {} -> pure p
|
||||||
PatternEmpty {} -> []
|
PatternEmpty {} -> pure p
|
||||||
PatternBraces b -> patternVariables b
|
PatternConstructorApp app -> PatternConstructorApp <$> appVariables f app
|
||||||
PatternConstructorApp app -> appVariables app
|
|
||||||
|
|
||||||
appVariables :: ConstructorApp -> [VarName]
|
patternArgVariables :: Traversal' PatternArg VarName
|
||||||
appVariables (ConstructorApp _ ps) = concatMap patternVariables ps
|
patternArgVariables f = traverseOf patternArgPattern (patternVariables f)
|
||||||
|
|
||||||
|
appVariables :: Traversal' ConstructorApp VarName
|
||||||
|
appVariables f = traverseOf constrAppParameters (traverse (patternArgVariables f))
|
||||||
|
|
||||||
idenName :: Iden -> Name
|
idenName :: Iden -> Name
|
||||||
idenName = \case
|
idenName = \case
|
||||||
@ -36,25 +38,35 @@ idenName = \case
|
|||||||
IdenInductive (InductiveRef i) -> i
|
IdenInductive (InductiveRef i) -> i
|
||||||
IdenAxiom (AxiomRef a) -> a
|
IdenAxiom (AxiomRef a) -> a
|
||||||
|
|
||||||
smallerPatternVariables :: Pattern -> [VarName]
|
smallerPatternVariables :: Traversal' Pattern VarName
|
||||||
smallerPatternVariables = \case
|
smallerPatternVariables f p = case p of
|
||||||
PatternVariable {} -> []
|
PatternVariable {} -> pure p
|
||||||
PatternBraces b -> smallerPatternVariables b
|
PatternWildcard {} -> pure p
|
||||||
PatternWildcard {} -> []
|
PatternEmpty {} -> pure p
|
||||||
PatternEmpty {} -> []
|
PatternConstructorApp app -> PatternConstructorApp <$> appVariables f app
|
||||||
PatternConstructorApp app -> appVariables app
|
|
||||||
|
|
||||||
viewApp :: Expression -> (Expression, [Expression])
|
viewApp :: Expression -> (Expression, [ApplicationArg])
|
||||||
viewApp e = case e of
|
viewApp e =
|
||||||
ExpressionApplication (Application l r _) ->
|
case e of
|
||||||
second (`snoc` r) (viewApp l)
|
ExpressionApplication (Application l r i) ->
|
||||||
_ -> (e, [])
|
second (`snoc` ApplicationArg i r) (viewApp l)
|
||||||
|
_ -> (e, [])
|
||||||
|
|
||||||
|
viewAppArgAsPattern :: ApplicationArg -> Maybe PatternArg
|
||||||
|
viewAppArgAsPattern a = do
|
||||||
|
p' <- viewExpressionAsPattern (a ^. appArg)
|
||||||
|
return
|
||||||
|
( PatternArg
|
||||||
|
{ _patternArgIsImplicit = a ^. appArgIsImplicit,
|
||||||
|
_patternArgPattern = p'
|
||||||
|
}
|
||||||
|
)
|
||||||
|
|
||||||
viewExpressionAsPattern :: Expression -> Maybe Pattern
|
viewExpressionAsPattern :: Expression -> Maybe Pattern
|
||||||
viewExpressionAsPattern e = case viewApp e of
|
viewExpressionAsPattern e = case viewApp e of
|
||||||
(f, args)
|
(f, args)
|
||||||
| Just c <- getConstructor f -> do
|
| Just c <- getConstructor f -> do
|
||||||
args' <- mapM viewExpressionAsPattern args
|
args' <- mapM viewAppArgAsPattern args
|
||||||
Just $ PatternConstructorApp (ConstructorApp c args')
|
Just $ PatternConstructorApp (ConstructorApp c args')
|
||||||
(f, [])
|
(f, [])
|
||||||
| Just v <- getVariable f -> Just (PatternVariable v)
|
| Just v <- getVariable f -> Just (PatternVariable v)
|
||||||
@ -200,13 +212,16 @@ isSmallUniverse' = \case
|
|||||||
ExpressionUniverse u -> isSmallUniverse u
|
ExpressionUniverse u -> isSmallUniverse u
|
||||||
_ -> False
|
_ -> False
|
||||||
|
|
||||||
toApplicationArg :: Pattern -> ApplicationArg
|
toApplicationArg :: PatternArg -> ApplicationArg
|
||||||
toApplicationArg = \case
|
toApplicationArg p =
|
||||||
PatternVariable v -> ApplicationArg Explicit (toExpression v)
|
set appArgIsImplicit (p ^. patternArgIsImplicit) (helper (p ^. patternArgPattern))
|
||||||
PatternConstructorApp a -> ApplicationArg Explicit (toExpression a)
|
where
|
||||||
PatternEmpty -> impossible
|
helper :: Pattern -> ApplicationArg
|
||||||
PatternBraces p -> set appArgIsImplicit Implicit (toApplicationArg p)
|
helper = \case
|
||||||
PatternWildcard _ -> error "TODO"
|
PatternVariable v -> ApplicationArg Explicit (toExpression v)
|
||||||
|
PatternConstructorApp a -> ApplicationArg Explicit (toExpression a)
|
||||||
|
PatternEmpty -> impossible
|
||||||
|
PatternWildcard _ -> error "TODO"
|
||||||
|
|
||||||
clauseLhsAsExpression :: FunctionClause -> Expression
|
clauseLhsAsExpression :: FunctionClause -> Expression
|
||||||
clauseLhsAsExpression cl =
|
clauseLhsAsExpression cl =
|
||||||
|
@ -83,7 +83,7 @@ type family ExpressionType s = res | res -> s where
|
|||||||
type PatternType :: Stage -> GHC.Type
|
type PatternType :: Stage -> GHC.Type
|
||||||
type family PatternType s = res | res -> s where
|
type family PatternType s = res | res -> s where
|
||||||
PatternType 'Parsed = PatternAtom 'Parsed
|
PatternType 'Parsed = PatternAtom 'Parsed
|
||||||
PatternType 'Scoped = Pattern
|
PatternType 'Scoped = PatternArg
|
||||||
|
|
||||||
type family ImportType (s :: Stage) :: GHC.Type where
|
type family ImportType (s :: Stage) :: GHC.Type where
|
||||||
ImportType 'Parsed = TopModulePath
|
ImportType 'Parsed = TopModulePath
|
||||||
@ -257,15 +257,15 @@ deriving stock instance (Ord (ExpressionType s), Ord (SymbolType s)) => Ord (Ind
|
|||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
data PatternApp = PatternApp
|
data PatternApp = PatternApp
|
||||||
{ _patAppLeft :: Pattern,
|
{ _patAppLeft :: PatternArg,
|
||||||
_patAppRight :: Pattern
|
_patAppRight :: PatternArg
|
||||||
}
|
}
|
||||||
deriving stock (Show, Eq, Ord)
|
deriving stock (Show, Eq, Ord)
|
||||||
|
|
||||||
data PatternInfixApp = PatternInfixApp
|
data PatternInfixApp = PatternInfixApp
|
||||||
{ _patInfixLeft :: Pattern,
|
{ _patInfixLeft :: PatternArg,
|
||||||
_patInfixConstructor :: ConstructorRef,
|
_patInfixConstructor :: ConstructorRef,
|
||||||
_patInfixRight :: Pattern
|
_patInfixRight :: PatternArg
|
||||||
}
|
}
|
||||||
deriving stock (Show, Eq, Ord)
|
deriving stock (Show, Eq, Ord)
|
||||||
|
|
||||||
@ -273,7 +273,7 @@ instance HasFixity PatternInfixApp where
|
|||||||
getFixity (PatternInfixApp _ op _) = fromMaybe impossible (op ^. constructorRefName . S.nameFixity)
|
getFixity (PatternInfixApp _ op _) = fromMaybe impossible (op ^. constructorRefName . S.nameFixity)
|
||||||
|
|
||||||
data PatternPostfixApp = PatternPostfixApp
|
data PatternPostfixApp = PatternPostfixApp
|
||||||
{ _patPostfixParameter :: Pattern,
|
{ _patPostfixParameter :: PatternArg,
|
||||||
_patPostfixConstructor :: ConstructorRef
|
_patPostfixConstructor :: ConstructorRef
|
||||||
}
|
}
|
||||||
deriving stock (Show, Eq, Ord)
|
deriving stock (Show, Eq, Ord)
|
||||||
@ -281,13 +281,18 @@ data PatternPostfixApp = PatternPostfixApp
|
|||||||
instance HasFixity PatternPostfixApp where
|
instance HasFixity PatternPostfixApp where
|
||||||
getFixity (PatternPostfixApp _ op) = fromMaybe impossible (op ^. constructorRefName . S.nameFixity)
|
getFixity (PatternPostfixApp _ op) = fromMaybe impossible (op ^. constructorRefName . S.nameFixity)
|
||||||
|
|
||||||
|
data PatternArg = PatternArg
|
||||||
|
{ _patternArgIsImplicit :: IsImplicit,
|
||||||
|
_patternArgPattern :: Pattern
|
||||||
|
}
|
||||||
|
deriving stock (Show, Eq, Ord)
|
||||||
|
|
||||||
data Pattern
|
data Pattern
|
||||||
= PatternVariable (SymbolType 'Scoped)
|
= PatternVariable (SymbolType 'Scoped)
|
||||||
| PatternConstructor ConstructorRef
|
| PatternConstructor ConstructorRef
|
||||||
| PatternApplication PatternApp
|
| PatternApplication PatternApp
|
||||||
| PatternInfixApplication PatternInfixApp
|
| PatternInfixApplication PatternInfixApp
|
||||||
| PatternPostfixApplication PatternPostfixApp
|
| PatternPostfixApplication PatternPostfixApp
|
||||||
| PatternBraces Pattern
|
|
||||||
| PatternWildcard Wildcard
|
| PatternWildcard Wildcard
|
||||||
| PatternEmpty
|
| PatternEmpty
|
||||||
deriving stock (Show, Eq, Ord)
|
deriving stock (Show, Eq, Ord)
|
||||||
@ -300,7 +305,6 @@ instance HasAtomicity Pattern where
|
|||||||
PatternInfixApplication a -> Aggregate (getFixity a)
|
PatternInfixApplication a -> Aggregate (getFixity a)
|
||||||
PatternPostfixApplication p -> Aggregate (getFixity p)
|
PatternPostfixApplication p -> Aggregate (getFixity p)
|
||||||
PatternWildcard {} -> Atom
|
PatternWildcard {} -> Atom
|
||||||
PatternBraces {} -> Atom
|
|
||||||
PatternEmpty -> Atom
|
PatternEmpty -> Atom
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
@ -887,8 +891,7 @@ data ExpressionAtoms (s :: Stage) = ExpressionAtoms
|
|||||||
_expressionAtomsLoc :: Interval
|
_expressionAtomsLoc :: Interval
|
||||||
}
|
}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
makeLenses ''PatternArg
|
||||||
|
|
||||||
makeLenses ''Function
|
makeLenses ''Function
|
||||||
makeLenses ''InductiveDef
|
makeLenses ''InductiveDef
|
||||||
makeLenses ''PostfixApplication
|
makeLenses ''PostfixApplication
|
||||||
@ -1048,6 +1051,11 @@ instance
|
|||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
instance HasAtomicity PatternArg where
|
||||||
|
atomicity p
|
||||||
|
| Implicit <- p ^. patternArgIsImplicit = Atom
|
||||||
|
| otherwise = atomicity (p ^. patternArgPattern)
|
||||||
|
|
||||||
idenOverName :: (forall s. S.Name' s -> S.Name' s) -> ScopedIden -> ScopedIden
|
idenOverName :: (forall s. S.Name' s -> S.Name' s) -> ScopedIden -> ScopedIden
|
||||||
idenOverName f = \case
|
idenOverName f = \case
|
||||||
ScopedAxiom a -> ScopedAxiom (over axiomRefName f a)
|
ScopedAxiom a -> ScopedAxiom (over axiomRefName f a)
|
||||||
|
@ -448,6 +448,9 @@ instance PrettyCode QualifiedName where
|
|||||||
let symbols = _qualifiedPath ^. pathParts NonEmpty.|> _qualifiedSymbol
|
let symbols = _qualifiedPath ^. pathParts NonEmpty.|> _qualifiedSymbol
|
||||||
dotted <$> mapM ppSymbol symbols
|
dotted <$> mapM ppSymbol symbols
|
||||||
|
|
||||||
|
bracesIf :: Bool -> Doc Ann -> Doc Ann
|
||||||
|
bracesIf t = if t then braces else id
|
||||||
|
|
||||||
ppName :: forall s r. (SingI s, Members '[Reader Options] r) => IdentifierType s -> Sem r (Doc Ann)
|
ppName :: forall s r. (SingI s, Members '[Reader Options] r) => IdentifierType s -> Sem r (Doc Ann)
|
||||||
ppName = case sing :: SStage s of
|
ppName = case sing :: SStage s of
|
||||||
SParsed -> ppCode
|
SParsed -> ppCode
|
||||||
@ -652,6 +655,11 @@ instance PrettyCode PatternScopedIden where
|
|||||||
PatternScopedVar v -> ppCode v
|
PatternScopedVar v -> ppCode v
|
||||||
PatternScopedConstructor c -> ppCode c
|
PatternScopedConstructor c -> ppCode c
|
||||||
|
|
||||||
|
instance PrettyCode PatternArg where
|
||||||
|
ppCode a = do
|
||||||
|
p <- ppCode (a ^. patternArgPattern)
|
||||||
|
return (bracesIf (Implicit == a ^. patternArgIsImplicit) p)
|
||||||
|
|
||||||
instance SingI s => PrettyCode (PatternAtom s) where
|
instance SingI s => PrettyCode (PatternAtom s) where
|
||||||
ppCode a = case a of
|
ppCode a = case a of
|
||||||
PatternAtomIden n -> case sing :: SStage s of
|
PatternAtomIden n -> case sing :: SStage s of
|
||||||
@ -750,7 +758,6 @@ instance PrettyCode Pattern where
|
|||||||
return $ l' <+> r'
|
return $ l' <+> r'
|
||||||
PatternWildcard {} -> return kwWildcard
|
PatternWildcard {} -> return kwWildcard
|
||||||
PatternEmpty -> return $ parens mempty
|
PatternEmpty -> return $ parens mempty
|
||||||
PatternBraces p -> braces <$> ppCode p
|
|
||||||
PatternConstructor constr -> ppCode constr
|
PatternConstructor constr -> ppCode constr
|
||||||
PatternInfixApplication i -> ppPatternInfixApp i
|
PatternInfixApplication i -> ppPatternInfixApp i
|
||||||
PatternPostfixApplication i -> ppPatternPostfixApp i
|
PatternPostfixApplication i -> ppPatternPostfixApp i
|
||||||
|
@ -1198,7 +1198,7 @@ checkParseExpressionAtoms = checkExpressionAtoms >=> parseExpressionAtoms
|
|||||||
checkParsePatternAtom ::
|
checkParsePatternAtom ::
|
||||||
Members '[Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen] r =>
|
Members '[Error ScoperError, State Scope, State ScoperState, InfoTableBuilder, NameIdGen] r =>
|
||||||
PatternAtom 'Parsed ->
|
PatternAtom 'Parsed ->
|
||||||
Sem r Pattern
|
Sem r PatternArg
|
||||||
checkParsePatternAtom = checkPatternAtom >=> parsePatternAtom
|
checkParsePatternAtom = checkPatternAtom >=> parsePatternAtom
|
||||||
|
|
||||||
checkStatement ::
|
checkStatement ::
|
||||||
@ -1423,7 +1423,7 @@ parseTerm =
|
|||||||
type ParsePat = P.Parsec () [PatternAtom 'Scoped]
|
type ParsePat = P.Parsec () [PatternAtom 'Scoped]
|
||||||
|
|
||||||
makePatternTable ::
|
makePatternTable ::
|
||||||
PatternAtom 'Scoped -> [[P.Operator ParsePat Pattern]]
|
PatternAtom 'Scoped -> [[P.Operator ParsePat PatternArg]]
|
||||||
makePatternTable atom = [appOp] : operators
|
makePatternTable atom = [appOp] : operators
|
||||||
where
|
where
|
||||||
getConstructorRef :: PatternAtom 'Scoped -> Maybe ConstructorRef
|
getConstructorRef :: PatternAtom 'Scoped -> Maybe ConstructorRef
|
||||||
@ -1437,24 +1437,24 @@ makePatternTable atom = [appOp] : operators
|
|||||||
constructorRefs = case atom of
|
constructorRefs = case atom of
|
||||||
PatternAtomParens (PatternAtoms atoms _) -> mapMaybe getConstructorRef (toList atoms)
|
PatternAtomParens (PatternAtoms atoms _) -> mapMaybe getConstructorRef (toList atoms)
|
||||||
_ -> []
|
_ -> []
|
||||||
mkSymbolTable :: [ConstructorRef] -> [[P.Operator ParsePat Pattern]]
|
mkSymbolTable :: [ConstructorRef] -> [[P.Operator ParsePat PatternArg]]
|
||||||
mkSymbolTable = reverse . map (map snd) . groupSortOn' fst . mapMaybe unqualifiedSymbolOp
|
mkSymbolTable = reverse . map (map snd) . groupSortOn' fst . mapMaybe unqualifiedSymbolOp
|
||||||
where
|
where
|
||||||
unqualifiedSymbolOp :: ConstructorRef -> Maybe (Precedence, P.Operator ParsePat Pattern)
|
unqualifiedSymbolOp :: ConstructorRef -> Maybe (Precedence, P.Operator ParsePat PatternArg)
|
||||||
unqualifiedSymbolOp (ConstructorRef' S.Name' {..})
|
unqualifiedSymbolOp (ConstructorRef' S.Name' {..})
|
||||||
| Just Fixity {..} <- _nameFixity,
|
| Just Fixity {..} <- _nameFixity,
|
||||||
_nameKind == S.KNameConstructor = Just $
|
_nameKind == S.KNameConstructor = Just $
|
||||||
case _fixityArity of
|
case _fixityArity of
|
||||||
Unary u -> (_fixityPrecedence, P.Postfix (unaryApp <$> parseSymbolId _nameId))
|
Unary u -> (_fixityPrecedence, P.Postfix (unaryApp <$> parseSymbolId _nameId))
|
||||||
where
|
where
|
||||||
unaryApp :: ConstructorRef -> Pattern -> Pattern
|
unaryApp :: ConstructorRef -> PatternArg -> PatternArg
|
||||||
unaryApp funName = case u of
|
unaryApp funName = case u of
|
||||||
AssocPostfix -> PatternPostfixApplication . (`PatternPostfixApp` funName)
|
AssocPostfix -> explicitP . PatternPostfixApplication . (`PatternPostfixApp` funName)
|
||||||
Binary b -> (_fixityPrecedence, infixLRN (binaryInfixApp <$> parseSymbolId _nameId))
|
Binary b -> (_fixityPrecedence, infixLRN (binaryInfixApp <$> parseSymbolId _nameId))
|
||||||
where
|
where
|
||||||
binaryInfixApp :: ConstructorRef -> Pattern -> Pattern -> Pattern
|
binaryInfixApp :: ConstructorRef -> PatternArg -> PatternArg -> PatternArg
|
||||||
binaryInfixApp name argLeft = PatternInfixApplication . PatternInfixApp argLeft name
|
binaryInfixApp name argLeft = explicitP . PatternInfixApplication . PatternInfixApp argLeft name
|
||||||
infixLRN :: ParsePat (Pattern -> Pattern -> Pattern) -> P.Operator ParsePat Pattern
|
infixLRN :: ParsePat (PatternArg -> PatternArg -> PatternArg) -> P.Operator ParsePat PatternArg
|
||||||
infixLRN = case b of
|
infixLRN = case b of
|
||||||
AssocLeft -> P.InfixL
|
AssocLeft -> P.InfixL
|
||||||
AssocRight -> P.InfixR
|
AssocRight -> P.InfixR
|
||||||
@ -1470,22 +1470,30 @@ makePatternTable atom = [appOp] : operators
|
|||||||
return ref
|
return ref
|
||||||
|
|
||||||
-- Application by juxtaposition.
|
-- Application by juxtaposition.
|
||||||
appOp :: P.Operator ParsePat Pattern
|
appOp :: P.Operator ParsePat PatternArg
|
||||||
appOp = P.InfixL (return app)
|
appOp = P.InfixL (return app)
|
||||||
where
|
where
|
||||||
app :: Pattern -> Pattern -> Pattern
|
app :: PatternArg -> PatternArg -> PatternArg
|
||||||
app l r =
|
app l r =
|
||||||
PatternApplication
|
explicitP
|
||||||
( PatternApp
|
( PatternApplication
|
||||||
{ _patAppLeft = l,
|
( PatternApp
|
||||||
_patAppRight = r
|
{ _patAppLeft = l,
|
||||||
}
|
_patAppRight = r
|
||||||
|
}
|
||||||
|
)
|
||||||
)
|
)
|
||||||
|
|
||||||
|
explicitP :: Pattern -> PatternArg
|
||||||
|
explicitP = PatternArg Explicit
|
||||||
|
|
||||||
|
implicitP :: Pattern -> PatternArg
|
||||||
|
implicitP = PatternArg Implicit
|
||||||
|
|
||||||
parsePatternTerm ::
|
parsePatternTerm ::
|
||||||
forall r.
|
forall r.
|
||||||
Members '[Reader (ParsePat Pattern), Embed ParsePat] r =>
|
Members '[Reader (ParsePat PatternArg), Embed ParsePat] r =>
|
||||||
Sem r Pattern
|
Sem r PatternArg
|
||||||
parsePatternTerm = do
|
parsePatternTerm = do
|
||||||
pPat <- ask
|
pPat <- ask
|
||||||
embed @ParsePat $
|
embed @ParsePat $
|
||||||
@ -1496,9 +1504,9 @@ parsePatternTerm = do
|
|||||||
<|> parseWildcard
|
<|> parseWildcard
|
||||||
<|> parseEmpty
|
<|> parseEmpty
|
||||||
where
|
where
|
||||||
parseNoInfixConstructor :: ParsePat Pattern
|
parseNoInfixConstructor :: ParsePat PatternArg
|
||||||
parseNoInfixConstructor =
|
parseNoInfixConstructor =
|
||||||
PatternConstructor
|
explicitP . PatternConstructor
|
||||||
<$> P.token constructorNoFixity mempty
|
<$> P.token constructorNoFixity mempty
|
||||||
where
|
where
|
||||||
constructorNoFixity :: PatternAtom 'Scoped -> Maybe ConstructorRef
|
constructorNoFixity :: PatternAtom 'Scoped -> Maybe ConstructorRef
|
||||||
@ -1509,35 +1517,38 @@ parsePatternTerm = do
|
|||||||
n = ref ^. constructorRefName
|
n = ref ^. constructorRefName
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
|
|
||||||
parseWildcard :: ParsePat Pattern
|
parseWildcard :: ParsePat PatternArg
|
||||||
parseWildcard = PatternWildcard <$> P.token isWildcard mempty
|
parseWildcard = explicitP . PatternWildcard <$> P.token isWildcard mempty
|
||||||
where
|
where
|
||||||
isWildcard :: PatternAtom 'Scoped -> Maybe Wildcard
|
isWildcard :: PatternAtom 'Scoped -> Maybe Wildcard
|
||||||
isWildcard s = case s of
|
isWildcard s = case s of
|
||||||
PatternAtomWildcard i -> Just i
|
PatternAtomWildcard i -> Just i
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
|
|
||||||
parseEmpty :: ParsePat Pattern
|
parseEmpty :: ParsePat PatternArg
|
||||||
parseEmpty = PatternEmpty <$ P.satisfy isEmpty
|
parseEmpty = explicitP PatternEmpty <$ P.satisfy isEmpty
|
||||||
where
|
where
|
||||||
isEmpty :: PatternAtom 'Scoped -> Bool
|
isEmpty :: PatternAtom 'Scoped -> Bool
|
||||||
isEmpty s = case s of
|
isEmpty s = case s of
|
||||||
PatternAtomEmpty -> True
|
PatternAtomEmpty -> True
|
||||||
_ -> False
|
_ -> False
|
||||||
|
|
||||||
parseVariable :: ParsePat Pattern
|
parseVariable :: ParsePat PatternArg
|
||||||
parseVariable = PatternVariable <$> P.token var mempty
|
parseVariable = explicitP . PatternVariable <$> P.token var mempty
|
||||||
where
|
where
|
||||||
var :: PatternAtom 'Scoped -> Maybe S.Symbol
|
var :: PatternAtom 'Scoped -> Maybe S.Symbol
|
||||||
var s = case s of
|
var s = case s of
|
||||||
PatternAtomIden (PatternScopedVar sym) -> Just sym
|
PatternAtomIden (PatternScopedVar sym) -> Just sym
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
|
|
||||||
parseBraces :: ParsePat Pattern -> ParsePat Pattern
|
parseBraces :: ParsePat PatternArg -> ParsePat PatternArg
|
||||||
parseBraces patternParser = do
|
parseBraces patternParser = do
|
||||||
exprs <- P.token bracesPat mempty
|
exprs <- P.token bracesPat mempty
|
||||||
case P.parse patternParser "" exprs of
|
case P.parse patternParser "" exprs of
|
||||||
Right r -> return (PatternBraces r)
|
Right (PatternArg i p)
|
||||||
|
-- TODO proper error
|
||||||
|
| Implicit <- i -> error "nested braces"
|
||||||
|
| otherwise -> return (implicitP p)
|
||||||
Left {} -> mzero
|
Left {} -> mzero
|
||||||
where
|
where
|
||||||
bracesPat :: PatternAtom 'Scoped -> Maybe [PatternAtom 'Scoped]
|
bracesPat :: PatternAtom 'Scoped -> Maybe [PatternAtom 'Scoped]
|
||||||
@ -1545,7 +1556,7 @@ parsePatternTerm = do
|
|||||||
PatternAtomBraces (PatternAtoms ss _) -> Just (toList ss)
|
PatternAtomBraces (PatternAtoms ss _) -> Just (toList ss)
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
|
|
||||||
parseParens :: ParsePat Pattern -> ParsePat Pattern
|
parseParens :: ParsePat PatternArg -> ParsePat PatternArg
|
||||||
parseParens patternParser = do
|
parseParens patternParser = do
|
||||||
exprs <- P.token parenPat mempty
|
exprs <- P.token parenPat mempty
|
||||||
case P.parse patternParser "" exprs of
|
case P.parse patternParser "" exprs of
|
||||||
@ -1560,22 +1571,22 @@ parsePatternTerm = do
|
|||||||
mkPatternParser ::
|
mkPatternParser ::
|
||||||
forall r.
|
forall r.
|
||||||
Members '[Embed ParsePat] r =>
|
Members '[Embed ParsePat] r =>
|
||||||
[[P.Operator ParsePat Pattern]] ->
|
[[P.Operator ParsePat PatternArg]] ->
|
||||||
Sem r Pattern
|
Sem r PatternArg
|
||||||
mkPatternParser table = embed @ParsePat pPattern
|
mkPatternParser table = embed @ParsePat pPattern
|
||||||
where
|
where
|
||||||
pPattern :: ParsePat Pattern
|
pPattern :: ParsePat PatternArg
|
||||||
pPattern = P.makeExprParser pTerm table
|
pPattern = P.makeExprParser pTerm table
|
||||||
pTerm :: ParsePat Pattern
|
pTerm :: ParsePat PatternArg
|
||||||
pTerm = runM parseTermRec
|
pTerm = runM parseTermRec
|
||||||
where
|
where
|
||||||
parseTermRec :: Sem '[Embed ParsePat] Pattern
|
parseTermRec :: Sem '[Embed ParsePat] PatternArg
|
||||||
parseTermRec = runReader pPattern parsePatternTerm
|
parseTermRec = runReader pPattern parsePatternTerm
|
||||||
|
|
||||||
parsePatternAtom ::
|
parsePatternAtom ::
|
||||||
Members '[Error ScoperError, State Scope] r =>
|
Members '[Error ScoperError, State Scope] r =>
|
||||||
PatternAtom 'Scoped ->
|
PatternAtom 'Scoped ->
|
||||||
Sem r Pattern
|
Sem r PatternArg
|
||||||
parsePatternAtom sec = do
|
parsePatternAtom sec = do
|
||||||
case res of
|
case res of
|
||||||
Left {} -> case sec of
|
Left {} -> case sec of
|
||||||
@ -1584,7 +1595,7 @@ parsePatternAtom sec = do
|
|||||||
Right r -> return r
|
Right r -> return r
|
||||||
where
|
where
|
||||||
tbl = makePatternTable sec
|
tbl = makePatternTable sec
|
||||||
parser :: ParsePat Pattern
|
parser :: ParsePat PatternArg
|
||||||
parser = runM (mkPatternParser tbl) <* P.eof
|
parser = runM (mkPatternParser tbl) <* P.eof
|
||||||
res = P.parse parser filePath [sec]
|
res = P.parse parser filePath [sec]
|
||||||
|
|
||||||
|
@ -1,8 +1,14 @@
|
|||||||
module Juvix.Syntax.IsImplicit where
|
module Juvix.Syntax.IsImplicit where
|
||||||
|
|
||||||
import Juvix.Prelude
|
import Juvix.Prelude
|
||||||
|
import Juvix.Prelude.Pretty
|
||||||
|
|
||||||
data IsImplicit = Explicit | Implicit
|
data IsImplicit = Explicit | Implicit
|
||||||
deriving stock (Show, Eq, Ord, Generic)
|
deriving stock (Show, Eq, Ord, Generic)
|
||||||
|
|
||||||
instance Hashable IsImplicit
|
instance Hashable IsImplicit
|
||||||
|
|
||||||
|
instance Pretty IsImplicit where
|
||||||
|
pretty = \case
|
||||||
|
Implicit -> "implicit"
|
||||||
|
Explicit -> "explicit"
|
||||||
|
@ -163,8 +163,8 @@ checkLhs ::
|
|||||||
Interval ->
|
Interval ->
|
||||||
Maybe Arity ->
|
Maybe Arity ->
|
||||||
Arity ->
|
Arity ->
|
||||||
[Pattern] ->
|
[PatternArg] ->
|
||||||
Sem r ([Pattern], LocalVars, Arity)
|
Sem r ([PatternArg], LocalVars, Arity)
|
||||||
checkLhs loc hint ariSignature pats = do
|
checkLhs loc hint ariSignature pats = do
|
||||||
(locals, (pats', bodyAri)) <- runState emptyLocalVars (goLhs ariSignature pats)
|
(locals, (pats', bodyAri)) <- runState emptyLocalVars (goLhs ariSignature pats)
|
||||||
return (pats', locals, bodyAri)
|
return (pats', locals, bodyAri)
|
||||||
@ -173,7 +173,7 @@ checkLhs loc hint ariSignature pats = do
|
|||||||
-- body once all the patterns have been processed).
|
-- body once all the patterns have been processed).
|
||||||
-- Does not insert holes greedily. I.e. implicit wildcards are only inserted
|
-- Does not insert holes greedily. I.e. implicit wildcards are only inserted
|
||||||
-- between explicit parameters already in the pattern.
|
-- between explicit parameters already in the pattern.
|
||||||
goLhs :: Arity -> [Pattern] -> Sem (State LocalVars ': r) ([Pattern], Arity)
|
goLhs :: Arity -> [PatternArg] -> Sem (State LocalVars ': r) ([PatternArg], Arity)
|
||||||
goLhs a = \case
|
goLhs a = \case
|
||||||
[] -> return $ case hint >>= tailHelper a of
|
[] -> return $ case hint >>= tailHelper a of
|
||||||
Nothing -> ([], a)
|
Nothing -> ([], a)
|
||||||
@ -192,25 +192,26 @@ checkLhs loc hint ariSignature pats = do
|
|||||||
p' <- checkPattern ArityUnknown p
|
p' <- checkPattern ArityUnknown p
|
||||||
first (p' :) <$> goLhs ArityUnknown ps
|
first (p' :) <$> goLhs ArityUnknown ps
|
||||||
ArityFunction (FunctionArity l r) ->
|
ArityFunction (FunctionArity l r) ->
|
||||||
case (getPatternBraces p, l) of
|
case (p ^. patternArgIsImplicit, l) of
|
||||||
(Just b, ParamImplicit) -> do
|
(Implicit, ParamImplicit) -> do
|
||||||
b' <- checkPattern (arityParameter l) b
|
b' <- checkPattern (arityParameter l) p
|
||||||
first (b' :) <$> goLhs r ps
|
first (b' :) <$> goLhs r ps
|
||||||
(Just x, ParamExplicit {}) ->
|
(Implicit, ParamExplicit {}) ->
|
||||||
throw
|
throw
|
||||||
( ErrExpectedExplicitPattern
|
( ErrWrongPatternIsImplicit
|
||||||
ExpectedExplicitPattern
|
WrongPatternIsImplicit
|
||||||
{ _expectedExplicitPattern = x
|
{ _wrongPatternIsImplicitExpected = Explicit,
|
||||||
|
_wrongPatternIsImplicitActual = p
|
||||||
}
|
}
|
||||||
)
|
)
|
||||||
(Nothing, ParamImplicit) ->
|
(Explicit, ParamImplicit) ->
|
||||||
first (wildcard :) <$> goLhs r lhs
|
first (wildcard :) <$> goLhs r lhs
|
||||||
(Nothing, ParamExplicit pa) -> do
|
(Explicit, ParamExplicit pa) -> do
|
||||||
p' <- checkPattern pa p
|
p' <- checkPattern pa p
|
||||||
first (p' :) <$> goLhs r ps
|
first (p' :) <$> goLhs r ps
|
||||||
where
|
where
|
||||||
wildcard :: Pattern
|
wildcard :: PatternArg
|
||||||
wildcard = PatternBraces (PatternWildcard (Wildcard loc))
|
wildcard = PatternArg Implicit (PatternWildcard (Wildcard loc))
|
||||||
|
|
||||||
tailHelper :: Arity -> Arity -> Maybe Int
|
tailHelper :: Arity -> Arity -> Maybe Int
|
||||||
tailHelper a target
|
tailHelper a target
|
||||||
@ -220,30 +221,28 @@ checkLhs loc hint ariSignature pats = do
|
|||||||
a' = dropSuffix target' (unfoldArity a)
|
a' = dropSuffix target' (unfoldArity a)
|
||||||
target' = unfoldArity target
|
target' = unfoldArity target
|
||||||
|
|
||||||
getPatternBraces :: Pattern -> Maybe Pattern
|
|
||||||
getPatternBraces p = case p of
|
|
||||||
PatternBraces {} -> Just p
|
|
||||||
_ -> Nothing
|
|
||||||
|
|
||||||
checkPattern ::
|
checkPattern ::
|
||||||
|
forall r.
|
||||||
Members '[Reader InfoTable, Error ArityCheckerError, State LocalVars] r =>
|
Members '[Reader InfoTable, Error ArityCheckerError, State LocalVars] r =>
|
||||||
Arity ->
|
Arity ->
|
||||||
Pattern ->
|
PatternArg ->
|
||||||
Sem r Pattern
|
Sem r PatternArg
|
||||||
checkPattern ari = \case
|
checkPattern ari = traverseOf patternArgPattern helper
|
||||||
PatternBraces p -> checkPattern ari p
|
where
|
||||||
PatternVariable v -> addArity v ari $> PatternVariable v
|
helper :: Pattern -> Sem r Pattern
|
||||||
PatternWildcard i -> return (PatternWildcard i)
|
helper = \case
|
||||||
PatternConstructorApp c -> case ari of
|
PatternVariable v -> addArity v ari $> PatternVariable v
|
||||||
ArityUnit -> PatternConstructorApp <$> checkConstructorApp c
|
PatternWildcard i -> return (PatternWildcard i)
|
||||||
ArityUnknown -> PatternConstructorApp <$> checkConstructorApp c
|
PatternConstructorApp c -> case ari of
|
||||||
ArityFunction {} ->
|
ArityUnit -> PatternConstructorApp <$> checkConstructorApp c
|
||||||
throw
|
ArityUnknown -> PatternConstructorApp <$> checkConstructorApp c
|
||||||
( ErrPatternFunction
|
ArityFunction {} ->
|
||||||
PatternFunction
|
throw
|
||||||
{ _patternFunction = c
|
( ErrPatternFunction
|
||||||
}
|
PatternFunction
|
||||||
)
|
{ _patternFunction = c
|
||||||
|
}
|
||||||
|
)
|
||||||
|
|
||||||
checkConstructorApp ::
|
checkConstructorApp ::
|
||||||
forall r.
|
forall r.
|
||||||
|
@ -10,7 +10,7 @@ import Juvix.Syntax.MicroJuvix.ArityChecker.Error.Types
|
|||||||
data ArityCheckerError
|
data ArityCheckerError
|
||||||
= ErrWrongConstructorAppLength WrongConstructorAppLength
|
= ErrWrongConstructorAppLength WrongConstructorAppLength
|
||||||
| ErrLhsTooManyPatterns LhsTooManyPatterns
|
| ErrLhsTooManyPatterns LhsTooManyPatterns
|
||||||
| ErrExpectedExplicitPattern ExpectedExplicitPattern
|
| ErrWrongPatternIsImplicit WrongPatternIsImplicit
|
||||||
| ErrExpectedExplicitArgument ExpectedExplicitArgument
|
| ErrExpectedExplicitArgument ExpectedExplicitArgument
|
||||||
| ErrPatternFunction PatternFunction
|
| ErrPatternFunction PatternFunction
|
||||||
| ErrTooManyArguments TooManyArguments
|
| ErrTooManyArguments TooManyArguments
|
||||||
@ -21,7 +21,7 @@ instance ToGenericError ArityCheckerError where
|
|||||||
genericError = \case
|
genericError = \case
|
||||||
ErrWrongConstructorAppLength e -> genericError e
|
ErrWrongConstructorAppLength e -> genericError e
|
||||||
ErrLhsTooManyPatterns e -> genericError e
|
ErrLhsTooManyPatterns e -> genericError e
|
||||||
ErrExpectedExplicitPattern e -> genericError e
|
ErrWrongPatternIsImplicit e -> genericError e
|
||||||
ErrExpectedExplicitArgument e -> genericError e
|
ErrExpectedExplicitArgument e -> genericError e
|
||||||
ErrPatternFunction e -> genericError e
|
ErrPatternFunction e -> genericError e
|
||||||
ErrTooManyArguments e -> genericError e
|
ErrTooManyArguments e -> genericError e
|
||||||
|
@ -40,7 +40,7 @@ instance ToGenericError WrongConstructorAppLength where
|
|||||||
| otherwise = pretty n
|
| otherwise = pretty n
|
||||||
|
|
||||||
newtype LhsTooManyPatterns = LhsTooManyPatterns
|
newtype LhsTooManyPatterns = LhsTooManyPatterns
|
||||||
{ _lhsTooManyPatternsRemaining :: NonEmpty Pattern
|
{ _lhsTooManyPatternsRemaining :: NonEmpty PatternArg
|
||||||
}
|
}
|
||||||
|
|
||||||
makeLenses ''LhsTooManyPatterns
|
makeLenses ''LhsTooManyPatterns
|
||||||
@ -65,13 +65,14 @@ instance ToGenericError LhsTooManyPatterns where
|
|||||||
| n == 1 = "was"
|
| n == 1 = "was"
|
||||||
| otherwise = "were"
|
| otherwise = "were"
|
||||||
|
|
||||||
newtype ExpectedExplicitPattern = ExpectedExplicitPattern
|
data WrongPatternIsImplicit = WrongPatternIsImplicit
|
||||||
{ _expectedExplicitPattern :: Pattern
|
{ _wrongPatternIsImplicitExpected :: IsImplicit,
|
||||||
|
_wrongPatternIsImplicitActual :: PatternArg
|
||||||
}
|
}
|
||||||
|
|
||||||
makeLenses ''ExpectedExplicitPattern
|
makeLenses ''WrongPatternIsImplicit
|
||||||
|
|
||||||
instance ToGenericError ExpectedExplicitPattern where
|
instance ToGenericError WrongPatternIsImplicit where
|
||||||
genericError e =
|
genericError e =
|
||||||
GenericError
|
GenericError
|
||||||
{ _genericErrorLoc = i,
|
{ _genericErrorLoc = i,
|
||||||
@ -79,10 +80,17 @@ instance ToGenericError ExpectedExplicitPattern where
|
|||||||
_genericErrorIntervals = [i]
|
_genericErrorIntervals = [i]
|
||||||
}
|
}
|
||||||
where
|
where
|
||||||
i = getLoc (e ^. expectedExplicitPattern)
|
i = getLoc (e ^. wrongPatternIsImplicitActual)
|
||||||
|
expec = e ^. wrongPatternIsImplicitExpected
|
||||||
|
found = e ^. wrongPatternIsImplicitActual . patternArgIsImplicit
|
||||||
|
pat = e ^. wrongPatternIsImplicitActual
|
||||||
msg =
|
msg =
|
||||||
"Expected an explicit pattern but found an implicit pattern"
|
"Expected an"
|
||||||
<+> ppCode (e ^. expectedExplicitPattern)
|
<+> pretty expec
|
||||||
|
<+> "pattern but found an"
|
||||||
|
<+> pretty found
|
||||||
|
<+> "pattern:"
|
||||||
|
<+> ppCode pat
|
||||||
|
|
||||||
data ExpectedExplicitArgument = ExpectedExplicitArgument
|
data ExpectedExplicitArgument = ExpectedExplicitArgument
|
||||||
{ _expectedExplicitArgumentApp :: (Expression, [(IsImplicit, Expression)]),
|
{ _expectedExplicitArgumentApp :: (Expression, [(IsImplicit, Expression)]),
|
||||||
|
@ -57,7 +57,7 @@ data FunctionDef = FunctionDef
|
|||||||
|
|
||||||
data FunctionClause = FunctionClause
|
data FunctionClause = FunctionClause
|
||||||
{ _clauseName :: FunctionName,
|
{ _clauseName :: FunctionName,
|
||||||
_clausePatterns :: [Pattern],
|
_clausePatterns :: [PatternArg],
|
||||||
_clauseBody :: Expression
|
_clauseBody :: Expression
|
||||||
}
|
}
|
||||||
|
|
||||||
@ -113,14 +113,18 @@ instance Hashable Application where
|
|||||||
-- | Fully applied constructor in a pattern.
|
-- | Fully applied constructor in a pattern.
|
||||||
data ConstructorApp = ConstructorApp
|
data ConstructorApp = ConstructorApp
|
||||||
{ _constrAppConstructor :: Name,
|
{ _constrAppConstructor :: Name,
|
||||||
_constrAppParameters :: [Pattern]
|
_constrAppParameters :: [PatternArg]
|
||||||
|
}
|
||||||
|
|
||||||
|
data PatternArg = PatternArg
|
||||||
|
{ _patternArgIsImplicit :: IsImplicit,
|
||||||
|
_patternArgPattern :: Pattern
|
||||||
}
|
}
|
||||||
|
|
||||||
data Pattern
|
data Pattern
|
||||||
= PatternVariable VarName
|
= PatternVariable VarName
|
||||||
| PatternConstructorApp ConstructorApp
|
| PatternConstructorApp ConstructorApp
|
||||||
| PatternWildcard Wildcard
|
| PatternWildcard Wildcard
|
||||||
| PatternBraces Pattern
|
|
||||||
|
|
||||||
newtype InductiveParameter = InductiveParameter
|
newtype InductiveParameter = InductiveParameter
|
||||||
{ _inductiveParamName :: VarName
|
{ _inductiveParamName :: VarName
|
||||||
@ -157,6 +161,7 @@ data Function = Function
|
|||||||
instance Hashable Function
|
instance Hashable Function
|
||||||
|
|
||||||
makeLenses ''Module
|
makeLenses ''Module
|
||||||
|
makeLenses ''PatternArg
|
||||||
makeLenses ''Include
|
makeLenses ''Include
|
||||||
makeLenses ''FunctionDef
|
makeLenses ''FunctionDef
|
||||||
makeLenses ''FunctionClause
|
makeLenses ''FunctionClause
|
||||||
@ -191,12 +196,16 @@ instance HasAtomicity ConstructorApp where
|
|||||||
| null args = Atom
|
| null args = Atom
|
||||||
| otherwise = Aggregate appFixity
|
| otherwise = Aggregate appFixity
|
||||||
|
|
||||||
|
instance HasAtomicity PatternArg where
|
||||||
|
atomicity p
|
||||||
|
| Implicit <- p ^. patternArgIsImplicit = Atom
|
||||||
|
| otherwise = atomicity (p ^. patternArgPattern)
|
||||||
|
|
||||||
instance HasAtomicity Pattern where
|
instance HasAtomicity Pattern where
|
||||||
atomicity p = case p of
|
atomicity p = case p of
|
||||||
PatternConstructorApp a -> atomicity a
|
PatternConstructorApp a -> atomicity a
|
||||||
PatternVariable {} -> Atom
|
PatternVariable {} -> Atom
|
||||||
PatternWildcard {} -> Atom
|
PatternWildcard {} -> Atom
|
||||||
PatternBraces {} -> Atom
|
|
||||||
|
|
||||||
instance HasLoc FunctionParameter where
|
instance HasLoc FunctionParameter where
|
||||||
getLoc f = v (getLoc (f ^. paramType))
|
getLoc f = v (getLoc (f ^. paramType))
|
||||||
@ -232,9 +241,11 @@ instance HasLoc Pattern where
|
|||||||
getLoc = \case
|
getLoc = \case
|
||||||
PatternVariable v -> getLoc v
|
PatternVariable v -> getLoc v
|
||||||
PatternConstructorApp a -> getLoc a
|
PatternConstructorApp a -> getLoc a
|
||||||
PatternBraces p -> getLoc p
|
|
||||||
PatternWildcard i -> getLoc i
|
PatternWildcard i -> getLoc i
|
||||||
|
|
||||||
|
instance HasLoc PatternArg where
|
||||||
|
getLoc = getLoc . (^. patternArgPattern)
|
||||||
|
|
||||||
instance HasLoc ConstructorApp where
|
instance HasLoc ConstructorApp where
|
||||||
getLoc (ConstructorApp c ps) =
|
getLoc (ConstructorApp c ps) =
|
||||||
case last <$> nonEmpty ps of
|
case last <$> nonEmpty ps of
|
||||||
|
@ -244,27 +244,28 @@ renameToSubsE = fmap (ExpressionIden . IdenVar)
|
|||||||
renameExpression :: Rename -> Expression -> Expression
|
renameExpression :: Rename -> Expression -> Expression
|
||||||
renameExpression r = substitutionE (renameToSubsE r)
|
renameExpression r = substitutionE (renameToSubsE r)
|
||||||
|
|
||||||
patternVariables :: Pattern -> [VarName]
|
patternArgVariables :: Traversal' PatternArg VarName
|
||||||
patternVariables = \case
|
patternArgVariables f = traverseOf patternArgPattern (patternVariables f)
|
||||||
PatternVariable v -> [v]
|
|
||||||
PatternConstructorApp a -> goApp a
|
patternVariables :: Traversal' Pattern VarName
|
||||||
PatternBraces b -> patternVariables b
|
patternVariables f p = case p of
|
||||||
PatternWildcard {} -> []
|
PatternVariable v -> PatternVariable <$> f v
|
||||||
|
PatternConstructorApp a -> PatternConstructorApp <$> goApp f a
|
||||||
|
PatternWildcard {} -> pure p
|
||||||
where
|
where
|
||||||
goApp :: ConstructorApp -> [VarName]
|
goApp :: Traversal' ConstructorApp VarName
|
||||||
goApp (ConstructorApp _ ps) = concatMap patternVariables ps
|
goApp g = traverseOf constrAppParameters (traverse (patternArgVariables g))
|
||||||
|
|
||||||
|
renamePatternArg :: Rename -> PatternArg -> PatternArg
|
||||||
|
renamePatternArg = over patternArgPattern . renamePattern
|
||||||
|
|
||||||
renamePattern :: Rename -> Pattern -> Pattern
|
renamePattern :: Rename -> Pattern -> Pattern
|
||||||
renamePattern m = go
|
renamePattern m = over patternVariables renameVar
|
||||||
where
|
where
|
||||||
go :: Pattern -> Pattern
|
renameVar :: VarName -> VarName
|
||||||
go p = case p of
|
renameVar v
|
||||||
PatternVariable v
|
| Just v' <- m ^. at v = v'
|
||||||
| Just v' <- m ^. at v -> PatternVariable v'
|
| otherwise = v
|
||||||
PatternConstructorApp a -> PatternConstructorApp (goApp a)
|
|
||||||
_ -> p
|
|
||||||
goApp :: ConstructorApp -> ConstructorApp
|
|
||||||
goApp (ConstructorApp c ps) = ConstructorApp c (map go ps)
|
|
||||||
|
|
||||||
inductiveTypeVarsAssoc :: Foldable f => InductiveDef -> f a -> HashMap VarName a
|
inductiveTypeVarsAssoc :: Foldable f => InductiveDef -> f a -> HashMap VarName a
|
||||||
inductiveTypeVarsAssoc def l
|
inductiveTypeVarsAssoc def l
|
||||||
@ -275,6 +276,7 @@ inductiveTypeVarsAssoc def l
|
|||||||
vars :: [VarName]
|
vars :: [VarName]
|
||||||
vars = def ^.. inductiveParameters . each . inductiveParamName
|
vars = def ^.. inductiveParameters . each . inductiveParamName
|
||||||
|
|
||||||
|
-- TODO remove this after monojuvix is gone
|
||||||
functionTypeVarsAssoc :: forall a f. Foldable f => FunctionDef -> f a -> HashMap VarName a
|
functionTypeVarsAssoc :: forall a f. Foldable f => FunctionDef -> f a -> HashMap VarName a
|
||||||
functionTypeVarsAssoc def l = sig <> mconcatMap clause (def ^. funDefClauses)
|
functionTypeVarsAssoc def l = sig <> mconcatMap clause (def ^. funDefClauses)
|
||||||
where
|
where
|
||||||
@ -297,8 +299,8 @@ functionTypeVarsAssoc def l = sig <> mconcatMap clause (def ^. funDefClauses)
|
|||||||
clauseVars :: [Maybe VarName]
|
clauseVars :: [Maybe VarName]
|
||||||
clauseVars = take n (map patternVar (c ^. clausePatterns))
|
clauseVars = take n (map patternVar (c ^. clausePatterns))
|
||||||
where
|
where
|
||||||
patternVar :: Pattern -> Maybe VarName
|
patternVar :: PatternArg -> Maybe VarName
|
||||||
patternVar = \case
|
patternVar a = case a ^. patternArgPattern of
|
||||||
PatternVariable v -> Just v
|
PatternVariable v -> Just v
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
|
|
||||||
|
@ -199,6 +199,11 @@ instance PrettyCode InductiveDef where
|
|||||||
rhs <- indent' $ align $ concatWith (\a b -> a <> line <> kwPipe <+> b) inductiveConstructors'
|
rhs <- indent' $ align $ concatWith (\a b -> a <> line <> kwPipe <+> b) inductiveConstructors'
|
||||||
return $ kwData <+> inductiveName' <+?> params <+> kwEquals <> line <> rhs
|
return $ kwData <+> inductiveName' <+?> params <+> kwEquals <> line <> rhs
|
||||||
|
|
||||||
|
instance PrettyCode PatternArg where
|
||||||
|
ppCode a = do
|
||||||
|
p <- ppCode (a ^. patternArgPattern)
|
||||||
|
return (bracesIf (Implicit == a ^. patternArgIsImplicit) p)
|
||||||
|
|
||||||
instance PrettyCode ConstructorApp where
|
instance PrettyCode ConstructorApp where
|
||||||
ppCode c = do
|
ppCode c = do
|
||||||
constr' <- ppCode (c ^. constrAppConstructor)
|
constr' <- ppCode (c ^. constrAppConstructor)
|
||||||
@ -210,7 +215,6 @@ instance PrettyCode Pattern where
|
|||||||
PatternVariable v -> ppCode v
|
PatternVariable v -> ppCode v
|
||||||
PatternConstructorApp a -> ppCode a
|
PatternConstructorApp a -> ppCode a
|
||||||
PatternWildcard {} -> return kwWildcard
|
PatternWildcard {} -> return kwWildcard
|
||||||
PatternBraces b -> braces <$> ppCode b
|
|
||||||
|
|
||||||
instance PrettyCode FunctionDef where
|
instance PrettyCode FunctionDef where
|
||||||
ppCode f = do
|
ppCode f = do
|
||||||
@ -327,8 +331,11 @@ instance PrettyCode TypeCalls where
|
|||||||
elems' <- mapM ppCode elems
|
elems' <- mapM ppCode elems
|
||||||
return $ title <> line <> vsep elems' <> line
|
return $ title <> line <> vsep elems' <> line
|
||||||
|
|
||||||
parensCond :: Bool -> Doc Ann -> Doc Ann
|
parensIf :: Bool -> Doc Ann -> Doc Ann
|
||||||
parensCond t d = if t then parens d else d
|
parensIf t = if t then parens else id
|
||||||
|
|
||||||
|
bracesIf :: Bool -> Doc Ann -> Doc Ann
|
||||||
|
bracesIf t = if t then braces else id
|
||||||
|
|
||||||
ppPostExpression ::
|
ppPostExpression ::
|
||||||
(PrettyCode a, HasAtomicity a, Member (Reader Options) r) =>
|
(PrettyCode a, HasAtomicity a, Member (Reader Options) r) =>
|
||||||
@ -358,7 +365,7 @@ ppLRExpression ::
|
|||||||
a ->
|
a ->
|
||||||
Sem r (Doc Ann)
|
Sem r (Doc Ann)
|
||||||
ppLRExpression associates fixlr e =
|
ppLRExpression associates fixlr e =
|
||||||
parensCond (atomParens associates (atomicity e) fixlr)
|
parensIf (atomParens associates (atomicity e) fixlr)
|
||||||
<$> ppCode e
|
<$> ppCode e
|
||||||
|
|
||||||
ppCodeAtom :: (HasAtomicity c, PrettyCode c, Members '[Reader Options] r) => c -> Sem r (Doc Ann)
|
ppCodeAtom :: (HasAtomicity c, PrettyCode c, Members '[Reader Options] r) => c -> Sem r (Doc Ann)
|
||||||
|
@ -174,9 +174,9 @@ checkFunctionClause info FunctionClause {..} = do
|
|||||||
where
|
where
|
||||||
clauseType :: Expression
|
clauseType :: Expression
|
||||||
clauseType = info ^. functionInfoDef . funDefType
|
clauseType = info ^. functionInfoDef . funDefType
|
||||||
helper :: [Pattern] -> Expression -> Sem r (LocalVars, Expression)
|
helper :: [PatternArg] -> Expression -> Sem r (LocalVars, Expression)
|
||||||
helper pats ty = runState emptyLocalVars (go pats ty)
|
helper pats ty = runState emptyLocalVars (go pats ty)
|
||||||
go :: [Pattern] -> Expression -> Sem (State LocalVars ': r) Expression
|
go :: [PatternArg] -> Expression -> Sem (State LocalVars ': r) Expression
|
||||||
go pats bodyTy = case pats of
|
go pats bodyTy = case pats of
|
||||||
[] -> return bodyTy
|
[] -> return bodyTy
|
||||||
(p : ps) -> case bodyTy of
|
(p : ps) -> case bodyTy of
|
||||||
@ -200,26 +200,38 @@ checkFunctionClause info FunctionClause {..} = do
|
|||||||
typeOfArg :: FunctionParameter -> Expression
|
typeOfArg :: FunctionParameter -> Expression
|
||||||
typeOfArg = (^. paramType)
|
typeOfArg = (^. paramType)
|
||||||
|
|
||||||
|
matchIsImplicit :: Member (Error TypeCheckerError) r => IsImplicit -> PatternArg -> Sem r ()
|
||||||
|
matchIsImplicit expected actual =
|
||||||
|
unless
|
||||||
|
(expected == actual ^. patternArgIsImplicit)
|
||||||
|
( throw
|
||||||
|
( ErrArity
|
||||||
|
( ErrWrongPatternIsImplicit
|
||||||
|
WrongPatternIsImplicit
|
||||||
|
{ _wrongPatternIsImplicitExpected = expected,
|
||||||
|
_wrongPatternIsImplicitActual = actual
|
||||||
|
}
|
||||||
|
)
|
||||||
|
)
|
||||||
|
)
|
||||||
|
|
||||||
checkPattern ::
|
checkPattern ::
|
||||||
forall r.
|
forall r.
|
||||||
Members '[Reader InfoTable, Error TypeCheckerError, State LocalVars, Inference, NameIdGen] r =>
|
Members '[Reader InfoTable, Error TypeCheckerError, State LocalVars, Inference, NameIdGen] r =>
|
||||||
FunctionName ->
|
FunctionName ->
|
||||||
FunctionParameter ->
|
FunctionParameter ->
|
||||||
Pattern ->
|
PatternArg ->
|
||||||
Sem r ()
|
Sem r ()
|
||||||
checkPattern funName = go
|
checkPattern funName = go
|
||||||
where
|
where
|
||||||
go :: FunctionParameter -> Pattern -> Sem r ()
|
go :: FunctionParameter -> PatternArg -> Sem r ()
|
||||||
go argTy p = do
|
go argTy patArg = do
|
||||||
|
matchIsImplicit (argTy ^. paramImplicit) patArg
|
||||||
tyVarMap <- fmap (ExpressionIden . IdenVar) . (^. localTyMap) <$> get
|
tyVarMap <- fmap (ExpressionIden . IdenVar) . (^. localTyMap) <$> get
|
||||||
ty <- normalizeType (substitutionE tyVarMap (typeOfArg argTy))
|
ty <- normalizeType (substitutionE tyVarMap (typeOfArg argTy))
|
||||||
let unbrace = \case
|
let pat = patArg ^. patternArgPattern
|
||||||
PatternBraces b -> b
|
|
||||||
x -> x
|
|
||||||
pat = unbrace p
|
|
||||||
case pat of
|
case pat of
|
||||||
PatternWildcard {} -> return ()
|
PatternWildcard {} -> return ()
|
||||||
PatternBraces {} -> impossible
|
|
||||||
PatternVariable v -> do
|
PatternVariable v -> do
|
||||||
modify (addType v ty)
|
modify (addType v ty)
|
||||||
registerIden v ty
|
registerIden v ty
|
||||||
|
@ -42,7 +42,7 @@ viewCall = \case
|
|||||||
return $ case s of
|
return $ case s of
|
||||||
Nothing -> CallRow Nothing
|
Nothing -> CallRow Nothing
|
||||||
Just s' -> CallRow (Just (s', REq))
|
Just s' -> CallRow (Just (s', REq))
|
||||||
_ -> return (CallRow Nothing)
|
Nothing -> return (CallRow Nothing)
|
||||||
ExpressionIden (IdenFunction x) ->
|
ExpressionIden (IdenFunction x) ->
|
||||||
return (Just (singletonCall x))
|
return (Just (singletonCall x))
|
||||||
_ -> return Nothing
|
_ -> return Nothing
|
||||||
|
@ -20,15 +20,16 @@ emptySizeInfo =
|
|||||||
_sizeSmaller = mempty
|
_sizeSmaller = mempty
|
||||||
}
|
}
|
||||||
|
|
||||||
mkSizeInfo :: [Pattern] -> SizeInfo
|
mkSizeInfo :: [PatternArg] -> SizeInfo
|
||||||
mkSizeInfo ps = SizeInfo {..}
|
mkSizeInfo ps = SizeInfo {..}
|
||||||
where
|
where
|
||||||
ps' = filter (not . isBrace) ps
|
ps' :: [Pattern]
|
||||||
isBrace = \case
|
ps' = map (^. patternArgPattern) (filter (not . isBrace) ps)
|
||||||
PatternBraces {} -> True
|
isBrace :: PatternArg -> Bool
|
||||||
_ -> False
|
isBrace = (== Implicit) . (^. patternArgIsImplicit)
|
||||||
_sizeEqual = ps
|
_sizeEqual = map (^. patternArgPattern) ps
|
||||||
|
_sizeSmaller :: HashMap VarName Int
|
||||||
_sizeSmaller =
|
_sizeSmaller =
|
||||||
HashMap.fromList
|
HashMap.fromList
|
||||||
[ (v, i) | (i, p) <- zip [0 ..] ps', v <- smallerPatternVariables p
|
[ (v, i) | (i, p) <- zip [0 ..] ps', v <- p ^.. smallerPatternVariables
|
||||||
]
|
]
|
||||||
|
@ -163,7 +163,7 @@ goFunctionDef f = do
|
|||||||
goFunctionClause :: Name -> Abstract.FunctionClause -> Sem r FunctionClause
|
goFunctionClause :: Name -> Abstract.FunctionClause -> Sem r FunctionClause
|
||||||
goFunctionClause n c = do
|
goFunctionClause n c = do
|
||||||
_clauseBody' <- goExpression (c ^. Abstract.clauseBody)
|
_clauseBody' <- goExpression (c ^. Abstract.clauseBody)
|
||||||
_clausePatterns' <- mapM goPattern (c ^. Abstract.clausePatterns)
|
_clausePatterns' <- mapM goPatternArg (c ^. Abstract.clausePatterns)
|
||||||
return
|
return
|
||||||
FunctionClause
|
FunctionClause
|
||||||
{ _clauseName = n,
|
{ _clauseName = n,
|
||||||
@ -171,17 +171,25 @@ goFunctionClause n c = do
|
|||||||
_clauseBody = _clauseBody'
|
_clauseBody = _clauseBody'
|
||||||
}
|
}
|
||||||
|
|
||||||
|
goPatternArg :: Abstract.PatternArg -> Sem r PatternArg
|
||||||
|
goPatternArg p = do
|
||||||
|
pat' <- goPattern (p ^. Abstract.patternArgPattern)
|
||||||
|
return
|
||||||
|
PatternArg
|
||||||
|
{ _patternArgIsImplicit = p ^. Abstract.patternArgIsImplicit,
|
||||||
|
_patternArgPattern = pat'
|
||||||
|
}
|
||||||
|
|
||||||
goPattern :: Abstract.Pattern -> Sem r Pattern
|
goPattern :: Abstract.Pattern -> Sem r Pattern
|
||||||
goPattern p = case p of
|
goPattern p = case p of
|
||||||
Abstract.PatternVariable v -> return (PatternVariable v)
|
Abstract.PatternVariable v -> return (PatternVariable v)
|
||||||
Abstract.PatternConstructorApp c -> PatternConstructorApp <$> goConstructorApp c
|
Abstract.PatternConstructorApp c -> PatternConstructorApp <$> goConstructorApp c
|
||||||
Abstract.PatternWildcard i -> return (PatternWildcard i)
|
Abstract.PatternWildcard i -> return (PatternWildcard i)
|
||||||
Abstract.PatternBraces b -> PatternBraces <$> goPattern b
|
|
||||||
Abstract.PatternEmpty -> unsupported "pattern empty"
|
Abstract.PatternEmpty -> unsupported "pattern empty"
|
||||||
|
|
||||||
goConstructorApp :: Abstract.ConstructorApp -> Sem r ConstructorApp
|
goConstructorApp :: Abstract.ConstructorApp -> Sem r ConstructorApp
|
||||||
goConstructorApp c = do
|
goConstructorApp c = do
|
||||||
_constrAppParameters' <- mapM goPattern (c ^. Abstract.constrAppParameters)
|
_constrAppParameters' <- mapM goPatternArg (c ^. Abstract.constrAppParameters)
|
||||||
return
|
return
|
||||||
ConstructorApp
|
ConstructorApp
|
||||||
{ _constrAppConstructor = c ^. Abstract.constrAppConstructor . Abstract.constructorRefName,
|
{ _constrAppConstructor = c ^. Abstract.constrAppConstructor . Abstract.constructorRefName,
|
||||||
|
@ -315,11 +315,17 @@ goFunctionClause funSig argTyps clause = do
|
|||||||
projCtor :: Text -> Expression
|
projCtor :: Text -> Expression
|
||||||
projCtor ctorArg = functionCall (ExpressionVar (asProjName ctorArg ctorName)) [castToType ty arg]
|
projCtor ctorArg = functionCall (ExpressionVar (asProjName ctorArg ctorName)) [castToType ty arg]
|
||||||
subConditions :: Sem r [Expression]
|
subConditions :: Sem r [Expression]
|
||||||
subConditions = fmap concat (zipWithM patternCondition (map projCtor ctorArgs) _constrAppParameters)
|
subConditions =
|
||||||
|
fmap
|
||||||
|
concat
|
||||||
|
( zipWithM
|
||||||
|
patternCondition
|
||||||
|
(map projCtor ctorArgs)
|
||||||
|
(_constrAppParameters ^.. each . Micro.patternArgPattern)
|
||||||
|
)
|
||||||
fmap (isCtor :) subConditions
|
fmap (isCtor :) subConditions
|
||||||
Micro.PatternVariable {} -> return []
|
Micro.PatternVariable {} -> return []
|
||||||
Micro.PatternWildcard {} -> return []
|
Micro.PatternWildcard {} -> return []
|
||||||
Micro.PatternBraces b -> patternCondition arg b
|
|
||||||
|
|
||||||
clauseCondition :: Sem r (Maybe Expression)
|
clauseCondition :: Sem r (Maybe Expression)
|
||||||
clauseCondition = fmap (foldr1 f) . nonEmpty <$> conditions
|
clauseCondition = fmap (foldr1 f) . nonEmpty <$> conditions
|
||||||
|
@ -174,7 +174,14 @@ typeOfConstructor name = do
|
|||||||
getInductiveCType (info ^. Micro.constructorInfoInductive)
|
getInductiveCType (info ^. Micro.constructorInfoInductive)
|
||||||
|
|
||||||
getClausePatterns :: Member (Reader Micro.TypesTable) r => Micro.FunctionClause -> Sem r [Micro.Pattern]
|
getClausePatterns :: Member (Reader Micro.TypesTable) r => Micro.FunctionClause -> Sem r [Micro.Pattern]
|
||||||
getClausePatterns c = filterCompileTimeArgsOrPatterns (c ^. Micro.clauseName) (c ^. Micro.clausePatterns)
|
getClausePatterns c =
|
||||||
|
filterCompileTimeArgsOrPatterns
|
||||||
|
(c ^. Micro.clauseName)
|
||||||
|
( c
|
||||||
|
^.. Micro.clausePatterns
|
||||||
|
. each
|
||||||
|
. Micro.patternArgPattern
|
||||||
|
)
|
||||||
|
|
||||||
functionInfoPatternsNum :: Member (Reader Micro.TypesTable) r => Micro.FunctionInfo -> Sem r Int
|
functionInfoPatternsNum :: Member (Reader Micro.TypesTable) r => Micro.FunctionInfo -> Sem r Int
|
||||||
functionInfoPatternsNum fInfo = do
|
functionInfoPatternsNum fInfo = do
|
||||||
@ -203,9 +210,8 @@ buildPatternInfoTable argTyps c =
|
|||||||
return
|
return
|
||||||
[(v ^. Micro.nameText, BindingInfo {_bindingInfoExpr = exp, _bindingInfoType = typ})]
|
[(v ^. Micro.nameText, BindingInfo {_bindingInfoExpr = exp, _bindingInfoType = typ})]
|
||||||
Micro.PatternConstructorApp Micro.ConstructorApp {..} ->
|
Micro.PatternConstructorApp Micro.ConstructorApp {..} ->
|
||||||
goConstructorApp exp _constrAppConstructor _constrAppParameters
|
goConstructorApp exp _constrAppConstructor (_constrAppParameters ^.. each . Micro.patternArgPattern)
|
||||||
Micro.PatternWildcard {} -> return []
|
Micro.PatternWildcard {} -> return []
|
||||||
Micro.PatternBraces b -> go (b, (exp, typ))
|
|
||||||
|
|
||||||
goConstructorApp :: Expression -> Micro.Name -> [Micro.Pattern] -> Sem r [(Text, BindingInfo)]
|
goConstructorApp :: Expression -> Micro.Name -> [Micro.Pattern] -> Sem r [(Text, BindingInfo)]
|
||||||
goConstructorApp exp constructorName ps = do
|
goConstructorApp exp constructorName ps = do
|
||||||
|
@ -359,7 +359,7 @@ goFunctionDefConcrete n d = do
|
|||||||
goClause :: Micro.FunctionClause -> Sem r FunctionClause
|
goClause :: Micro.FunctionClause -> Sem r FunctionClause
|
||||||
goClause c = do
|
goClause c = do
|
||||||
body' <- goExpression (c ^. Micro.clauseBody)
|
body' <- goExpression (c ^. Micro.clauseBody)
|
||||||
patterns' <- zipWithM goPattern' patternTys (c ^. Micro.clausePatterns)
|
patterns' <- zipWithM goPatternArg patternTys (c ^. Micro.clausePatterns)
|
||||||
return
|
return
|
||||||
FunctionClause
|
FunctionClause
|
||||||
{ _clauseName = funName,
|
{ _clauseName = funName,
|
||||||
@ -437,7 +437,7 @@ goFunctionDefPoly def poly
|
|||||||
pvars' <- mapM cloneName' pvars
|
pvars' <- mapM cloneName' pvars
|
||||||
let localVarsRename :: Micro.Rename
|
let localVarsRename :: Micro.Rename
|
||||||
localVarsRename = HashMap.fromList (zipExact pvars pvars')
|
localVarsRename = HashMap.fromList (zipExact pvars pvars')
|
||||||
_clausePatterns = map (Micro.renamePattern localVarsRename) patsTail
|
_clausePatterns = map (Micro.renamePatternArg localVarsRename) patsTail
|
||||||
_clauseBody =
|
_clauseBody =
|
||||||
Micro.substitutionE
|
Micro.substitutionE
|
||||||
(concreteSubsE <> Micro.renameToSubsE localVarsRename)
|
(concreteSubsE <> Micro.renameToSubsE localVarsRename)
|
||||||
@ -448,19 +448,21 @@ goFunctionDefPoly def poly
|
|||||||
..
|
..
|
||||||
}
|
}
|
||||||
where
|
where
|
||||||
patsTail :: [Micro.Pattern]
|
patsTail :: [Micro.PatternArg]
|
||||||
patsTail = dropExact (length tyVars) (c ^. Micro.clausePatterns)
|
patsTail = dropExact (length tyVars) (c ^. Micro.clausePatterns)
|
||||||
pvars :: [Micro.VarName]
|
pvars :: [Micro.VarName]
|
||||||
pvars = concatMap Micro.patternVariables patsTail
|
pvars = concatMap (^.. Micro.patternArgVariables) patsTail
|
||||||
sig' :: Micro.ConcreteType
|
sig' :: Micro.ConcreteType
|
||||||
sig' = Micro.substitutionConcrete (i ^. concreteTypeSubs) tyTail
|
sig' = Micro.substitutionConcrete (i ^. concreteTypeSubs) tyTail
|
||||||
|
|
||||||
goPattern' :: forall r. Members '[Reader ConcreteTable, Reader Micro.InfoTable] r => Micro.ConcreteType -> Micro.Pattern -> Sem r Pattern
|
goPatternArg :: forall r. Members '[Reader ConcreteTable, Reader Micro.InfoTable] r => Micro.ConcreteType -> Micro.PatternArg -> Sem r Pattern
|
||||||
goPattern' ty = \case
|
goPatternArg ty = goPattern ty . (^. Micro.patternArgPattern)
|
||||||
|
|
||||||
|
goPattern :: forall r. Members '[Reader ConcreteTable, Reader Micro.InfoTable] r => Micro.ConcreteType -> Micro.Pattern -> Sem r Pattern
|
||||||
|
goPattern ty = \case
|
||||||
Micro.PatternVariable v -> return (PatternVariable (goName v))
|
Micro.PatternVariable v -> return (PatternVariable (goName v))
|
||||||
Micro.PatternConstructorApp capp -> PatternConstructorApp <$> goApp capp
|
Micro.PatternConstructorApp capp -> PatternConstructorApp <$> goApp capp
|
||||||
Micro.PatternWildcard {} -> return PatternWildcard
|
Micro.PatternWildcard {} -> return PatternWildcard
|
||||||
Micro.PatternBraces b -> goPattern' ty b
|
|
||||||
where
|
where
|
||||||
goApp :: Micro.ConstructorApp -> Sem r ConstructorApp
|
goApp :: Micro.ConstructorApp -> Sem r ConstructorApp
|
||||||
goApp capp = case ty ^. Micro.unconcreteType of
|
goApp capp = case ty ^. Micro.unconcreteType of
|
||||||
@ -469,7 +471,7 @@ goPattern' ty = \case
|
|||||||
c' = goName (capp ^. Micro.constrAppConstructor)
|
c' = goName (capp ^. Micro.constrAppConstructor)
|
||||||
cInfo <- Micro.lookupConstructor (capp ^. Micro.constrAppConstructor)
|
cInfo <- Micro.lookupConstructor (capp ^. Micro.constrAppConstructor)
|
||||||
let psTysConcrete = map Micro.mkConcreteType' (cInfo ^. Micro.constructorInfoArgs)
|
let psTysConcrete = map Micro.mkConcreteType' (cInfo ^. Micro.constructorInfoArgs)
|
||||||
ps' <- zipWithM goPattern' psTysConcrete (capp ^. Micro.constrAppParameters)
|
ps' <- zipWithM goPatternArg psTysConcrete (capp ^. Micro.constrAppParameters)
|
||||||
return (ConstructorApp c' ps')
|
return (ConstructorApp c' ps')
|
||||||
Micro.ExpressionApplication a -> do
|
Micro.ExpressionApplication a -> do
|
||||||
let getInductive :: Micro.Expression -> Micro.Name
|
let getInductive :: Micro.Expression -> Micro.Name
|
||||||
@ -493,7 +495,7 @@ goPattern' ty = \case
|
|||||||
subs = HashMap.fromList (zipExact tyParamVars (toList instanceTypes))
|
subs = HashMap.fromList (zipExact tyParamVars (toList instanceTypes))
|
||||||
psTysConcrete :: [Micro.ConcreteType]
|
psTysConcrete :: [Micro.ConcreteType]
|
||||||
psTysConcrete = map (Micro.substitutionConcrete subs) psTys
|
psTysConcrete = map (Micro.substitutionConcrete subs) psTys
|
||||||
ps' <- zipWithM goPattern' psTysConcrete (capp ^. Micro.constrAppParameters)
|
ps' <- zipWithM goPatternArg psTysConcrete (capp ^. Micro.constrAppParameters)
|
||||||
return (ConstructorApp c' ps')
|
return (ConstructorApp c' ps')
|
||||||
_ -> impossible
|
_ -> impossible
|
||||||
|
|
||||||
|
@ -174,7 +174,7 @@ goFunctionClause ::
|
|||||||
FunctionClause 'Scoped ->
|
FunctionClause 'Scoped ->
|
||||||
Sem r Abstract.FunctionClause
|
Sem r Abstract.FunctionClause
|
||||||
goFunctionClause FunctionClause {..} = do
|
goFunctionClause FunctionClause {..} = do
|
||||||
_clausePatterns' <- mapM goPattern _clausePatterns
|
_clausePatterns' <- mapM goPatternArg _clausePatterns
|
||||||
_clauseBody' <- goExpression _clauseBody
|
_clauseBody' <- goExpression _clauseBody
|
||||||
goWhereBlock _clauseWhere
|
goWhereBlock _clauseWhere
|
||||||
return
|
return
|
||||||
@ -360,30 +360,44 @@ goPostfixPatternApplication ::
|
|||||||
Sem r Abstract.ConstructorApp
|
Sem r Abstract.ConstructorApp
|
||||||
goPostfixPatternApplication a = uncurry Abstract.ConstructorApp <$> viewApp (PatternPostfixApplication a)
|
goPostfixPatternApplication a = uncurry Abstract.ConstructorApp <$> viewApp (PatternPostfixApplication a)
|
||||||
|
|
||||||
viewApp :: forall r. Pattern -> Sem r (Abstract.ConstructorRef, [Abstract.Pattern])
|
viewApp :: forall r. Pattern -> Sem r (Abstract.ConstructorRef, [Abstract.PatternArg])
|
||||||
viewApp = \case
|
viewApp = \case
|
||||||
PatternConstructor c -> return (goConstructorRef c, [])
|
PatternConstructor c -> return (goConstructorRef c, [])
|
||||||
PatternApplication (PatternApp l r) -> do
|
PatternApplication (PatternApp l r) -> do
|
||||||
r' <- goPattern r
|
r' <- goPatternArg r
|
||||||
second (`snoc` r') <$> viewApp l
|
second (`snoc` r') <$> viewAppLeft l
|
||||||
PatternInfixApplication (PatternInfixApp l c r) -> do
|
PatternInfixApplication (PatternInfixApp l c r) -> do
|
||||||
l' <- goPattern l
|
l' <- goPatternArg l
|
||||||
r' <- goPattern r
|
r' <- goPatternArg r
|
||||||
return (goConstructorRef c, [l', r'])
|
return (goConstructorRef c, [l', r'])
|
||||||
PatternPostfixApplication (PatternPostfixApp l c) -> do
|
PatternPostfixApplication (PatternPostfixApp l c) -> do
|
||||||
l' <- goPattern l
|
l' <- goPatternArg l
|
||||||
return (goConstructorRef c, [l'])
|
return (goConstructorRef c, [l'])
|
||||||
PatternVariable {} -> err
|
PatternVariable {} -> err
|
||||||
PatternWildcard {} -> err
|
PatternWildcard {} -> err
|
||||||
PatternBraces {} -> err
|
|
||||||
PatternEmpty {} -> err
|
PatternEmpty {} -> err
|
||||||
where
|
where
|
||||||
|
viewAppLeft :: PatternArg -> Sem r (Abstract.ConstructorRef, [Abstract.PatternArg])
|
||||||
|
viewAppLeft p
|
||||||
|
-- TODO proper error
|
||||||
|
| Implicit <- p ^. patternArgIsImplicit = error "An implicit pattern cannot be on the left of an application"
|
||||||
|
| otherwise = viewApp (p ^. patternArgPattern)
|
||||||
|
-- TODO proper error
|
||||||
err :: a
|
err :: a
|
||||||
err = error "constructor expected on the left of a pattern application"
|
err = error "constructor expected on the left of a pattern application"
|
||||||
|
|
||||||
goConstructorRef :: ConstructorRef -> Abstract.ConstructorRef
|
goConstructorRef :: ConstructorRef -> Abstract.ConstructorRef
|
||||||
goConstructorRef (ConstructorRef' n) = Abstract.ConstructorRef (goName n)
|
goConstructorRef (ConstructorRef' n) = Abstract.ConstructorRef (goName n)
|
||||||
|
|
||||||
|
goPatternArg :: PatternArg -> Sem r Abstract.PatternArg
|
||||||
|
goPatternArg p = do
|
||||||
|
pat' <- goPattern (p ^. patternArgPattern)
|
||||||
|
return
|
||||||
|
Abstract.PatternArg
|
||||||
|
{ _patternArgIsImplicit = p ^. patternArgIsImplicit,
|
||||||
|
_patternArgPattern = pat'
|
||||||
|
}
|
||||||
|
|
||||||
goPattern :: Pattern -> Sem r Abstract.Pattern
|
goPattern :: Pattern -> Sem r Abstract.Pattern
|
||||||
goPattern p = case p of
|
goPattern p = case p of
|
||||||
PatternVariable a -> return $ Abstract.PatternVariable (goSymbol a)
|
PatternVariable a -> return $ Abstract.PatternVariable (goSymbol a)
|
||||||
@ -393,7 +407,6 @@ goPattern p = case p of
|
|||||||
PatternPostfixApplication a -> Abstract.PatternConstructorApp <$> goPostfixPatternApplication a
|
PatternPostfixApplication a -> Abstract.PatternConstructorApp <$> goPostfixPatternApplication a
|
||||||
PatternWildcard i -> return (Abstract.PatternWildcard i)
|
PatternWildcard i -> return (Abstract.PatternWildcard i)
|
||||||
PatternEmpty -> return Abstract.PatternEmpty
|
PatternEmpty -> return Abstract.PatternEmpty
|
||||||
PatternBraces b -> Abstract.PatternBraces <$> goPattern b
|
|
||||||
|
|
||||||
goAxiom :: Members '[InfoTableBuilder, Error ScoperError, Builtins] r => AxiomDef 'Scoped -> Sem r Abstract.AxiomDef
|
goAxiom :: Members '[InfoTableBuilder, Error ScoperError, Builtins] r => AxiomDef 'Scoped -> Sem r Abstract.AxiomDef
|
||||||
goAxiom a = do
|
goAxiom a = do
|
||||||
|
@ -68,7 +68,7 @@ tests =
|
|||||||
"MicroJuvix"
|
"MicroJuvix"
|
||||||
"ExpectedExplicitPattern.juvix"
|
"ExpectedExplicitPattern.juvix"
|
||||||
$ \case
|
$ \case
|
||||||
ErrExpectedExplicitPattern {} -> Nothing
|
ErrWrongPatternIsImplicit {} -> Nothing
|
||||||
_ -> wrongError,
|
_ -> wrongError,
|
||||||
NegTest
|
NegTest
|
||||||
"Expected explicit argument"
|
"Expected explicit argument"
|
||||||
|
@ -84,6 +84,13 @@ tests =
|
|||||||
$ \case
|
$ \case
|
||||||
ErrWrongType {} -> Nothing
|
ErrWrongType {} -> Nothing
|
||||||
_ -> wrongError,
|
_ -> wrongError,
|
||||||
|
NegTest
|
||||||
|
"Unexpected braces in pattern"
|
||||||
|
"issue1337"
|
||||||
|
"Braces.juvix"
|
||||||
|
$ \case
|
||||||
|
ErrArity (ErrWrongPatternIsImplicit {}) -> Nothing
|
||||||
|
_ -> wrongError,
|
||||||
NegTest
|
NegTest
|
||||||
"Wrong return type name for a constructor of a simple data type"
|
"Wrong return type name for a constructor of a simple data type"
|
||||||
"MicroJuvix"
|
"MicroJuvix"
|
||||||
|
11
tests/negative/258/M.juvix
Normal file
11
tests/negative/258/M.juvix
Normal file
@ -0,0 +1,11 @@
|
|||||||
|
module M;
|
||||||
|
|
||||||
|
inductive Nat {
|
||||||
|
O : Nat;
|
||||||
|
S : Nat -> Nat;
|
||||||
|
};
|
||||||
|
|
||||||
|
fun : Nat -> Nat;
|
||||||
|
fun (S {S {x}}) := x;
|
||||||
|
|
||||||
|
end;
|
0
tests/negative/258/juvix.yaml
Normal file
0
tests/negative/258/juvix.yaml
Normal file
11
tests/negative/issue1337/Braces.juvix
Normal file
11
tests/negative/issue1337/Braces.juvix
Normal file
@ -0,0 +1,11 @@
|
|||||||
|
module Braces;
|
||||||
|
|
||||||
|
inductive Nat {
|
||||||
|
O : Nat;
|
||||||
|
S : Nat -> Nat;
|
||||||
|
};
|
||||||
|
|
||||||
|
fun : Nat -> Nat;
|
||||||
|
fun (S {S {x}}) := x;
|
||||||
|
|
||||||
|
end;
|
0
tests/negative/issue1337/juvix.yaml
Normal file
0
tests/negative/issue1337/juvix.yaml
Normal file
Loading…
Reference in New Issue
Block a user