refactoring

9 files changed, 198 insertions, 148 deletions

diff --git a/TODO b/TODO
index 6c508564..c91f7ea4 100644
--- a/TODO
+++ b/TODO
@@ -93,6 +93,29 @@ done:
 - names have Int identifiers
 
 next:
+- update API docs
+- CHANGELOG
+- better README
+- editor: highlight errors in editor
+- editor: editor socket reconnection
+- register to stackage
+
+
+
+* New Quake map viewer
+  - compiler: HOAS reducer
+
+===== compiler
+* Frequencies & type classes, recursion
+* Extra language features
+* amiguity check & other checks
+* Better error messages
+* Speedup
+
+
+
+
+
 - re-enable ambiguity checks
 - show desugared source code on a tab in the editor
 - compiler optimization: HOAS iterpreter
@@ -109,10 +132,7 @@ next:
           fragment05uniform
 - backend: basic pipeline optimization
 
-- editor: highlight errors in editor
-- editor: editor socket reconnection
 
-- register to stackage
 
 - docs: feature teaser, 2 min paper videos
 - minimal quake videos
diff --git a/src/LambdaCube/Compiler.hs b/src/LambdaCube/Compiler.hs
index 54013b74..91c65666 100644
--- a/src/LambdaCube/Compiler.hs
+++ b/src/LambdaCube/Compiler.hs
@@ -15,7 +15,7 @@ module LambdaCube.Compiler
     , MM, runMM
     , Err
     , catchMM, catchErr
-    , ioFetch
+    , ioFetch, decideFilePath
     , getDef, compileMain, preCompile
     , removeFromCache
 
@@ -25,6 +25,7 @@ module LambdaCube.Compiler
     ) where
 
 import Data.List
+import Data.Maybe
 import Data.Function
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
@@ -46,34 +47,102 @@ import qualified Text.Show.Pretty as PP
 import LambdaCube.IR as IR
 import LambdaCube.Compiler.Pretty hiding ((</>))
 import LambdaCube.Compiler.Parser (Module(..), Export(..), ImportItems (..), runDefParser, parseLC)
+import LambdaCube.Compiler.Lexer (DesugarInfo)
 import LambdaCube.Compiler.Lexer as Exported (Range(..))
-import LambdaCube.Compiler.Infer (PolyEnv(..), showError, joinPolyEnvs, filterPolyEnv, inference_)
+import LambdaCube.Compiler.Infer (showError, inference, GlobalEnv, initEnv)
 import LambdaCube.Compiler.Infer as Exported (Infos, listAllInfos, listTypeInfos, listTraceInfos, Exp, outputType, boolType, trueExp, unfixlabel)
 import LambdaCube.Compiler.CoreToIR
 
 -- inlcude path for: Builtins, Internals and Prelude
 import Paths_lambdacube_compiler (getDataDir)
 
-type EName = String
-type MName = String
+--------------------------------------------------------------------------------
 
-type Modules = Map FilePath (Either Doc (PolyEnv, String))
-type ModuleFetcher m = Maybe FilePath -> MName -> m (FilePath, MName, String)
+readFileStrict :: FilePath -> IO String
+readFileStrict = fmap T.unpack . TIO.readFile
 
--- todo: use RWS
-newtype MMT m a = MMT { runMMT :: ExceptT String (ReaderT (ModuleFetcher (MMT m)) (StateT Modules (WriterT Infos m))) a }
-    deriving (Functor, Applicative, Monad, MonadReader (ModuleFetcher (MMT m)), MonadState Modules, MonadError String, MonadIO, MonadThrow, MonadCatch, MonadMask, MonadWriter Infos)
-type MM = MMT IO
+readFile' :: FilePath -> IO (Maybe (IO String))
+readFile' fname = do
+    b <- doesFileExist fname
+    return $ if b then Just $ readFileStrict fname else Nothing
 
 instance MonadMask m => MonadMask (ExceptT e m) where
     mask f = ExceptT $ mask $ \u -> runExceptT $ f (mapExceptT u)
     uninterruptibleMask = error "not implemented: uninterruptibleMask for ExcpetT"
 
