use Doc instead of String is several places

5 files changed, 78 insertions, 67 deletions

diff --git a/src/LambdaCube/Compiler.hs b/src/LambdaCube/Compiler.hs
index 017d629c..4c1b7fd8 100644
--- a/src/LambdaCube/Compiler.hs
+++ b/src/LambdaCube/Compiler.hs
@@ -118,14 +118,14 @@ moduleNameToFileName n = hn n ++ ".lc"
     h acc ('.':cs) = reverse acc </> hn cs
     h acc (c: cs) = h (c: acc) cs
 
-type ModuleFetcher m = Maybe FilePath -> Either FilePath MName -> m (Either String (FilePath, MName, m SourceCode))
+type ModuleFetcher m = Maybe FilePath -> Either FilePath MName -> m (Either Doc (FilePath, MName, m SourceCode))
 
 ioFetch :: MonadIO m => [FilePath] -> ModuleFetcher (MMT m x)
 ioFetch paths' imp n = do
     preludePath <- (</> "lc") <$> liftIO getDataDir
     let paths = paths' ++ [preludePath]
         find ((x, mn): xs) = liftIO (readFile' x) >>= maybe (find xs) (\src -> return $ Right (x, mn, liftIO src))
-        find [] = return $ Left $ show $ "can't find " <+> either (("lc file" <+>) . text) (("module" <+>) . text) n
+        find [] = return $ Left $ "can't find" <+> either (("lc file" <+>) . text) (("module" <+>) . text) n
                                   <+> "in path" <+> hsep (map text (paths' ++ ["<<installed-prelude-path>>"]{-todo-}))
     find $ nubBy ((==) `on` fst) $ map (first normalise . lcModuleFile) paths
   where
@@ -160,7 +160,7 @@ removeFromCache f = modify $ \m@(Modules nm im ni) -> case Map.lookup f nm of
     Nothing -> m
     Just i -> Modules (Map.delete f nm) (IM.delete i im) ni
 
-type Module' x = (SourceCode, Either String{-error msg-} (Module, x, Either String{-error msg-} (DesugarInfo, GlobalEnv)))
+type Module' x = (SourceCode, Either Doc{-error msg-} (Module, x, Either Doc{-error msg-} (DesugarInfo, GlobalEnv)))
 
 data Modules x = Modules
     { moduleIds :: !(Map FilePath Int)
@@ -170,7 +170,7 @@ data Modules x = Modules
 
 (<&>) = flip (<$>)
 
-loadModule :: MonadMask m => ((Infos, [Stmt]) -> x) -> Maybe FilePath -> Either FilePath MName -> MMT m x (Either String (FilePath, Module' x))
+loadModule :: MonadMask m => ((Infos, [Stmt]) -> x) -> Maybe FilePath -> Either FilePath MName -> MMT m x (Either Doc (FilePath, Module' x))
 loadModule ex imp mname_ = do
   r <- ask >>= \fetch -> fetch imp mname_
   case r of
@@ -184,34 +184,34 @@ loadModule ex imp mname_ = do
         fid <- gets nextMId
         modify $ \(Modules nm im ni) -> Modules (Map.insert fname fid nm) im $ ni+1
         res <- case parseLC $ FileInfo fid fname src of
-          Left e -> return $ Left $ show e
+          Left e -> return $ Left $ text $ show e
           Right e -> do
-            modify $ \(Modules nm im ni) -> Modules nm (IM.insert fid (fname, (src, Right (e, ex mempty, Left $ show $ "cycles in module imports:" <+> pShow mname <+> pShow (fst <$> moduleImports e)))) im) ni
+            modify $ \(Modules nm im ni) -> Modules nm (IM.insert fid (fname, (src, Right (e, ex mempty, Left $ "cycles in module imports:" <+> pShow mname <+> pShow (fst <$> moduleImports e)))) im) ni
             ms <- forM (moduleImports e) $ \(m, is) -> loadModule ex (Just fname) (Right $ sName m) <&> \r -> case r of
-                      Left err -> Left $ sName m ++ " couldn't be found"
+                      Left err -> Left $ pShow m <+> "is not found"
                       Right (fb, (src, dsge)) ->
-                         either (Left . const (sName m ++ " couldn't be parsed"))
+                         either (Left . const (pShow m <+> "couldn't be parsed"))
                                 (\(pm, x, e) -> either
-                                    (Left . const (sName m ++ " couldn't be typechecked"))
+                                    (Left . const (pShow m <+> "couldn't be typechecked"))
                                     (\(ds, ge) -> Right (ds{-todo: filter-}, Map.filterWithKey (\k _ -> filterImports is k) ge))
                                     e)
                                 dsge
 
             let (res, err) = case sequence ms of
-                  Left err -> (ex mempty, Left err)
+                  Left err -> (ex mempty, Left $ pShow err)
                   Right ms@(mconcat -> (ds, ge)) -> case runExcept $ runDefParser ds $ definitions e of
-                    Left err -> (ex mempty, Left $ show err)
+                    Left err -> (ex mempty, Left $ pShow err)
                     Right (defs, warnings, dsinfo) -> (,) (ex (map ParseWarning warnings ++ is, defs)) $ case res of
-                      Left err -> Left (show err)
+                      Left err -> Left $ pShow err
                       Right (mconcat -> newge) ->
                         right mconcat $ forM (fromMaybe [ExportModule $ SIName mempty mname] $ moduleExports e) $ \case
                             ExportId (sName -> d) -> case Map.lookup d newge of
                                 Just def -> Right (mempty{-TODO-}, Map.singleton d def)
-                                Nothing  -> Left $ d ++ " is not defined"
+                                Nothing  -> Left $ text d <+> "is not defined"
                             ExportModule (sName -> m) | m == mname -> Right (dsinfo, newge)
                             ExportModule m -> case [ x | ((m', _), x) <- zip (moduleImports e) ms, m' == m] of
                                 [x] -> Right x
-                                []  -> Left $ "empty export list: " ++ show (fname, m, map fst $ moduleImports e, mname)
+                                []  -> Left $ "empty export list in module" <+> text fname -- m, map fst $ moduleImports e, mname)
                                 _   -> error "export list: internal error"
                      where
                         (res, is) = runWriter . flip runReaderT (extensions e, initEnv <> ge) . runExceptT $ inference defs
@@ -224,7 +224,7 @@ loadModule ex imp mname_ = do
     filterImports (ImportJust ns) = (`elem` map sName ns)
 
 -- used in runTests
-getDef :: MonadMask m => FilePath -> SName -> Maybe Exp -> MMT m Infos (Infos, Either String (FilePath, Either String (Exp, Exp)))
+getDef :: MonadMask m => FilePath -> SName -> Maybe Exp -> MMT m Infos (Infos, Either Doc (FilePath, Either Doc (Exp, Exp)))
 getDef = getDef_ fst
 
 getDef_ ex m d ty = loadModule ex Nothing (Left m) <&> \case
@@ -236,37 +236,37 @@ getDef_ ex m d ty = loadModule ex Nothing (Left m) <&> \case
         , case Map.lookup d ge of
           Just (e, thy, si)
             | Just False <- (== thy) <$> ty          -- TODO: better type comparison
-                -> Left $ "type of " ++ d ++ " should be " ++ show ty ++ " instead of " ++ ppShow thy
+                -> Left $ "type of" <+> text d <+> "should be" <+> pShow ty <+> "instead of" <+> pShow thy
             | otherwise -> Right (e, thy)
-          Nothing -> Left $ d ++ " is not found"
+          Nothing -> Left $ text d <+> "is not found"
         )
 
 compilePipeline' ex backend m
     = second (either Left (fmap (compilePipeline backend) . snd)) <$> getDef_ ex m "main" (Just outputType)
 
 -- | most commonly used interface for end users
-compileMain :: [FilePath] -> IR.Backend -> MName -> IO (Either String IR.Pipeline)
+compileMain :: [FilePath] -> IR.Backend -> MName -> IO (Either Doc IR.Pipeline)
 compileMain path backend fname
     = fmap snd $ runMM (ioFetch path) $ compilePipeline' (const ()) backend fname
 
-parseModule :: [FilePath] -> MName -> IO (Either String String)
+parseModule :: [FilePath] -> MName -> IO (Either Doc String)
 parseModule path fname = runMM (ioFetch path) $ loadModule snd Nothing (Left fname) <&> \case
     Left err -> Left err
     Right (fname, (src, Left err)) -> Left err
     Right (fname, (src, Right (pm, infos, _))) -> Right $ pPrintStmts infos
 
 -- used by the compiler-service of the online editor
-preCompile :: (MonadMask m, MonadIO m) => [FilePath] -> [FilePath] -> Backend -> FilePath -> IO (String -> m (Either String IR.Pipeline, (Infos, String)))
+preCompile :: (MonadMask m, MonadIO m) => [FilePath] -> [FilePath] -> Backend -> FilePath -> IO (String -> m (Either Doc IR.Pipeline, (Infos, String)))
 preCompile paths paths' backend mod = do
   res <- runMM (ioFetch paths) $ loadModule ex Nothing $ Left mod
   case res of
-    Left err -> error $ "Prelude could not compiled: " ++ err
+    Left err -> error $ "Prelude could not compiled:" ++ show err
     Right (src, prelude) -> return compile
       where
         compile src = runMM fetch $ do
             let pname = "." </> "Prelude.lc"
             modify $ \(Modules nm im ni) -> Modules (Map.insert pname ni nm) (IM.insert ni (pname, prelude) im) (ni+1)
-            ((left plainShow . snd) &&& fst) <$> compilePipeline' ex backend "Main"
+            (snd &&& fst) <$> compilePipeline' ex backend "Main"
           where
             fetch imp = \case
                 Left "Prelude" -> return $ Right ("./Prelude.lc", "Prelude", undefined)
diff --git a/src/LambdaCube/Compiler/DesugaredSource.hs b/src/LambdaCube/Compiler/DesugaredSource.hs
index c2317615..6fb1cbaa 100644
--- a/src/LambdaCube/Compiler/DesugaredSource.hs
+++ b/src/LambdaCube/Compiler/DesugaredSource.hs
@@ -136,9 +136,10 @@ instance PShow SI where
     pShow (RangeSI r) = pShow r
 
 -- long version
+-- TODO: merge with pShow
 showSI x = case sourceInfo x of
-    RangeSI r -> show $ showRange r
-    x -> ppShow x
+    RangeSI r -> showRange r
+    x -> pShow x
 
 hashPos :: FileInfo -> SPos -> Int
 hashPos fn (SPos r c) = fileId fn `shiftL` 32 .|. r `shiftL` 16 .|. c
diff --git a/src/LambdaCube/Compiler/Infer.hs b/src/LambdaCube/Compiler/Infer.hs
index 74e0c4d6..e7c52d9a 100644
--- a/src/LambdaCube/Compiler/Infer.hs
+++ b/src/LambdaCube/Compiler/Infer.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE PatternSynonyms #-}
@@ -881,30 +882,31 @@ appTy t x = error $ "appTy: " ++ show t
 -------------------------------------------------------------------------------- error messages
 
 data ErrorMsg
-    = ErrorMsg String
+    = ErrorMsg Doc
     | ECantFind SName SI
-    | ETypeError String SI
+    | ETypeError Doc SI
     | ERedefined SName SI SI
 
-instance NFData ErrorMsg where
+instance NFData ErrorMsg where rnf = rnf . ppShow
+{-
     rnf = \case
         ErrorMsg m -> rnf m
         ECantFind a b -> rnf (a, b)
         ETypeError a b -> rnf (a, b)
         ERedefined a b c -> rnf (a, b, c)
-
+-}
 errorRange_ = \case
     ErrorMsg s -> []
     ECantFind s si -> [si]
     ETypeError msg si -> [si]
     ERedefined s si si' -> [si, si']
 
-instance Show ErrorMsg where
-    show = \case
+instance PShow ErrorMsg where
+    pShow = \case
         ErrorMsg s -> s
-        ECantFind s si -> "can't find: " ++ s ++ " in " ++ showSI si
-        ETypeError msg si -> "type error: " ++ msg ++ "\nin " ++ showSI si ++ "\n"
-        ERedefined s si si' -> "already defined " ++ s ++ " at " ++ showSI si ++ "\n and at " ++ showSI si'
+        ECantFind s si -> "can't find:" <+> text s <+> "in" <+> showSI si
+        ETypeError msg si -> "type error:" <+> msg <$$> "in" <+> showSI si
+        ERedefined s si si' -> "already defined" <+> text s <+> "at" <+> showSI si <$$> "and at" <+> showSI si'
 
 
 -------------------------------------------------------------------------------- inference
@@ -1051,7 +1053,7 @@ inferN_ tellTrace = infer  where
         EBind2_ si BMeta tt_ te
             | ELabelEnd te'   <- te -> refocus (ELabelEnd $ EBind2_ si BMeta tt_ te') eet
             | Unit <- tt    -> refocus te $ subst 0 TT eet
-            | Empty msg <- tt -> throwError' $ ETypeError msg si
+            | Empty msg <- tt -> throwError' $ ETypeError (text msg) si
             | T2 x y <- tt, let te' = EBind2_ si BMeta (up 1 y) $ EBind2_ si BMeta x te
                             -> refocus te' $ subst 2 (t2C (Var 1) (Var 0)) $ up 2 eet
             | CstrT t a b <- tt, Just r <- cst (a, t) b -> r
@@ -1117,8 +1119,8 @@ inferN_ tellTrace = infer  where
 
         EGlobal{} -> return eet
         _ -> case eet of
-            MEnd x -> throwError' $ ErrorMsg $ "focus todo: " ++ ppShow x
-            _ -> throwError' $ ErrorMsg $ "focus checkMetas: " ++ ppShow env ++ "\n" ++ ppShow (fst <$> eet)
+            MEnd x -> throwError' $ ErrorMsg $ "focus todo:" <+> pShow x
+            _ -> throwError' $ ErrorMsg $ "focus checkMetas:" <+> pShow env <$$> pShow (fst <$> eet)
       where
         refocus_ :: (Env -> CEnv ExpType -> IM m ExpType') -> Env -> CEnv ExpType -> IM m ExpType'
         refocus_ _ e (MEnd at) = focus_ e at
@@ -1255,12 +1257,13 @@ initEnv = Map.fromList
 
 data Info
     = Info Range String
-    | IType String String
+    | IType SIName Exp
     | ITrace String String
     | IError ErrorMsg
     | ParseWarning ParseWarning
 
-instance NFData Info
+instance NFData Info where rnf = rnf . ppShow
+{-
  where
     rnf = \case
         Info r s -> rnf (r, s)
@@ -1268,14 +1271,14 @@ instance NFData Info
         ITrace i s -> rnf (i, s)
         IError x -> rnf x
         ParseWarning w -> rnf w
-
-instance Show Info where
-    show = \case
-        Info r s -> ppShow r ++ "  " ++ s
-        IType a b -> a ++ " :: " ++ b
-        ITrace i s -> i ++ ":  " ++ s
-        IError e -> "!" ++ show e
-        ParseWarning w -> show w
+-}
+instance PShow Info where
+    pShow = \case
+        Info r s -> pShow r <+> "" <+> text s
+        IType a b -> shAnn False (pShow a) (pShow b)
+        ITrace i s -> text i <> ": " <+> text s
+        IError e -> "!" <> pShow e
+        ParseWarning w -> pShow w
 
 errorRange is = [r | IError e <- is, RangeSI r <- errorRange_ e ]
 
@@ -1288,12 +1291,12 @@ mkInfoItem _ _ = mempty
 
 listAllInfos m = h "trace"  (listTraceInfos m)
              ++  h "tooltips" [ ppShow r ++ "  " ++ intercalate " | " is | (r, is) <- listTypeInfos m ]
-             ++  h "warnings" [ show w | ParseWarning w <- m ]
+             ++  h "warnings" [ ppShow w | ParseWarning w <- m ]
   where
     h x [] = []
     h x xs = ("------------ " ++ x) : xs
 
-listTraceInfos m = [show i | i <- m, case i of Info{} -> False; ParseWarning{} -> False; _ -> True]
+listTraceInfos m = [ppShow i | i <- m, case i of Info{} -> False; ParseWarning{} -> False; _ -> True]
 listTypeInfos m = map (second Set.toList) $ Map.toList $ Map.unionsWith (<>) [Map.singleton r $ Set.singleton i | Info r i <- m]
 
 -------------------------------------------------------------------------------- inference for statements
@@ -1428,10 +1431,10 @@ inferType :: Monad m => SExp2 -> IM m Type
 inferType t = fmap (closedExp . fst . recheck "inferType" EGlobal . flip (,) TType . replaceMetas (Pi Hidden) . fmap fst) $ inferN (CheckType_ (debugSI "inferType CheckType_") TType EGlobal) t
 
 addToEnv :: Monad m => SIName -> ExpType -> IM m GlobalEnv
-addToEnv (SIName si s) (x, t) = do
+addToEnv sn@(SIName si s) (x, t) = do
 --    maybe (pure ()) throwError_ $ ambiguityCheck s t      -- TODO
 --    b <- asks $ (TraceTypeCheck `elem`) . fst
-    tell [IType s $ ppShow t]
+    tell [IType sn t]
     v <- asks $ Map.lookup s . snd
     case v of
       Nothing -> return $ Map.singleton s (closedExp x, closedExp t, si)
diff --git a/src/LambdaCube/Compiler/Parser.hs b/src/LambdaCube/Compiler/Parser.hs
index ce830f2a..a4dfa229 100644
--- a/src/LambdaCube/Compiler/Parser.hs
+++ b/src/LambdaCube/Compiler/Parser.hs
@@ -67,24 +67,21 @@ instance NFData ParseWarning
         Unreachable r -> rnf r
         Uncovered si r -> rnf si -- TODO --rnf r
 
-instance Show LCParseError where
-    show = \case
-        MultiplePatternVars xs -> unlines $ "multiple pattern vars:":
-            concat [(sName (head ns) ++ " is defined at"): map showSI ns | ns <- xs]
-        OperatorMismatch op op' -> "Operator precedences don't match:\n" ++ show (fromJust $ getFixity_ op) ++ " at " ++ showSI op ++ "\n" ++ show (fromJust $ getFixity_ op') ++ " at " ++ showSI op'
-        UndefinedConstructor n -> "Constructor " ++ show n ++ " is not defined at " ++ showSI n
-        ParseError p -> show p
-
-instance Show ParseWarning where
-    show = \case
-        Unreachable si -> "Source code is not reachable: " ++ show (showRange si)
-        Uncovered si pss -> "Uncovered pattern(s) at " ++ showSI si ++ "\nMissing case(s):\n" ++
-            unlines ["  " ++ unwords (map ppShow ps) ++
-                     " | " +++ intercalate ", " [ppShow p ++ " <- " ++ ppShow e | (p, e) <- gs]
+instance PShow LCParseError where
+    pShow = \case
+        MultiplePatternVars xs -> vcat $ "multiple pattern vars:":
+            concat [(pShow (head ns) <+> "is defined at"): map showSI ns | ns <- xs]
+        OperatorMismatch op op' -> "Operator precedences don't match:" <$$> pShow (fromJust $ getFixity_ op) <+> "at" <+> showSI op <$$> pShow (fromJust $ getFixity_ op') <+> "at" <+> showSI op'
+        UndefinedConstructor n -> "Constructor" <+> pShow n <+> "is not defined at" <+> showSI n
+        ParseError p -> text $ show p
+
+instance PShow ParseWarning where
+    pShow = \case
+        Unreachable si -> "Source code is not reachable:" <+> showRange si
+        Uncovered si pss -> "Uncovered pattern(s) at" <+> showSI si <$$> "Missing case(s):" <$$>
+               vcat ["  " <> hsep (map pShow ps) <+> 
+                     hsep [se <+> pShow p <+> "<-" <+> pShow e | (se, (p, e)) <- zip ("|": repeat ",") gs]
                     | (ps, gs) <- pss]
-      where
-        s +++ "" = ""
-        s +++ s' = s ++ s'
 
 trackSI p = do
     x <- p
diff --git a/src/LambdaCube/Compiler/Pretty.hs b/src/LambdaCube/Compiler/Pretty.hs
index a8fdf851..42e06ad3 100644
--- a/src/LambdaCube/Compiler/Pretty.hs
+++ b/src/LambdaCube/Compiler/Pretty.hs
@@ -17,6 +17,7 @@ import Data.String
 --import qualified Data.Map as Map
 import Control.Monad.Reader
 import Control.Monad.State
+import Control.DeepSeq
 --import Debug.Trace
 
 import qualified Text.PrettyPrint.ANSI.Leijen as P
@@ -66,6 +67,12 @@ data Fixity
     | InfixR !Int
     deriving (Eq, Show)
 
+instance PShow Fixity where
+    pShow = \case
+        Infix  i -> "infix"  `DApp` pShow i
+        InfixL i -> "infixl" `DApp` pShow i
+        InfixR i -> "infixr" `DApp` pShow i
+
 precedence, leftPrecedence, rightPrecedence :: Fixity -> Int
 
 precedence = \case
@@ -107,6 +114,9 @@ instance Monoid Doc where
     mempty = text ""
     a `mappend` b = DDoc $ DOHCat a b
 
+instance NFData Doc where
+    rnf x = rnf $ show x    -- TODO
+
 pattern DColor c a = DDoc (DOColor c a)
 
 strip :: Doc -> Doc