bugfix

8 files changed, 71 insertions, 48 deletions

diff --git a/src/LambdaCube/Compiler/Infer.hs b/src/LambdaCube/Compiler/Infer.hs
index b6216f74..25b37526 100644
--- a/src/LambdaCube/Compiler/Infer.hs
+++ b/src/LambdaCube/Compiler/Infer.hs
@@ -252,7 +252,7 @@ pmLabel :: FunName -> Int -> [Exp] -> Exp -> Exp
 pmLabel _ _ _ (unlabel'' -> LabelEnd y) = y
 pmLabel f i xs y@Neut{} = PMLabel f i xs y
 pmLabel f i xs y@Lam{} = PMLabel f i xs y
---pmLabel f i xs y = trace_ (ppShow y) $ PMLabel f i xs y
+pmLabel f i xs y = error $ "pmLabel: " ++ show y
 
 pattern UL a <- (unlabel -> a) where UL = unlabel
 
@@ -1443,10 +1443,11 @@ trLight exs = traceLevel exs >= 1
 
 inference_ :: PolyEnv -> Module -> ErrorT (WriterT Infos Identity) PolyEnv
 inference_ (PolyEnv pe is) m = ff $ runWriter $ runExceptT $ mdo
-    let (x, dns) = definitions m $ mkDesugarInfo defs `joinDesugarInfo` extractDesugarInfo pe
+    let (x, dns) = definitions m ds
+        ds = mkDesugarInfo defs `joinDesugarInfo` extractDesugarInfo pe
     defs <- either (throwError . ErrorMsg) return x
     mapM_ (maybe (return ()) (throwErrorTCM . text)) dns
-    mapExceptT (fmap $ ErrorMsg +++ snd) . flip runStateT (initEnv <> pe) . flip runReaderT (extensions m, sourceCode m) . mapM_ (handleStmt defs) $ sortDefs defs
+    mapExceptT (fmap $ ErrorMsg +++ snd) . flip runStateT (initEnv <> pe) . flip runReaderT (extensions m, sourceCode m) . mapM_ (handleStmt defs) $ sortDefs ds defs
   where
     ff (Left e, is) = throwError e
     ff (Right ge, is) = do
diff --git a/src/LambdaCube/Compiler/Parser.hs b/src/LambdaCube/Compiler/Parser.hs
index 3cce82ed..c8b78b0e 100644
--- a/src/LambdaCube/Compiler/Parser.hs
+++ b/src/LambdaCube/Compiler/Parser.hs
@@ -469,7 +469,7 @@ parseTerm prec = withRange setSI $ case prec of
                     ])
          `SAppV` exp
 