+prettyShowUnlines :: Show a => a -> String
+prettyShowUnlines = goPP 0 . PP.ppShow
+  where
+    goPP _ [] = []
+    goPP n ('"':xs) | isMultilineString xs = "\"\"\"\n" ++ indent ++ go xs where
+        indent = replicate n ' '
+        go ('\\':'n':xs) = "\n" ++ indent ++ go xs
+        go ('\\':c:xs) = '\\':c:go xs
+        go ('"':xs) = "\n" ++ indent ++ "\"\"\"" ++ goPP n xs
+        go (x:xs) = x : go xs
+    goPP n (x:xs) = x : goPP (if x == '\n' then 0 else n+1) xs
+
+    isMultilineString ('\\':'n':xs) = True
+    isMultilineString ('\\':c:xs) = isMultilineString xs
+    isMultilineString ('"':xs) = False
+    isMultilineString (x:xs) = isMultilineString xs
+    isMultilineString [] = False
+
+--------------------------------------------------------------------------------
+
+type MName = String
+type SName = String
+type SourceCode = String
+
+-- file name or module name?
+decideFilePath n
+    | takeExtension n == ".lc" = Left n
+    | otherwise = Right n
+
+dropExtension' e f
+    | takeExtension f == e = dropExtension f
+    | otherwise = error $ "dropExtension: expcted extension: " ++ e ++ " ; filename: " ++ f
+
+fileNameToModuleName n
+    = intercalate "." $ remDot $ (\(a, b) -> map takeDirectory (splitPath a) ++ [b]) $ splitFileName $ dropExtension' ".lc" $ normalise n
+  where
+    remDot (".": xs) = xs
+    remDot xs = xs
+
+moduleNameToFileName n = hn n ++ ".lc"
+  where
+    hn = h []
+    h acc [] = reverse acc
+    h acc ('.':cs) = reverse acc </> hn cs
+    h acc (c: cs) = h (c: acc) cs
+
+type ModuleFetcher m = Maybe FilePath -> Either FilePath MName -> m (FilePath, MName, m SourceCode)
+
+ioFetch :: MonadIO m => [FilePath] -> ModuleFetcher (MMT m x)
+ioFetch paths imp n = do
+    preludePath <- (</> "lc") <$> liftIO getDataDir
+    find $ nubBy ((==) `on` fst) $ map (first normalise . lcModuleFile) $ paths ++ [preludePath]
+  where
+    find ((x, mn): xs) = liftIO (readFile' x) >>= maybe (find xs) (\src -> return (x, mn, liftIO src))
+    find [] = throwError $ show $ "can't find " <+> either (("lc file" <+>) . text) (("module" <+>) . text) n
+                              <+> "in path" <+> hsep (map text paths)
+
+    lcModuleFile path = case n of
+        Left n  -> (path </> n, fileNameToModuleName n)
+        Right n -> (path </> moduleNameToFileName n, n)
+
+--------------------------------------------------------------------------------
+
+-- todo: use RWS
+newtype MMT m x a = MMT { runMMT :: ExceptT String (ReaderT (ModuleFetcher (MMT m x)) (StateT (Modules x) (WriterT Infos m))) a }
+    deriving (Functor, Applicative, Monad, MonadReader (ModuleFetcher (MMT m x)), MonadState (Modules x), MonadError String, MonadIO, MonadThrow, MonadCatch, MonadMask, MonadWriter Infos)
+type MM = MMT IO Infos
+
 mapMMT f (MMT m) = MMT $ f m
 
 type Err a = (Either String a, Infos)
 
-runMM :: Monad m => ModuleFetcher (MMT m) -> MMT m a -> m (Err a) 
+runMM :: Monad m => ModuleFetcher (MMT m x) -> MMT m x a -> m (Err a) 
 runMM fetcher
     = runWriterT
     . flip evalStateT mempty
@@ -87,102 +156,74 @@ catchErr er m = (force <$> m >>= liftIO . evaluate) `catch` getErr `catch` getPM
     getErr (e :: ErrorCall) = catchErr er $ er $ show e
     getPMatchFail (e :: PatternMatchFail) = catchErr er $ er $ show e
 
-catchMM :: Monad m => MMT m a -> (String -> Infos -> MMT m a) -> MMT m a
+catchMM :: Monad m => MMT m x a -> (String -> Infos -> MMT m x a) -> MMT m x a
 catchMM m e = mapMMT (lift . mapReaderT (mapStateT $ lift . runWriterT >=> f) . runExceptT) m >>= either (uncurry e) return
   where
     f ((Right x, m), is) = tell is >> return (Right x, m)
     f ((Left e, m), is) = return (Left (e, is), m)
 
 -- TODO: remove dependent modules from cache too?
-removeFromCache :: Monad m => FilePath -> MMT m ()
+removeFromCache :: Monad m => FilePath -> MMT m x ()
 removeFromCache f = modify $ Map.delete f
 
-readFileStrict :: FilePath -> IO String
-readFileStrict = fmap T.unpack . TIO.readFile
+type Module' x = (SourceCode, DesugarInfo, GlobalEnv, x)
 
-readFile' :: FilePath -> IO (Maybe String)
-readFile' fname = do
-    b <- doesFileExist fname
-    if b then Just <$> readFileStrict fname else return Nothing
+type Modules x = Map FilePath (Either (SourceCode, Module) (Module' x))
 
-ioFetch :: MonadIO m => [FilePath] -> ModuleFetcher (MMT m)
-ioFetch paths imp n = do
-  preludePath <- (</> "lc") <$> liftIO getDataDir
-  let
-    fnames = nubBy ((==) `on` fst) $ map (first normalise) $ concatMap lcModuleFile $ paths ++ [preludePath]
-    lcModuleFile path = g imp
-      where
-        g _ | takeExtension n == ".lc" = [(path </> n, intercalate "." $ remDot $ (\(a, b) -> a ++ [b]) $ map takeDirectory . splitPath *** id $ splitFileName $ dropExtension $ normalise n)]
-            | otherwise = [(path </> hn n ++ ".lc", n)]
-
-        remDot (".": xs) = xs
-        remDot xs = xs
-
-        hn = h []
-        h acc [] = reverse acc
-        h acc ('.':cs) = reverse acc </> hn cs
-        h acc (c: cs) = h (c: acc) cs
-
-    f [] = throwError $ show $ "can't find module" <+> text n <+> "in path" <+> hsep (map text paths)
-    f ((x, mn): xs) = liftIO (readFile' x) >>= \case
-        Nothing -> f xs
-        Just src -> do
-          --liftIO $ putStrLn $ "loading " ++ x
-          return (x, mn, src)
-  f fnames
-
-loadModule :: MonadMask m => Maybe FilePath -> MName -> MMT m (FilePath, PolyEnv)
-loadModule imp mname_ = do
-    fetch <- ask
-    (fname, mname, src) <- fetch imp mname_
+loadModule :: MonadMask m => (Infos -> x) -> Maybe FilePath -> Either FilePath MName -> MMT m x (FilePath, Module' x)
+loadModule ex imp mname_ = do
+    (fname, mname, srcm) <- ask >>= \fetch -> fetch imp mname_
     c <- gets $ Map.lookup fname
     case c of
-        Just (Right (m, _)) -> return (fname, m)
-        Just (Left e) -> throwError $ show $ "cycles in module imports:" <+> pShow mname <+> e
+        Just (Right m) -> return (fname, m)
+        Just (Left (_, e)) -> throwError $ show $ "cycles in module imports:" <+> pShow mname <+> pShow (fst <$> moduleImports e)
         _ -> do
+            src <- srcm
             e <- either (throwError . show) return $ parseLC fname src
-            modify $ Map.insert fname $ Left $ pShow $ map fst $ moduleImports e
+            modify $ Map.insert fname $ Left (src, e)
             let
                 loadModuleImports (m, is) = do
-                    filterPolyEnv (filterImports is) . snd <$> loadModule (Just fname) (snd m)
+                    (_, (_, ds, ge, _)) <- loadModule ex (Just fname) (Right $ snd m)
+                    return (ds{-todo: filter-}, Map.filterWithKey (\k _ -> filterImports is k) ge)
+
+                filterImports (ImportAllBut ns) = not . (`elem` map snd ns)
+                filterImports (ImportJust ns) = (`elem` map snd ns)
             do
                 ms <- mapM loadModuleImports $ moduleImports e
-                x' <- {-trace ("loading " ++ fname) $-} do
-                    env@(PolyEnv ge _ ds) <- joinPolyEnvs False ms
-                    defs <- MMT $ mapExceptT (return . runIdentity) $ runDefParser ds $ definitions e
-                    srcs <- gets $ Map.mapMaybe (either (const Nothing) (Just . snd))
-                    x <- MMT $ mapExceptT (lift . lift . mapWriterT (return . first (left $ showError (Map.insert fname src srcs)) . runIdentity)) $ inference_ env (extensions e) defs
-                    case moduleExports e of
-                            Nothing -> return x
-                            Just es -> joinPolyEnvs False $ flip map es $ \exp -> case exp of
-                                ExportId (snd -> d) -> case  Map.lookup d $ getPolyEnv x of
-                                    Just def -> PolyEnv (Map.singleton d def) mempty mempty{-TODO-}
-                                    Nothing  -> error $ d ++ " is not defined"
-                                ExportModule (snd -> m) | m == mname -> x
-                                ExportModule m -> case [ ms
-                                                       | ((m', is), ms) <- zip (moduleImports e) ms, m' == m] of
-                                    [PolyEnv x infos ds] -> PolyEnv x mempty{-TODO-} ds
-                                    []  -> error $ "empty export list: " ++ show (fname, m, map fst $ moduleImports e, mname)
-                                    _   -> error "export list: internal error"
-                modify $ Map.insert fname $ Right (x', src)
-                return (fname, x')
+                let (ds, ge) = mconcat ms
+                (defs, dsinfo) <- MMT $ mapExceptT (return . runIdentity) $ runDefParser ds $ definitions e
+                srcs <- gets $ fmap $ either fst (\(src, _, _, _) -> src)
+                let
+                    -- todo: better story for info handling
+                    ff (Left e, is) = Left (showError srcs e) <$ tell is
+                    ff (Right ge, is) = return $ Right (mconcat ge, is)
+                (newge, is) <- MMT $ mapExceptT (lift . lift . mapWriterT (return . runIdentity) . (ff <=< runWriterT . flip runReaderT (extensions e, initEnv <> ge))) $ inference defs
+                (ds', ge') <- fmap mconcat $ forM (fromMaybe [ExportModule (mempty, mname)] $ moduleExports e) $ \exp -> case exp of
+                    ExportId (snd -> d) -> case Map.lookup d newge of
+                        Just def -> return (mempty{-TODO-}, Map.singleton d def)
+                        Nothing  -> error $ d ++ " is not defined"
+                    ExportModule (snd -> m) | m == mname -> return (dsinfo, newge)
+                    ExportModule m -> case [ x | ((m', _), x) <- zip (moduleImports e) ms, m' == m] of
+                        [x] -> return x
+                        []  -> throwError $ "empty export list: " ++ show (fname, m, map fst $ moduleImports e, mname)
+                        _   -> error "export list: internal error"
+                let m = (src, ds', ge', ex is)
+                modify $ Map.insert fname $ Right m
+                return (fname, m)
               `catchMM` (\e is -> modify (Map.delete fname) >> tell is >> throwError e)
 
-filterImports (ImportAllBut ns) = not . (`elem` map snd ns)
-filterImports (ImportJust ns) = (`elem` map snd ns)
-
 -- used in runTests
-getDef :: MonadMask m => MName -> EName -> Maybe Exp -> MMT m (FilePath, Either String (Exp, Exp), Infos)
+getDef :: MonadMask m => FilePath -> SName -> Maybe Exp -> MMT m Infos (FilePath, Either String (Exp, Exp), Infos)
 getDef m d ty = do
-    (fname, pe) <- loadModule Nothing m
+    (fname, (_, _, ge, infos)) <- loadModule id Nothing $ Left m
     return
       ( fname
-      , case Map.lookup d $ getPolyEnv pe of
+      , case Map.lookup d ge of
         Just (e, thy, si)
             | Just False <- (== thy) <$> ty -> Left $ "type of " ++ d ++ " should be " ++ show ty ++ " instead of " ++ ppShow thy     -- TODO: better type comparison
             | otherwise -> Right (e, thy)
         Nothing -> Left $ d ++ " is not found"
-      , infos pe
+      , infos
       )
 
 parseAndToCoreMain m = either throwError return . (\(_, e, i) -> flip (,) i <$> e) =<< getDef m "main" (Just outputType)
@@ -190,41 +231,22 @@ parseAndToCoreMain m = either throwError return . (\(_, e, i) -> flip (,) i <$>
 -- | most commonly used interface for end users
 compileMain :: [FilePath] -> IR.Backend -> MName -> IO (Either String IR.Pipeline)
 compileMain path backend fname
-    = fmap ((id +++ fst) . fst) $ runMM (ioFetch path) $ first (compilePipeline backend) <$> parseAndToCoreMain fname
-
--- | Removes the escaping characters from the error message
-removeEscapes = first (removeEscs +++ id)
+    = fmap (right fst . fst) $ runMM (ioFetch path) $ first (compilePipeline backend) <$> parseAndToCoreMain fname
 
 -- used by the compiler-service of the online editor
-preCompile :: (MonadMask m, MonadIO m) => [FilePath] -> [FilePath] -> Backend -> String -> IO (String -> m (Err (IR.Pipeline, Infos)))
+preCompile :: (MonadMask m, MonadIO m) => [FilePath] -> [FilePath] -> Backend -> FilePath -> IO (String -> m (Err (IR.Pipeline, Infos)))
 preCompile paths paths' backend mod = do
-  res <- runMM (ioFetch paths) $ loadModule Nothing mod
+  res <- runMM (ioFetch paths) $ loadModule id Nothing $ Left mod
   case res of
     (Left err, i) -> error $ "Prelude could not compiled: " ++ err
     (Right (_, prelude), _) -> return compile
       where
-        compile src = fmap removeEscapes . runMM fetch $ do
-            modify $ Map.insert ("." </> "Prelude.lc") $ Right (prelude, "<<TODO>>")
+        compile src = fmap (first (left removeEscs)) . runMM fetch $ do
+            modify $ Map.insert ("." </> "Prelude.lc") $ Right prelude
             first (compilePipeline backend) <$> parseAndToCoreMain "Main"
           where
             fetch imp = \case
-                "Prelude" -> return ("./Prelude.lc", "Prelude", undefined)
-                "Main" -> return ("./Main.lc", "Main", src)
+                Right "Prelude" -> return ("./Prelude.lc", "Prelude", undefined)
+                Right "Main"    -> return ("./Main.lc", "Main", return src)
                 n -> ioFetch paths' imp n
 
-prettyShowUnlines :: Show a => a -> String
-prettyShowUnlines = goPP 0 . PP.ppShow
-  where goPP _ [] = []
-        goPP n ('"':xs) | isMultilineString xs = "\"\"\"\n" ++ indent ++ go xs where
-          indent = replicate n ' '
-          go ('\\':'n':xs) = "\n" ++ indent ++ go xs
-          go ('\\':c:xs) = '\\':c:go xs
-          go ('"':xs) = "\n" ++ indent ++ "\"\"\"" ++ goPP n xs
-          go (x:xs) = x : go xs
-        goPP n (x:xs) = x : goPP (if x == '\n' then 0 else n+1) xs
-
-        isMultilineString ('\\':'n':xs) = True
-        isMultilineString ('\\':c:xs) = isMultilineString xs
-        isMultilineString ('"':xs) = False
-        isMultilineString (x:xs) = isMultilineString xs
-        isMultilineString [] = False
diff --git a/src/LambdaCube/Compiler/Infer.hs b/src/LambdaCube/Compiler/Infer.hs
index c43fc8ff..16381ba4 100644
--- a/src/LambdaCube/Compiler/Infer.hs
+++ b/src/LambdaCube/Compiler/Infer.hs
@@ -24,7 +24,7 @@ module LambdaCube.Compiler.Infer
     , initEnv, Env(..), pattern EBind2
     , SI(..), Range(..) -- todo: remove
     , Info(..), Infos, listAllInfos, listTypeInfos, listTraceInfos
-    , PolyEnv(..), joinPolyEnvs, filterPolyEnv, inference_
+    , inference, IM
     , nType, conType, neutType, neutType', appTy, mkConPars, makeCaseFunPars, makeCaseFunPars'
     , MaxDB, unfixlabel
     , ErrorMsg, showError
@@ -42,7 +42,6 @@ import Control.Monad.Except
 import Control.Monad.Reader
 import Control.Monad.Writer
 import Control.Monad.State
-import Control.Monad.Identity
 import Control.Arrow hiding ((<+>))
 import Control.DeepSeq
 
@@ -1366,27 +1365,12 @@ downTo n m = map Var [n+m-1, n+m-2..n]
 
 defined' = Map.keys
 
+-- todo: proper handling of implicit foralls
 addF = asks $ \(exs, ge) -> addForalls exs $ defined' ge
 
 tellType si t = tell $ mkInfoItem (sourceInfo si) $ removeEscs $ showDoc $ mkDoc True (t, TType)
 
 
--------------------------------------------------------------------------------- inference output
-
-data PolyEnv = PolyEnv
-    { getPolyEnv :: GlobalEnv
-    , infos      :: Infos
-    , dsInfo     :: DesugarInfo
-    }
-
-filterPolyEnv p pe = pe { getPolyEnv = Map.filterWithKey (\k _ -> p k) $ getPolyEnv pe }
-
-joinPolyEnvs :: MonadError String m => Bool -> [PolyEnv] -> m PolyEnv
-joinPolyEnvs _ = return . foldr mappend' mempty'           -- todo
-  where
-    mempty' = PolyEnv mempty mempty mempty
-    PolyEnv a b c `mappend'` PolyEnv a' b' c' = PolyEnv (a `mappend` a') (b `mappend` b') (c `joinDesugarInfo` c')
-
 -------------------------------------------------------------------------------- pretty print
 -- todo: do this via conversion to SExp
 
@@ -1522,20 +1506,10 @@ getList (unfixlabel -> ConN FCons [x, xs]) = (x:) <$> getList xs
 getList (unfixlabel -> ConN FNil []) = Just []
 getList _ = Nothing
 
-
--------------------------------------------------------------------------------- main
+-------------------------------------------------------------------------------- tools
 
 mfix' f = ExceptT (mfix (runExceptT . f . either bomb id))
   where bomb e = error $ "mfix (ExceptT): inner computation returned Left value:\n" ++ show e
 
-inference_ :: MonadFix m => PolyEnv -> Extensions -> [Stmt] -> ExceptT ErrorMsg (WriterT Infos m) PolyEnv
-inference_ (PolyEnv pe is _) exts defs = mapExceptT (ff <=< runWriterT . flip runReaderT (exts, initEnv <> pe)) $ inference defs
-  where
-    ff (Left e, is) = do
-        tell is
-        return $ Left e
-    ff (Right ge, is) = do
-        return $ Right $ PolyEnv (mconcat ge) is $ mkDesugarInfo defs
-
 foldlrev f = foldr (flip f)
 
diff --git a/src/LambdaCube/Compiler/Parser.hs b/src/LambdaCube/Compiler/Parser.hs
index e64327de..389d2364 100644
--- a/src/LambdaCube/Compiler/Parser.hs
+++ b/src/LambdaCube/Compiler/Parser.hs
@@ -18,7 +18,6 @@ module LambdaCube.Compiler.Parser
     , debug, isPi, varDB, lowerDB, upDB, notClosed, cmpDB, MaxDB(..), iterateN, traceD
     , parseLC, runDefParser
     , getParamsS, addParamsS, getApps, apps', downToS, addForalls
-    , mkDesugarInfo, joinDesugarInfo
     , Up (..), up1, up
     , Doc, shLam, shApp, shLet, shLet_, shAtom, shAnn, shVar, epar, showDoc, showDoc_, sExpDoc, shCstr, shTuple
     , mtrace, sortDefs
@@ -1008,9 +1007,6 @@ mkDesugarInfo ss =
     hackHList ("HNil", _) = ("HNil", Left (("hlistNilCase", -1), [("HNil", 0)]))
     hackHList x = x
 
-joinDesugarInfo (fm, cm) (fm', cm') = (Map.union fm fm', Map.union cm cm')
-
-
 -------------------------------------------------------------------------------- module exports
 
 data Export = ExportModule SIName | ExportId SIName
@@ -1102,19 +1098,17 @@ parseLC f str
     $ str
 
 --type DefParser = DesugarInfo -> (Either ParseError [Stmt], [PostponedCheck])
-runDefParser :: (MonadFix m, MonadError String m) => DesugarInfo -> DefParser -> m [Stmt]
+runDefParser :: (MonadFix m, MonadError String m) => DesugarInfo -> DefParser -> m ([Stmt], DesugarInfo)
 runDefParser ds_ dp = do
 
-    ((defs, dns), ds) <- mfix $ \ ~(_, ds) -> do
-        let (x, dns) = dp ds
+    (defs, dns, ds) <- mfix $ \ ~(_, _, ds) -> do
+        let (x, dns) = dp (ds <> ds_)
         defs <- either (throwError . show) return x
-        let ds' = mkDesugarInfo defs `joinDesugarInfo` ds_
-        return ((defs, dns), ds')
+        return (defs, dns, mkDesugarInfo defs)
 
     mapM_ (maybe (return ()) throwError) dns
 
-    return $ sortDefs ds defs
-
+    return (sortDefs ds defs, ds)
 
 -------------------------------------------------------------------------------- pretty print
 
diff --git a/testdata/language-features/module/Hello02.out b/testdata/language-features/module/Hello02.out
index 8fcbc3af..71039060 100644
--- a/testdata/language-features/module/Hello02.out
+++ b/testdata/language-features/module/Hello02.out
@@ -1 +1,9 @@
 main is not found
+------------ trace
+hello :: 'String
+world :: 'String
+------------ tooltips
+testdata/language-features/module/Hello02.lc 3:1-3:6  String
+testdata/language-features/module/Hello02.lc 3:9-3:16  String
+testdata/language-features/module/Hello02.lc 4:1-4:6  String
+testdata/language-features/module/Hello02.lc 4:9-4:16  String
diff --git a/testdata/language-features/module/Hello03.out b/testdata/language-features/module/Hello03.out
index 8fcbc3af..899f1f33 100644
--- a/testdata/language-features/module/Hello03.out
+++ b/testdata/language-features/module/Hello03.out
@@ -1 +1,9 @@
 main is not found
+------------ trace
+greeting :: 'Char
+value :: 'Float
+------------ tooltips
+testdata/language-features/module/Hello03.lc 7:1-7:9  Char
+testdata/language-features/module/Hello03.lc 7:12-7:15  Char
+testdata/language-features/module/Hello03.lc 9:1-9:6  Float
+testdata/language-features/module/Hello03.lc 9:9-9:13  Float
diff --git a/testdata/language-features/module/Moduledef08.out b/testdata/language-features/module/Moduledef08.out
index 8fcbc3af..b361bfeb 100644
--- a/testdata/language-features/module/Moduledef08.out
+++ b/testdata/language-features/module/Moduledef08.out
@@ -1 +1,6 @@
 main is not found
+------------ trace
+hello :: 'String
+------------ tooltips
+testdata/language-features/module/Moduledef08.lc 5:1-5:6  String
+testdata/language-features/module/Moduledef08.lc 5:9-5:16  String
diff --git a/testdata/language-features/module/Moduledef09.out b/testdata/language-features/module/Moduledef09.out
index 8fcbc3af..59f23c4d 100644
--- a/testdata/language-features/module/Moduledef09.out
+++ b/testdata/language-features/module/Moduledef09.out
@@ -1 +1,9 @@
 main is not found
+------------ trace
+hello :: 'String
+world :: 'String
+------------ tooltips
+testdata/language-features/module/Moduledef09.lc 5:1-5:6  String
+testdata/language-features/module/Moduledef09.lc 5:9-5:16  String
+testdata/language-features/module/Moduledef09.lc 6:1-6:6  String
+testdata/language-features/module/Moduledef09.lc 6:9-6:16  String
diff --git a/testdata/language-features/module/Moduledef10.out b/testdata/language-features/module/Moduledef10.out
index 8fcbc3af..466f5547 100644
--- a/testdata/language-features/module/Moduledef10.out
+++ b/testdata/language-features/module/Moduledef10.out
@@ -1 +1,12 @@
 main is not found
+------------ trace
+hello :: 'String
+world :: 'String
+value :: ()
+------------ tooltips
+testdata/language-features/module/Moduledef10.lc 6:1-6:6  String
+testdata/language-features/module/Moduledef10.lc 6:9-6:16  String
+testdata/language-features/module/Moduledef10.lc 7:1-7:6  String
+testdata/language-features/module/Moduledef10.lc 7:9-7:16  String
+testdata/language-features/module/Moduledef10.lc 9:1-9:6  ()
+testdata/language-features/module/Moduledef10.lc 9:9-9:11  ()