From 838f88bcf9572eb77b4a00e847f8d06fcc227a20 Mon Sep 17 00:00:00 2001 From: Péter Diviánszky Date: Fri, 22 Jan 2016 22:04:18 +0100 Subject: do not allow multiple alternatives for 0 arity functions --- src/LambdaCube/Compiler/Infer.hs | 28 ++++++++++++---------- .../basic-values/redefine02.reject.lc | 3 +++ .../basic-values/redefine02.reject.out | 3 +++ .../basic-values/redefine02.reject.wip.lc | 3 --- .../basic-values/redefine03.reject.lc | 3 +++ .../basic-values/redefine03.reject.out | 4 ++++ .../basic-values/redefine03.reject.wip.lc | 3 --- 7 files changed, 28 insertions(+), 19 deletions(-) create mode 100644 testdata/language-features/basic-values/redefine02.reject.lc create mode 100644 testdata/language-features/basic-values/redefine02.reject.out delete mode 100644 testdata/language-features/basic-values/redefine02.reject.wip.lc create mode 100644 testdata/language-features/basic-values/redefine03.reject.lc create mode 100644 testdata/language-features/basic-values/redefine03.reject.out delete mode 100644 testdata/language-features/basic-values/redefine03.reject.wip.lc diff --git a/src/LambdaCube/Compiler/Infer.hs b/src/LambdaCube/Compiler/Infer.hs index c3b13b82..00106612 100644 --- a/src/LambdaCube/Compiler/Infer.hs +++ b/src/LambdaCube/Compiler/Infer.hs @@ -1853,19 +1853,21 @@ compileFunAlts par ulend lend ge ds = \case [] -> return tf -- builtin type family alts -> compileFunAlts True id SLabelEnd ge [TypeAnn n $ addParamsS ps t] alts [p@PrecDef{}] -> return [p] - fs@((FunAlt n vs _): _) - | ls@(_:_:_) <- map head $ group [length vs | FunAlt _ vs _ <- fs] -> fail $ "different number of arguments of " ++ snd n ++ " at " ++ showSIRange (fst n) - | any (== n) [n' | TypeFamily n' _ _ <- ds] -> return [] - | otherwise -> return - [ Let n - (listToMaybe [t | PrecDef n' t <- ds, n' == n]) - (listToMaybe [t | TypeAnn n' t <- ds, n' == n]) - (map (fst . fst) vs) - (foldr (uncurry SLam) (compileGuardTrees par ulend lend ge - [ compilePatts (zip (map snd vs) $ reverse [0..length vs - 1]) gsx - | FunAlt _ vs gsx <- fs - ]) (map fst vs)) - ] + fs@((FunAlt n vs _): _) -> case map head $ group [length vs | FunAlt _ vs _ <- fs] of + [num] + | num == 0 && length fs > 1 -> fail $ "redefined " ++ snd n ++ " at " ++ showSIRange (fst n) + | any (== n) [n' | TypeFamily n' _ _ <- ds] -> return [] + | otherwise -> return + [ Let n + (listToMaybe [t | PrecDef n' t <- ds, n' == n]) + (listToMaybe [t | TypeAnn n' t <- ds, n' == n]) + (map (fst . fst) vs) + (foldr (uncurry SLam) (compileGuardTrees par ulend lend ge + [ compilePatts (zip (map snd vs) $ reverse [0.. num - 1]) gsx + | FunAlt _ vs gsx <- fs + ]) (map fst vs)) + ] + _ -> fail $ "different number of arguments of " ++ snd n ++ " at " ++ showSIRange (fst n) x -> return x where noTA x = ((Visible, Wildcard SType), x) diff --git a/testdata/language-features/basic-values/redefine02.reject.lc b/testdata/language-features/basic-values/redefine02.reject.lc new file mode 100644 index 00000000..7510e602 --- /dev/null +++ b/testdata/language-features/basic-values/redefine02.reject.lc @@ -0,0 +1,3 @@ +unit = let x = () + x = () + in () \ No newline at end of file diff --git a/testdata/language-features/basic-values/redefine02.reject.out b/testdata/language-features/basic-values/redefine02.reject.out new file mode 100644 index 00000000..790b6e63 --- /dev/null +++ b/testdata/language-features/basic-values/redefine02.reject.out @@ -0,0 +1,3 @@ +"testdata/language-features/basic-values/redefine02.reject.lc" (line 3, column 9): +expecting lowercase ident, uppercase ident or operator definition +Invalid indentation. Found a token at indentation 8. Expecting a token at an indentation greater than or equal to 13.IndentStream {indentationState = IndentationState {minIndentation = 13, maxIndentation = 14, absMode = False, tokenRel = Ge}, tokenStream = ""} or Invalid indentation. Found a token at indentation 8. Expecting a token at an indentation greater than or equal to 12.IndentStream {indentationState = IndentationState {minIndentation = 12, maxIndentation = 12, absMode = False, tokenRel = Ge}, tokenStream = ""} \ No newline at end of file diff --git a/testdata/language-features/basic-values/redefine02.reject.wip.lc b/testdata/language-features/basic-values/redefine02.reject.wip.lc deleted file mode 100644 index 7510e602..00000000 --- a/testdata/language-features/basic-values/redefine02.reject.wip.lc +++ /dev/null @@ -1,3 +0,0 @@ -unit = let x = () - x = () - in () \ No newline at end of file diff --git a/testdata/language-features/basic-values/redefine03.reject.lc b/testdata/language-features/basic-values/redefine03.reject.lc new file mode 100644 index 00000000..62e5705e --- /dev/null +++ b/testdata/language-features/basic-values/redefine03.reject.lc @@ -0,0 +1,3 @@ +unit = () + where x = () + x = () diff --git a/testdata/language-features/basic-values/redefine03.reject.out b/testdata/language-features/basic-values/redefine03.reject.out new file mode 100644 index 00000000..05f009e1 --- /dev/null +++ b/testdata/language-features/basic-values/redefine03.reject.out @@ -0,0 +1,4 @@ +"testdata/language-features/basic-values/redefine03.reject.lc" (line 4, column 1): +unexpected end of input +expecting ".", "%", character, literal string, float, "#", natural, "_", "'", lowercase ident, "(", uppercase ident, "[", List comprehension, "{", "let", "@", symbols, ":", backquoted, "::", "~", "->", "=>", "where", "data", "class", "instance", "type", "infix", "infixl", "infixr" or operator definition +redefined x at testdata/language-features/basic-values/redefine03.reject.lc 2:9-2:10 \ No newline at end of file diff --git a/testdata/language-features/basic-values/redefine03.reject.wip.lc b/testdata/language-features/basic-values/redefine03.reject.wip.lc deleted file mode 100644 index 62e5705e..00000000 --- a/testdata/language-features/basic-values/redefine03.reject.wip.lc +++ /dev/null @@ -1,3 +0,0 @@ -unit = () - where x = () - x = () -- cgit v1.2.3