-    letdecl = mkLets False <$ reserved "let" <*> dsInfo <*> valueDef
+    letdecl = mkLets False <$ reserved "let" <*> dsInfo <*> (compileFunAlts' id =<< valueDef)
 
     boolExpression = (\pred e -> SBuiltin "primIfThenElse" `SAppV` pred `SAppV` e `SAppV` SBuiltin "Nil") <$> parseTerm PrecLam
 
@@ -674,12 +674,12 @@ compileGuardTrees False ulend lend ge alts = compileGuardTree ulend lend ge $ Al
 compileGuardTrees True ulend lend ge alts = foldr1 (SAppV2 $ SBuiltin "parEval" `SAppV` Wildcard SType) $ compileGuardTree ulend lend ge <$> alts
 
 compileGuardTree :: (SExp -> SExp) -> (SExp -> SExp) -> DesugarInfo -> GuardTree -> SExp
-compileGuardTree unode node adts t = (\x -> traceD ("  !  :" ++ ppShow x) x) $ guardTreeToCases t
+compileGuardTree ulend lend adts t = (\x -> traceD ("  !  :" ++ ppShow x) x) $ guardTreeToCases t
   where
     guardTreeToCases :: GuardTree -> SExp
     guardTreeToCases t = case alts t of
-        [] -> unode $ SBuiltin "undefined"
-        GuardLeaf e: _ -> node e
+        [] -> ulend $ SBuiltin "undefined"
+        GuardLeaf e: _ -> lend e
         ts@(GuardNode f s _ _: _) -> case Map.lookup s (snd adts) of
             Nothing -> error $ "Constructor is not defined: " ++ s
             Just (Left ((t, inum), cns)) ->
@@ -852,16 +852,20 @@ valueDef :: P [Stmt]
 valueDef = do
     (dns, p) <- try "pattern" $ longPattern <* reservedOp "="
     checkPattern dns
-    let n = mangleNames dns
     e <- localIndentation Gt $ parseETerm PrecLam
     ds <- dsInfo
-    -- todo: more sharing
-    return $ Let n Nothing Nothing [] e
-           : [ Let x Nothing Nothing [] $ compileCase ds e [(p, Right $ SVar x i)]
-             | (i, x) <- zip [0..] dns
-             ]
+    return $ desugarValueDef ds p e
+
+desugarValueDef ds p e
+    = FunAlt n [] (Right e)
+    : [ FunAlt x [] $ Right $ compileCase ds (SGlobal n) [(p, Right $ SVar x i)]
+      | (i, x) <- zip [0..] dns
+      ]
   where
-    mangleNames xs = (foldMap fst xs, "_" ++ intercalate "_" (map snd xs))
+    dns = getPVars p
+    n = mangleNames dns
+
+mangleNames xs = (foldMap fst xs, "_" ++ intercalate "_" (map snd xs))
 
 parseSomeGuards f = do
     pos <- sourceColumn <$> getPosition <* reservedOp "|"
@@ -877,7 +881,7 @@ parseSomeGuards f = do
       <*> option [] (parseSomeGuards (== pos))
 
 mkLets :: Bool -> DesugarInfo -> [Stmt]{-where block-} -> SExp{-main expression-} -> SExp{-big let with lambdas; replaces global names with de bruijn indices-}
-mkLets a b = mkLets' a b . sortDefs where
+mkLets a ds = mkLets' a ds . sortDefs ds where
     mkLets' _ _ [] e = e
     mkLets' False ge (Let n _ mt ar x: ds) e | not $ usedS n x
         = SLet (False, n, SData Nothing, ar) (maybe id (flip SAnn . addForalls {-todo-}[] []) mt x) (substSG0 n $ mkLets' False ge ds e)
@@ -904,7 +908,7 @@ defined defs = ("'Type":) $ flip foldMap defs $ \case
 
 -------------------------------------------------------------------------------- declaration desugaring
 
-sortDefs xs = topSort mempty mempty mempty nodes
+sortDefs ds xs = concatMap (desugarMutual ds) $ topSort mempty mempty mempty mempty nodes
   where
     nodes = zip (zip [0..] xs) $ map (def &&& need) xs
     need = \case
@@ -916,11 +920,29 @@ sortDefs xs = topSort mempty mempty mempty nodes
         Let n _ _ _ _ -> Set.singleton n
         Data n _ _ _ cs -> Set.singleton n <> Set.fromList (map fst cs)
     freeS' = Set.fromList . freeS
-    topSort _ _ _ [] = []
-    topSort out defs vs (x@((i, v), (d, u)): ns)
-        | i `elem` out = topSort out defs vs ns
-        | i `elem` vs || all (`elem` defs) u = v: topSort (Set.insert i out) (d <> defs) (Set.delete i vs) ns
-        | otherwise = topSort out defs (Set.insert i vs) $ [x | x@(_, (d, _)) <- nodes, not $ Set.null $ d `Set.intersection` u] ++ x: ns 
+    topSort acc@(_:_) out defs vs xs | Set.null vs = reverse acc: topSort mempty out defs vs xs
+    topSort [] _ _ _ [] = []
+    topSort acc out defs vs (x@((i, v), (d, u)): ns)
+        | i `elem` out = topSort acc out defs vs ns
+        | i `elem` vs || all (`elem` defs) u = topSort (v: acc) (Set.insert i out) (d <> defs) (Set.delete i vs) ns
+        | otherwise = topSort acc out defs (Set.insert i vs) $ [x | x@(_, (d, _)) <- nodes, not $ Set.null $ d `Set.intersection` u] ++ x: ns 
+
+desugarMutual _ [x] = [x]
+desugarMutual ds xs = xs
+{-
+    = FunAlt n [] (Right e)
+    : [ FunAlt x [] $ Right $ compileCase ds (SGlobal n) [(p, Right $ SVar x i)]
+      | (i, x) <- zip [0..] dns
+      ]
+  where
+    dns = getPVars p
+    n = mangleNames dns
+    (ps, es) = unzip [(n, e) | Let n ~Nothing ~Nothing [] e <- xs]
+    tup = "Tuple" ++ show (length xs)
+    e = dbf' ps $ foldl SAppV (SBuiltin tup) es
+    p = PCon (mempty, tup) $ map (ParPat . pure . PVar) ps
+-}
+
 
 compileFunAlts' lend ds = fmap concat . sequence $ map (compileFunAlts False lend lend ds) $ groupBy h ds where
     h (FunAlt n _ _) (FunAlt m _ _) = m == n
diff --git a/testdata/Prelude.out b/testdata/Prelude.out
index 02ba7641..ca6fc982 100644
--- a/testdata/Prelude.out
+++ b/testdata/Prelude.out
@@ -84,12 +84,11 @@ testdata/Prelude.lc 37:26-37:30  List V6
 testdata/Prelude.lc 37:27-37:28  {a} -> a -> List a -> List a
 testdata/Prelude.lc 37:28-37:30  List V3
 testdata/Prelude.lc 38:10-38:12  V2 -> V2->V2 | V2->V2 | V4
-testdata/Prelude.lc 38:10-38:15  V3
-testdata/Prelude.lc 38:10-38:27  List V1 | List V3
+testdata/Prelude.lc 38:10-38:15  Tuple2 (List V4) (List V3) | Tuple2 (List V5) (List V4) | V3
 testdata/Prelude.lc 38:13-38:15  V2 -> V2->V2 | V2->V2 | V3
 testdata/Prelude.lc 38:19-38:24  {a} -> {b} -> List (Tuple2 a b) -> Tuple2 (List a) (List b)
-testdata/Prelude.lc 38:19-38:27  Tuple2 (List V1) (List V0) | Tuple2 (List V4) (List V3) | Tuple2 (List V5) (List V4)
-testdata/Prelude.lc 38:25-38:27  List (Tuple2 V6 V5) | List (Tuple2 V7 V6) | List V11
+testdata/Prelude.lc 38:19-38:27  Tuple2 (List V1) (List V0)
+testdata/Prelude.lc 38:25-38:27  List V11
 testdata/Prelude.lc 40:1-40:7  {a} -> a->Bool -> List a -> List a
 testdata/Prelude.lc 40:21-40:23  {a} -> List a
 testdata/Prelude.lc 40:21-43:49  List V0 -> List V1 | V0->V1
@@ -209,12 +208,10 @@ testdata/Prelude.lc 71:19-71:20  {a} -> a -> List a -> List a
 testdata/Prelude.lc 71:21-71:23  V3
 testdata/Prelude.lc 71:25-71:27  V3
 testdata/Prelude.lc 71:37-71:39  V2 -> V2->V2 | V2->V2 | V4
-testdata/Prelude.lc 71:37-71:43  V3
-testdata/Prelude.lc 71:37-71:55  V0 | V2
+testdata/Prelude.lc 71:37-71:43  Tuple2 V4 V3 | V3
 testdata/Prelude.lc 71:41-71:43  V2 -> V2->V2 | V2->V2 | V3
-testdata/Prelude.lc 71:47-71:52  List V10 -> Tuple2 V5 V4 | List V8 -> V4 | V8
-testdata/Prelude.lc 71:47-71:55  Tuple2 V1 V0 | Tuple2 V2 V1
-testdata/Prelude.lc 71:53-71:55  List V7 | List V8
+testdata/Prelude.lc 71:47-71:52  V8
+testdata/Prelude.lc 71:53-71:55  List V7
 testdata/Prelude.lc 73:1-73:8  {a} -> (a -> a->Ordering) -> List a -> List a -> List a
 testdata/Prelude.lc 73:12-73:16  List V0
 testdata/Prelude.lc 73:12-77:21  List V0 | V0->V1
diff --git a/testdata/language-features/basic-list/listcomp05.out b/testdata/language-features/basic-list/listcomp05.out
index 55d65bc1..e5314964 100644
--- a/testdata/language-features/basic-list/listcomp05.out
+++ b/testdata/language-features/basic-list/listcomp05.out
@@ -7,6 +7,5 @@ testdata/language-features/basic-list/listcomp05.lc 1:10-1:38  V1 -> List V1
 testdata/language-features/basic-list/listcomp05.lc 1:19-1:26  List Tuple0
 testdata/language-features/basic-list/listcomp05.lc 1:20-1:22  Tuple0
 testdata/language-features/basic-list/listcomp05.lc 1:23-1:25  List Tuple0 | Tuple0
-testdata/language-features/basic-list/listcomp05.lc 1:32-1:33  V1
-testdata/language-features/basic-list/listcomp05.lc 1:32-1:38  Tuple0
+testdata/language-features/basic-list/listcomp05.lc 1:32-1:33  Tuple0 | V1
 testdata/language-features/basic-list/listcomp05.lc 1:36-1:38  Tuple0
diff --git a/testdata/language-features/basic-list/listcomp06.out b/testdata/language-features/basic-list/listcomp06.out
index cfc20330..09e4b2bc 100644
--- a/testdata/language-features/basic-list/listcomp06.out
+++ b/testdata/language-features/basic-list/listcomp06.out
@@ -7,8 +7,7 @@ testdata/language-features/basic-list/listcomp06.lc 1:11-1:45  List Tuple0 -> Li
 testdata/language-features/basic-list/listcomp06.lc 1:20-1:27  List Tuple0
 testdata/language-features/basic-list/listcomp06.lc 1:21-1:23  Tuple0
 testdata/language-features/basic-list/listcomp06.lc 1:24-1:26  List Tuple0 | Tuple0
-testdata/language-features/basic-list/listcomp06.lc 1:33-1:34  V1
-testdata/language-features/basic-list/listcomp06.lc 1:33-1:39  Tuple0
+testdata/language-features/basic-list/listcomp06.lc 1:33-1:34  Tuple0 | V1
 testdata/language-features/basic-list/listcomp06.lc 1:37-1:39  Tuple0
 testdata/language-features/basic-list/listcomp06.lc 1:41-1:45  Bool
 testdata/language-features/basic-list/listcomp06.lc 3:1-3:7  List Tuple0
@@ -19,6 +18,5 @@ testdata/language-features/basic-list/listcomp06.lc 3:20-3:27  List Tuple0
 testdata/language-features/basic-list/listcomp06.lc 3:21-3:23  Tuple0
 testdata/language-features/basic-list/listcomp06.lc 3:24-3:26  List Tuple0 | Tuple0
 testdata/language-features/basic-list/listcomp06.lc 3:29-3:33  Bool
-testdata/language-features/basic-list/listcomp06.lc 3:39-3:40  V1
-testdata/language-features/basic-list/listcomp06.lc 3:39-3:45  Tuple0
+testdata/language-features/basic-list/listcomp06.lc 3:39-3:40  Tuple0 | V1
 testdata/language-features/basic-list/listcomp06.lc 3:43-3:45  Tuple0
diff --git a/testdata/language-features/basic-list/listcomp07.out b/testdata/language-features/basic-list/listcomp07.out
index ff877833..b292bf10 100644
--- a/testdata/language-features/basic-list/listcomp07.out
+++ b/testdata/language-features/basic-list/listcomp07.out
@@ -7,12 +7,10 @@ testdata/language-features/basic-list/listcomp07.lc 1:12-5:21  V1 -> List V1
 testdata/language-features/basic-list/listcomp07.lc 2:17-2:24  List Tuple0
 testdata/language-features/basic-list/listcomp07.lc 2:18-2:20  Tuple0
 testdata/language-features/basic-list/listcomp07.lc 2:21-2:23  List Tuple0 | Tuple0
-testdata/language-features/basic-list/listcomp07.lc 3:16-3:17  V1
-testdata/language-features/basic-list/listcomp07.lc 3:16-3:22  Tuple0
+testdata/language-features/basic-list/listcomp07.lc 3:16-3:17  Tuple0 | V1
 testdata/language-features/basic-list/listcomp07.lc 3:20-3:22  Tuple0
 testdata/language-features/basic-list/listcomp07.lc 4:12-4:16  Bool
-testdata/language-features/basic-list/listcomp07.lc 5:16-5:17  V1
-testdata/language-features/basic-list/listcomp07.lc 5:16-5:21  Tuple0
+testdata/language-features/basic-list/listcomp07.lc 5:16-5:17  Tuple0 | V1
 testdata/language-features/basic-list/listcomp07.lc 5:20-5:21  Tuple0
 testdata/language-features/basic-list/listcomp07.lc 8:1-8:7  List Tuple0
 testdata/language-features/basic-list/listcomp07.lc 8:10-12:11  List Tuple0
@@ -21,12 +19,10 @@ testdata/language-features/basic-list/listcomp07.lc 8:12-11:21  V1 -> List V1
 testdata/language-features/basic-list/listcomp07.lc 8:21-8:28  List Tuple0
 testdata/language-features/basic-list/listcomp07.lc 8:22-8:24  Tuple0
 testdata/language-features/basic-list/listcomp07.lc 8:25-8:27  List Tuple0 | Tuple0
-testdata/language-features/basic-list/listcomp07.lc 9:16-9:17  V1
-testdata/language-features/basic-list/listcomp07.lc 9:16-9:22  Tuple0
+testdata/language-features/basic-list/listcomp07.lc 9:16-9:17  Tuple0 | V1
 testdata/language-features/basic-list/listcomp07.lc 9:20-9:22  Tuple0
 testdata/language-features/basic-list/listcomp07.lc 10:12-10:16  Bool
-testdata/language-features/basic-list/listcomp07.lc 11:16-11:17  V1
-testdata/language-features/basic-list/listcomp07.lc 11:16-11:21  Tuple0
+testdata/language-features/basic-list/listcomp07.lc 11:16-11:17  Tuple0 | V1
 testdata/language-features/basic-list/listcomp07.lc 11:20-11:21  Tuple0
 testdata/language-features/basic-list/listcomp07.lc 14:1-14:7  List Tuple0
 testdata/language-features/basic-list/listcomp07.lc 14:10-20:3  List Tuple0
@@ -35,10 +31,8 @@ testdata/language-features/basic-list/listcomp07.lc 14:12-19:15  V1 -> List V1
 testdata/language-features/basic-list/listcomp07.lc 15:15-15:22  List Tuple0
 testdata/language-features/basic-list/listcomp07.lc 15:16-15:18  Tuple0
 testdata/language-features/basic-list/listcomp07.lc 15:19-15:21  List Tuple0 | Tuple0
-testdata/language-features/basic-list/listcomp07.lc 17:2-17:3  V1
-testdata/language-features/basic-list/listcomp07.lc 17:2-17:8  Tuple0
+testdata/language-features/basic-list/listcomp07.lc 17:2-17:3  Tuple0 | V1
 testdata/language-features/basic-list/listcomp07.lc 17:6-17:8  Tuple0
 testdata/language-features/basic-list/listcomp07.lc 18:7-18:11  Bool
-testdata/language-features/basic-list/listcomp07.lc 19:10-19:11  V1
-testdata/language-features/basic-list/listcomp07.lc 19:10-19:15  Tuple0
+testdata/language-features/basic-list/listcomp07.lc 19:10-19:11  Tuple0 | V1
 testdata/language-features/basic-list/listcomp07.lc 19:14-19:15  Tuple0
diff --git a/testdata/language-features/recursion/mutualConst.lc b/testdata/language-features/recursion/mutualConst.lc
new file mode 100644
index 00000000..92823fd5
--- /dev/null
+++ b/testdata/language-features/recursion/mutualConst.lc
@@ -0,0 +1,11 @@
+
+(a, b) = (True, 'c')
+
+xy = (\x y -> ((1 :: Int): y, 1: x)) (fst xy) (snd xy)
+
+(x, y) = xy
+
+main = a && case x of
+    1: 1: 1: _ -> True
+
+
diff --git a/testdata/language-features/recursion/mutualConst.out b/testdata/language-features/recursion/mutualConst.out
new file mode 100644
index 00000000..65af037c
--- /dev/null
+++ b/testdata/language-features/recursion/mutualConst.out
@@ -0,0 +1 @@
+True
\ No newline at end of file