Permalink
Browse files

- fix of missing error message about mismatch of nr args of functions…

… defined by multiple bindings

- bit of code cleanup of ty beta reduction
  • Loading branch information...
atze
atze committed Mar 20, 2012
1 parent 8c623a1 commit 6f5e9827a7a4ee209685c2d013a936eb3417118e
@@ -107,6 +107,7 @@ DATA Err
%%[5
DATA Err
| Newtype tyNm : {HsName}
+ | FunPatternLengths funNm : {HsName}
%%]
%%[(7 hmtyinfer || hmtyast)
@@ -256,6 +256,11 @@ SEM Err
("Type:" >#< @tyNm)
%%[[99
@range
+%%]]
+ | FunPatternLengths lhs . pp = ppMsgErr ("Nr of arguments to function must be equal for all function alternatives")
+ ("Function:" >#< @funNm)
+%%[[99
+ @range
%%]]
%%]
@@ -1349,37 +1349,41 @@ mkIdDefEH def
%%]
%%[1.mergeFunDefL hs
-mergeFunDefL :: [IdDefOcc] -> ([IdDefOcc],[Err])
-mergeFunDefL ds
+mergeFunDefL :: Range -> [IdDefOcc] -> ([IdDefOcc],[Err])
+mergeFunDefL r ds
= case ds of
[_] -> (ds,[])
(d:_:_)
- -> ([d],[rngLift emptyRange Err_NamesDupIntrod "value" [(ioccNm $ doccOcc $ d,Nothing)]])
+ -> ([d],[rngLift r Err_NamesDupIntrod "value" [(ioccNm $ doccOcc d,Nothing)]])
_ -> ([],[])
%%]
%%[5 -1.mergeFunDefL hs
-mergeFunDefL :: [IdDefOcc] -> ([IdDefOcc],[Err])
-mergeFunDefL ds
+mergeFunDefL :: Range -> [IdDefOcc] -> ([IdDefOcc],[Err])
+mergeFunDefL _ ds
= case ds of
[_] -> (ds,[])
(od : _ : _) | iaspIsFun (doccAsp od)
- -> ([d],[])
+ -> ([d],e)
where (IdAsp_Val_Fun (patf:pats1) _ uniq) = doccAsp od
xSz = length pats1
xNmL = [ mkHNm ("x" ++ show i) | i <- [1..xSz] ]
- xPatL = map (rngLift (doccRange od) EH.PatExpr_Var) xNmL
+ xPatL = map (rngLift r EH.PatExpr_Var) xNmL
b = EH.mkCase'
- (doccRange od) (mkRngProdOpt (doccRange od) $ map (rngLift (doccRange od) EH.Expr_Var) $ xNmL)
+ r (mkRngProdOpt r $ map (rngLift r EH.Expr_Var) $ xNmL)
%%[[8
(Just $ Set.fromList $ map (iaspUniq . doccAsp) ds)
Set.empty
(length xNmL > 1)
%%]]
- $ zipWith (EH.mkAlt (doccRange od))
- [ mkRngProdOpt (doccRange od) $ tail $ iaspPatL $ doccAsp $ d | d <- ds ]
+ $ zipWith (EH.mkAlt r)
+ [ mkRngProdOpt r $ tail $ iaspPatL $ doccAsp d | d <- ds ]
[ iaspBody $ doccAsp $ d | d <- ds ]
- d = mkIdDefOcc (doccOcc od) (IdAsp_Val_Fun (patf:xPatL) b uniq) 0 (doccRange od)
+ d = mkIdDefOcc (doccOcc od) (IdAsp_Val_Fun (patf:xPatL) b uniq) 0 r
+ e | length patLens > 1 = [rngLift r Err_FunPatternLengths (ioccNm $ doccOcc od)]
+ | otherwise = []
+ where patLens = Set.toList $ Set.fromList [ length $ iaspPatL $ doccAsp d | d <- ds ]
+ r = rangeUnions [ doccRange d | d <- ds ]
_ -> ([],[])
%%]
@@ -1401,21 +1405,21 @@ splitOff
idOcc2Defs :: IdDefOccGam -> IdOcc -> [IdDefOcc]
idOcc2Defs idDefOccGam occ = maybe [] id $ gamLookupDup occ idDefOccGam
-mkIdOccEH :: [IdDefOcc] -> ([EH.Decl],[Err])
-mkIdOccEH defs
+mkIdOccEH :: Range -> [IdDefOcc] -> ([EH.Decl],[Err])
+mkIdOccEH r defs
= case defs of
(_:_)
-> (concatMap mkIdDefEH (otherDefs ++ funDef),errL)
where (funDefs,otherDefs) = partition (iaspIsFun . doccAsp) defs
- (funDef,errL) = mergeFunDefL funDefs
+ (funDef,errL) = mergeFunDefL r funDefs
_ -> ([],[])
%%]
%%[1.idDefOccs2Decls hs
-idDefOccs2Decls :: [[IdDefOcc]] -> ([[EH.Decl]],[Err])
-idDefOccs2Decls docss
+idDefOccs2Decls :: Range -> [[IdDefOcc]] -> ([[EH.Decl]],[Err])
+idDefOccs2Decls r docss
= ([concat ds], concat es)
- where (ds,es) = unzip $ map mkIdOccEH $ docss
+ where (ds,es) = unzip $ map (mkIdOccEH r) $ docss
%%]
%%[1.mkIdOccSccEH hs
@@ -1429,13 +1433,13 @@ mkIdOccSccEH r isStrict g moss
where (m,d,e) = foldr mkl (id,[],[]) doss
mkl dos (mke,d,e)
= ((\e -> foldr mkLet e dss) . mke,dss ++ d, es ++ e)
- where (dss,es) = idDefOccs2Decls dos
+ where (dss,es) = idDefOccs2Decls r dos
%%[[1
mkLet ds = EH.mkLet r (Just ds)
%%][8
mkLet ds = EH.mkLet' isStrict r (Just ds)
%%]]
- (sds,ses) = idDefOccs2Decls $ concat $ spls
+ (sds,ses) = idDefOccs2Decls r $ concat $ spls
(doss:spls:_)
= collapse
[ collapse [ splitOff $ idOcc2Defs g $ l | l <- ll ]
View
@@ -381,21 +381,22 @@ pBody' opts addDecl
%%]]
pLhsTail :: HSParser [Pattern]
pLhsTail = pList1 pPatternBaseCon
- pLhs :: HSParser LeftHandSide
- pLhs = mkRngNm LeftHandSide_Function <$> var <*> pLhsTail
+ pLhs :: HSParser (Range,LeftHandSide)
+ pLhs = (\v lhs -> let r = mkRange1 v in (r, LeftHandSide_Function r (tokMkQName v) lhs)) <$> var <*> pLhsTail
<|> pParens'
- ( (\l r t -> mkLP r l t)
+ ( (\l r t -> (r, mkLP r l t))
<$> pLhs
- <|> (\pl o pr r t -> mkLP r (mkLI pl o pr) t)
+ <|> (\pl o pr r t -> (r, mkLP r (mkLI pl o pr) t))
<$> pPatternOp <*> varop <*> pPatternOp
)
<*> pLhsTail
mkP p rhs = Declaration_PatternBinding emptyRange (p2p p) rhs'
where (p2p,rhs') = mkTyPat rhs
- mkF lhs rhs = Declaration_FunctionBindings emptyRange [FunctionBinding_FunctionBinding emptyRange (l2l lhs) rhs']
+ mkF (r,lhs) rhs= Declaration_FunctionBindings r [FunctionBinding_FunctionBinding r (l2l lhs) rhs']
where (l2l,rhs') = mkTyLhs rhs
- mkLI l o r = LeftHandSide_Infix (mkRange1 o) l (tokMkQName o) r
- mkLP r l t = LeftHandSide_Parenthesized r l t
+ mkLI l o rh = (r, LeftHandSide_Infix r l (tokMkQName o) rh)
+ where r = mkRange1 o
+ mkLP r (_,l) t = LeftHandSide_Parenthesized r l t
%%[[1
rhs = pRhs pEQUAL
mkTyLhs rhs = (id,rhs)
View
@@ -993,10 +993,10 @@ GADT: when encountering a product with eq-constraints on the outset, remove them
= case filter (not . foHasErrs) tries of
(fo:_) -> fo
_ -> case (drop limit rt1, drop limit rt2, tries) of
- (((t,tr):_),_ ,_ ) -> err (trfiAdd (tybetaredextraTracePPL tr) fi2) [rngLift range Err_TyBetaRedLimit (fiAppVarMp fi2 t1) (fiAppVarMp fi2 (tbroutRes t)) limit]
- (_ ,((t,tr):_),_ ) -> err (trfiAdd (tybetaredextraTracePPL tr) fi2) [rngLift range Err_TyBetaRedLimit (fiAppVarMp fi2 t2) (fiAppVarMp fi2 (tbroutRes t)) limit]
- (_ ,_ ,ts@(_:_)) -> last ts
- (_ ,_ ,_ ) -> errClash fi2 t1 t2
+ ((t:_),_ ,_ ) -> err (trfiAdd (tbroutTracePPL t) fi2) [rngLift range Err_TyBetaRedLimit (fiAppVarMp fi2 t1) (fiAppVarMp fi2 (tbroutRes t)) limit]
+ (_ ,(t:_),_ ) -> err (trfiAdd (tbroutTracePPL t) fi2) [rngLift range Err_TyBetaRedLimit (fiAppVarMp fi2 t2) (fiAppVarMp fi2 (tbroutRes t)) limit]
+ (_ ,_ ,ts@(_:_)) -> last ts
+ (_ ,_ ,_ ) -> errClash fi2 t1 t2
where limit = ehcOptTyBetaRedCutOffAt globOpts
%%[[11
fi2 = trfi "fTySyn" ("t1:" >#< ppTyWithFI fi t1 >-< "t2:" >#< ppTyWithFI fi t2) fi
@@ -1007,14 +1007,14 @@ GADT: when encountering a product with eq-constraints on the outset, remove them
rt2 = tyBetaRedAndInit (emptyTyBetaRedEnv {tbredFI=fi2}) betaRedTyLookup t2
tries = take (limit+1) $ try fi2 (rt1) (rt2)
where -- get the pairwise fitsIn of further and further expanded synonyms
- try fi ((t1,tr1):ts1@(_:_)) ((t2,tr2):ts2@(_:_)) = (ok tr1 tr2 $ fBase fi' updTy (tbroutRes t1) (tbroutRes t2)) ++ try fi' ts1 ts2
- where fi' = trfiAdd (tybetaredextraTracePPL tr1) $ trfiAdd (tybetaredextraTracePPL tr2) fi
- try fi ts1@[(t1,tr1)] ((t2,tr2):ts2@(_:_)) = (ok tr1 tr2 $ fBase fi' updTy (tbroutRes t1) (tbroutRes t2)) ++ try fi' ts1 ts2
- where fi' = trfiAdd (tybetaredextraTracePPL tr2) fi
- try fi ((t1,tr1):ts1@(_:_)) ts2@[(t2,tr2)] = (ok tr1 tr2 $ fBase fi' updTy (tbroutRes t1) (tbroutRes t2)) ++ try fi' ts1 ts2
- where fi' = trfiAdd (tybetaredextraTracePPL tr1) fi
- try fi [(t1,tr1)] [(t2,tr2)] = ok tr1 tr2 $ fBase fi' updTy (tbroutRes t1) (tbroutRes t2)
- where fi' = fi
+ try fi (t1:ts1@(_:_)) (t2:ts2@(_:_)) = (ok t1 t2 $ fBase fi' updTy (tbroutRes t1) (tbroutRes t2)) ++ try fi' ts1 ts2
+ where fi' = trfiAdd (tbroutTracePPL t1) $ trfiAdd (tbroutTracePPL t2) fi
+ try fi ts1@[t1] (t2:ts2@(_:_)) = (ok t1 t2 $ fBase fi' updTy (tbroutRes t1) (tbroutRes t2)) ++ try fi' ts1 ts2
+ where fi' = trfiAdd (tbroutTracePPL t2) fi
+ try fi (t1:ts1@(_:_)) ts2@[t2] = (ok t1 t2 $ fBase fi' updTy (tbroutRes t1) (tbroutRes t2)) ++ try fi' ts1 ts2
+ where fi' = trfiAdd (tbroutTracePPL t1) fi
+ try fi [t1] [t2] = ok t1 t2 $ fBase fi' updTy (tbroutRes t1) (tbroutRes t2)
+ where fi' = fi
-- check for a valid combi using lookahead info of next expansion
ok e1 e2 f | betaRedIsOkFitsinCombi (fiAllowTyVarBind fi)
e1 e2 = [f]
@@ -33,8 +33,10 @@ For debug/trace:
%%[(11 hmtyinfer) export(TyBetaRedOut,mkDfltTyBetaRedOut,TyBetaRedOut'(..))
data TyBetaRedOut' x
= TyBetaRedOut
- { tbroutRes :: x
- , tbroutVarMp :: VarMp
+ { tbroutRes :: x
+ , tbroutVarMp :: VarMp
+ , tbroutTracePPL :: [PP_Doc]
+ , tbroutExpandedTo :: Maybe TyBetaRedLookAheadExpansion -- 1 expansion step lookahead type function + args
}
type TyBetaRedOut = TyBetaRedOut' Ty
@@ -45,7 +47,7 @@ mkDfltTyBetaRedOut = emptyTyBetaRedOut'
%%[(11 hmtyinfer) export(emptyTyBetaRedOut',emptyTyBetaRedOut)
emptyTyBetaRedOut' :: x -> TyBetaRedOut' x
-emptyTyBetaRedOut' x = TyBetaRedOut x emptyVarMp
+emptyTyBetaRedOut' x = TyBetaRedOut x emptyVarMp [] Nothing
emptyTyBetaRedOut :: TyBetaRedOut' Ty
emptyTyBetaRedOut = emptyTyBetaRedOut' Ty_Any
@@ -55,23 +57,14 @@ emptyTyBetaRedOut = emptyTyBetaRedOut' Ty_Any
%%% Beta reduction extra info
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-%%[(11 hmtyinfer) export(TyBetaRedExtra(..), emptyTyBetaRedExtra)
+%%[(11 hmtyinfer)
-- | expansion lookahead info
type TyBetaRedLookAheadExpansion
= ( Ty -- type function
, [Ty] -- arguments
, Maybe TyBetaRedOut -- function in ty looked up as if it were to be used for expansion
)
--- | extra result info from betared
-data TyBetaRedExtra
- = TyBetaRedExtra
- { tybetaredextraTracePPL :: [PP_Doc]
- , tybetaredextraExpandedTo :: Maybe TyBetaRedLookAheadExpansion -- 1 expansion step lookahead type function + args
- }
-
-emptyTyBetaRedExtra :: TyBetaRedExtra
-emptyTyBetaRedExtra = TyBetaRedExtra [] Nothing
%%]
20100922 AD; Note: it is somewhat a mystery why this is not symmetric but IOBase will fail compilation.
@@ -80,10 +73,10 @@ So, for now, it therefore is somewhat a hack...
%%[(11 hmtyinfer) export(betaRedIsOkFitsinCombi)
-- | check for a valid combi using lookahead info of next expansion.
-- Basically prevent synonyms and lambdas from being bound, but forced to be expanded
-betaRedIsOkFitsinCombi :: (Ty -> Bool) -> TyBetaRedExtra -> TyBetaRedExtra -> Bool
+betaRedIsOkFitsinCombi :: (Ty -> Bool) -> TyBetaRedOut -> TyBetaRedOut -> Bool
betaRedIsOkFitsinCombi isBoundable
- (TyBetaRedExtra {tybetaredextraExpandedTo = Just (fl,al,_ )}) -- a tvar
- (TyBetaRedExtra {tybetaredextraExpandedTo = Just (fr,ar,mbExp)}) -- cannot be bound/matched against non expanded synonym/lambda
+ (TyBetaRedOut {tbroutExpandedTo = Just (fl,al,_ )}) -- a tvar
+ (TyBetaRedOut {tbroutExpandedTo = Just (fr,ar,mbExp)}) -- cannot be bound/matched against non expanded synonym/lambda
| isBoundable fl && not (null ar || null al) && (tyIsLam fr || isJust mbExp)
= False
{-
@@ -135,7 +128,7 @@ betaRedTyLookAhead renv lkup ty
tyBetaRed1
:: (VarLookup gm TyVarId VarMpInfo, VarLookupCmb VarMp gm)
=> TyBetaRedEnv gm -> TyBetaRedLkup gm -> Either Ty TyBetaRedLookAheadExpansion
- -> Maybe (TyBetaRedOut,TyBetaRedExtra)
+ -> Maybe TyBetaRedOut
tyBetaRed1 renv lkup tyOrFunAndArgs
= eval (either (betaRedTyLookAhead renv lkup) id tyOrFunAndArgs)
where -- lambda expression: take body and substitute arguments
@@ -171,10 +164,9 @@ tyBetaRed1 renv lkup tyOrFunAndArgs
eval _ = Nothing
-- utils
- mkres t = Just ( emptyTyBetaRedOut' t
- , emptyTyBetaRedExtra
- { tybetaredextraExpandedTo = Just $ betaRedTyLookAhead renv lkup t
- , tybetaredextraTracePPL = [trfitIn "tylam" ("from:" >#< ppTyWithFI fi (pack tyOrFunAndArgs) >-< "to :" >#< ppTyWithFI fi t)]
+ mkres t = Just ( (emptyTyBetaRedOut' t)
+ { tbroutExpandedTo = Just $ betaRedTyLookAhead renv lkup t
+ , tbroutTracePPL = [trfitIn "tylam" ("from:" >#< ppTyWithFI fi (pack tyOrFunAndArgs) >-< "to :" >#< ppTyWithFI fi t)]
}
)
pack = either id (\(f,as,_) -> mkApp (f:as))
@@ -185,24 +177,24 @@ tyBetaRed1 renv lkup tyOrFunAndArgs
tyBetaRed'
:: (VarLookup gm TyVarId VarMpInfo, VarLookupCmb VarMp gm)
=> TyBetaRedEnv gm -> TyBetaRedLkup gm -> Either Ty TyBetaRedLookAheadExpansion
- -> [(TyBetaRedOut,TyBetaRedExtra)]
+ -> [TyBetaRedOut]
tyBetaRed' renv lkup tyOrFunArgs
= case tyBetaRed1 renv lkup tyOrFunArgs of
- Just (tf@(re,e)) -> tf : tyBetaRed' renv lkup (maybe (Left (tbroutRes re)) Right $ tybetaredextraExpandedTo e)
- _ -> []
+ Just re -> re : tyBetaRed' renv lkup (maybe (Left (tbroutRes re)) Right $ tbroutExpandedTo re)
+ _ -> []
tyBetaRed
:: (VarLookup gm TyVarId VarMpInfo, VarLookupCmb VarMp gm)
=> TyBetaRedEnv gm -> TyBetaRedLkup gm -> Ty
- -> [(TyBetaRedOut,TyBetaRedExtra)]
+ -> [TyBetaRedOut]
tyBetaRed renv lkup ty = tyBetaRed' renv lkup (Left ty)
tyBetaRedAndInit
:: (VarLookup gm TyVarId VarMpInfo, VarLookupCmb VarMp gm)
=> TyBetaRedEnv gm -> TyBetaRedLkup gm -> Ty
- -> [(TyBetaRedOut,TyBetaRedExtra)]
+ -> [TyBetaRedOut]
tyBetaRedAndInit renv lkup ty
- = (emptyTyBetaRedOut' ty, emptyTyBetaRedExtra {tybetaredextraExpandedTo = Just l}) : tyBetaRed' renv lkup (Right l)
+ = ((emptyTyBetaRedOut' ty) {tbroutExpandedTo = Just l}) : tyBetaRed' renv lkup (Right l)
where l = betaRedTyLookAhead renv lkup ty
%%]
@@ -220,7 +212,7 @@ tyBetaRedFullMb renv lkup redSub ty
= fmap reda $ choose ty $ redl ty
where env = fiEnv $ tbredFI renv
lim = ehcOptTyBetaRedCutOffAt $ feEHCOpts env
- redl ty = take lim $ map fst $ tyBetaRed renv lkup ty
+ redl ty = take lim $ tyBetaRed renv lkup ty
reda re = if null (catMaybes as')
then mkDfltTyBetaRedOut ty
else let as'' = zipWith (\t mt -> maybe (mkDfltTyBetaRedOut t) id mt) as as'
@@ -0,0 +1,11 @@
+{- ----------------------------------------------------------------------------------------
+ what : Name analysis, function args
+ expected: error message about mismatch in nr of args
+---------------------------------------------------------------------------------------- -}
+
+module MissingPatternMatch1 where
+
+unwrap Nothing (Just x) = x
+unwrap (Just x) {- missing arg here -} = x
+
+main = return ()

0 comments on commit 6f5e982

Please sign in to comment.