complete pShow on patterns; bugfix; more uncovered warning tests

6 files changed, 40 insertions, 38 deletions

diff --git a/src/LambdaCube/Compiler/DesugaredSource.hs b/src/LambdaCube/Compiler/DesugaredSource.hs
index 7351f4d7..c17717f3 100644
--- a/src/LambdaCube/Compiler/DesugaredSource.hs
+++ b/src/LambdaCube/Compiler/DesugaredSource.hs
@@ -450,7 +450,7 @@ instance PShow Stmt where
     pShow stmt = DResetFreshNames $ case stmt of
         Primitive n t -> shAnn (pShow n) (pShow t)
         Let n ty e -> DLet "=" (pShow n) $ maybe (pShow e) (\ty -> shAnn (pShow e) (pShow ty)) ty 
-        Data n ps ty cs -> nest 4 $ "data" <+> shAnn (foldl dApp (DTypeNamespace True $ pShow n) [shAnn (text "_") (pShow t) | (v, t) <- ps]) (pShow ty) <+> "where" <$$> vcat [shAnn (pShow n) $ pShow t | (n, t) <- cs]
+        Data n ps ty cs -> nest 2 $ "data" <+> nest 2 (shAnn (foldl dApp (DTypeNamespace True $ pShow n) [shAnn (text "_") (pShow t) | (v, t) <- ps]) (pShow ty)) </> "where" <> nest 2 (hardline <> vcat [shAnn (pShow n) $ pShow t | (n, t) <- cs])
         PrecDef n i -> pShow i <+> shortForm (pShow n) --DOp0 (sName n) i
 
 instance DeBruijnify SIName Stmt where
diff --git a/src/LambdaCube/Compiler/Parser.hs b/src/LambdaCube/Compiler/Parser.hs
index 633368f8..bf7cd330 100644
--- a/src/LambdaCube/Compiler/Parser.hs
+++ b/src/LambdaCube/Compiler/Parser.hs
@@ -59,13 +59,13 @@ data LCParseError
 
 data ParseWarning
     = Unreachable Range
-    | Uncovered SI [PatList]
+    | Uncovered SIName [PatList]
 
 instance NFData ParseWarning
  where
     rnf = \case
         Unreachable r -> rnf r
-        Uncovered si r -> rnf si -- TODO --rnf r
+        Uncovered si r -> () --rnf si -- TODO --rnf r
 
 instance PShow LCParseError where
     pShow = \case
@@ -78,10 +78,14 @@ instance PShow LCParseError where
 instance PShow ParseWarning where
     pShow = \case
         Unreachable si -> "Source code is not reachable:" <+> pShow si
-        Uncovered si pss -> "Uncovered pattern(s) at" <+> pShow si <$$> "Missing case(s):" <$$>
-               vcat ["  " <> hsep (map pShow ps) <+> 
-                     hsep [se <+> pShow p <+> "<-" <+> pShow e | (se, (p, e)) <- zip ("|": repeat ",") gs]
+        Uncovered sn pss -> "Uncovered pattern(s) at" <+> pShow (sourceInfo sn) <$$>
+            nest 4 (shortForm $ vcat $ "Missing case(s):" :
+                    [ addG (foldl DApp (pShow sn) (pShow <$> ps)) [DOp "<-" (Infix (-1)) (pShow p) (pShow e) | (p, e) <- gs]
                     | (ps, gs) <- pss]
+            )
+          where
+            addG x [] = x
+            addG x xs = DOp "|" (Infix (-5)) x $ foldr1 (DOp "," (InfixR (-4))) xs
 
 trackSI p = do
     x <- p
@@ -283,7 +287,7 @@ generator = do
     checkPattern dbs
     exp <- setR parseTermLam
     return $ \e -> do
-        cf <- runCheck $ compileGuardTree id id (Just $ sourceInfo pat) [(Visible, Wildcard SType)] $ compilePatts [pat] (noGuards $ deBruijnify dbs e) `mappend` noGuards BNil
+        cf <- runCheck $ compileGuardTree id id (Just $ SIName (sourceInfo pat) "") [(Visible, Wildcard SType)] $ compilePatts [pat] (noGuards $ deBruijnify dbs e) `mappend` noGuards BNil
         return $ SBuiltin "concatMap" `SAppV` cf `SAppV` exp
 
 letdecl = (return .) . mkLets <$ reserved "let" <*> (runCheck . compileStmt' =<< valueDef)
diff --git a/src/LambdaCube/Compiler/Patterns.hs b/src/LambdaCube/Compiler/Patterns.hs
index a2bc3831..fe4ed352 100644
--- a/src/LambdaCube/Compiler/Patterns.hs
+++ b/src/LambdaCube/Compiler/Patterns.hs
@@ -15,6 +15,7 @@ import Data.Maybe
 import qualified Data.Set as Set
 import Control.Monad.Writer
 import Control.Arrow hiding ((<+>))
+import Debug.Trace
 
 import LambdaCube.Compiler.Utils
 import LambdaCube.Compiler.DeBruijn
@@ -26,7 +27,7 @@ import LambdaCube.Compiler.DesugaredSource
 data ParseCheck
     = TrackedCode Range
     | Reachable Range
-    | Uncovered' SI [PatList]
+    | Uncovered' SIName [PatList]
 
 type PatList = ([ParPat_ ()], [(ParPat_ (), SExp)])
 
@@ -38,7 +39,7 @@ type ConsInfo = Either ((SName{-case eliminator name-}, Int{-num of indices-}),
 type Pat = Pat_ ConsInfo
 
 data Pat_ c
-    = PVar SIName -- Int
+    = PVar SIName
     | PCon_ SI (SIName, c) [ParPat_ c]
     | ViewPat_ SI SExp (ParPat_ c)
     | PatType_ SI (ParPat_ c) SExp
@@ -52,9 +53,17 @@ pattern ParPat ps <- ParPat_ _ ps
   where ParPat ps =  ParPat_ (foldMap sourceInfo ps) ps
 
 instance PShow (Pat_ a) where
-    pShow = patDoc
+    pShow = \case
+        PVar sn -> pShow sn
+        PCon (sn, _) ps -> foldl DApp (pShow sn) (pShow <$> ps)
+        ViewPat e p -> DOp "->" (Infix (-1)) (pShow e) (pShow p)
+        PatType p t -> DAnn (pShow p) (pShow t)
+
 instance PShow (ParPat_ a) where
-    pShow = parPatDoc
+    pShow = \case
+        ParPat [] -> text "_"
+        ParPat ps -> foldr1 (DOp "@" (InfixR 11)) $ pShow <$> ps
+
 
 
 pattern PWildcard si = ParPat_ si []
@@ -153,17 +162,6 @@ instance SetSourceInfo (Pat_ c) where
         ViewPat_ _  a b -> ViewPat_ si a b
         PatType_ _  a b -> PatType_ si a b
 
--------------------------------------------------------------------------------- pretty print
-
-patDoc :: Pat_ a -> Doc
-patDoc = \case
-    PCon (n, _) _ -> text $ sName n -- TODO
-
-parPatDoc :: ParPat_ a -> Doc
-parPatDoc = \case
-    ParPat [] -> text "_"
-    ParPat [p] -> patDoc p
-    -- TODO
 -------------------------------------------------------------------------------- pattern match compilation
 
 -- pattern match compilation monad
@@ -171,7 +169,7 @@ type PMC = Writer ([CasePath], [Range])
 
 type CasePath = [Maybe (SIName, Int, SExp)]
 
-runPMC :: MonadWriter [ParseCheck] m => Maybe SI -> [(Visibility, SExp)] -> PMC a -> m a
+runPMC :: MonadWriter [ParseCheck] m => Maybe SIName -> [(Visibility, SExp)] -> PMC a -> m a
 runPMC si vt m = do
     tell $ Reachable <$> rs
     case si of
@@ -180,14 +178,16 @@ runPMC si vt m = do
     return a
   where
     (a, (ps, rs)) = runWriter m
-    mkPatt_ ps_ i_ = (ps, mkGuards 0 ps_)
+
+    mkPatt_ ps_ is = (ps, mkGuards 0 ps_)
       where
-        (mconcat -> qs, ps) = unzip $ map (mkPatt 0 ps_) i_
+        (mconcat -> qs, ps) = unzip $ map (mkPatt 0 ps_) is
 
         mkGuards k [] = []
         mkGuards k ((q, (cn, n, e)): ps) = [(PConSimp (cn, ()) $ replicate n $ PWildcard mempty, e) | q `Set.notMember` qs] ++ mkGuards (k + n) ps
 
-        mkPatt k ((q, (cn, n, SVar _ j)): ps) i | j == (i + k) = (Set.singleton q <>) . mconcat *** PConSimp (cn, ()) $ unzip [mkPatt (k + n) ps l | l <- [n-1, n-2..0]]
+        mkPatt k ((q, (cn, n, SVar _ j)): ps) i | j == (i + k)
+            = (Set.singleton q <>) . mconcat *** PConSimp (cn, ()) $ unzip [mkPatt 0 ps l | l <- [n-1, n-2..0]]
         mkPatt k ((q, (cn, n, _)): ps) i = mkPatt (k + n) ps i
         mkPatt k [] i = (mempty, PWildcard mempty)
 --        mkPatt k ps' i = error $ "mkPatt " ++ show i_ ++ ":  " ++ maybe "" showSI si ++ "\n" ++ show ps' ++ "\n" ++ show ps_
@@ -280,7 +280,7 @@ compilePatts ps = buildNode guardNode' n ps [n-1, n-2..0]
   where
     n = length ps
 
-compileGuardTree :: MonadWriter [ParseCheck] m => (SExp -> SExp) -> (SExp -> SExp) -> Maybe SI -> [(Visibility, SExp)] -> GuardTrees -> m SExp
+compileGuardTree :: MonadWriter [ParseCheck] m => (SExp -> SExp) -> (SExp -> SExp) -> Maybe SIName -> [(Visibility, SExp)] -> GuardTrees -> m SExp
 compileGuardTree ulend lend si vt = fmap (\e -> foldr (uncurry SLam) e vt) . runPMC si vt . guardTreeToCases []
   where
     guardTreeToCases :: CasePath -> GuardTrees -> PMC SExp
@@ -292,10 +292,8 @@ compileGuardTree ulend lend si vt = fmap (\e -> foldr (uncurry SLam) e vt) . run
             return $ ulend $ SBuiltin "undefined"
         In (GTSuccess e) -> do
             tell $ (,) mempty $ maybeToList $ getRange $ sourceInfo e
-            --trace (ppShow $ sourceInfo e) $ 
             return $ lend e
         ts@(In (GuardNode f (s, cn) _ _ _)) -> case cn of
---            Nothing -> throwError sn
             Left ((casename, inum), cns) -> do
                 cf <- sequence [ iterateN n SLamV <$> guardTreeToCases (Just (cn, n, f): path) (filterGuardTree (up n f) cn 0 n $ rUp n 0 ts)
                                | (cn, n) <- cns ]
@@ -339,8 +337,8 @@ compileGuardTrees ulend si vt = compileGuardTree ulend SRHS si vt . mconcat
 compileGuardTrees' si vt = fmap (foldr1 $ SAppV2 $ SBuiltin "parEval" `SAppV` Wildcard SType) . mapM (compileGuardTrees id Nothing vt . (:[]))
 
 compileCase x cs
-    = (`SAppV` x) <$> compileGuardTree id id (Just $ sourceInfo x) [(Visible, Wildcard SType)] (mconcat [compilePatts [p] e | (p, e) <- cs])
+    = (`SAppV` x) <$> compileGuardTree id id (Just $ SIName (sourceInfo x) "") [(Visible, Wildcard SType)] (mconcat [compilePatts [p] e | (p, e) <- cs])
 
 patLam :: MonadWriter [ParseCheck] m => (SExp -> SExp) -> (Visibility, SExp) -> ParPat -> SExp -> m SExp
-patLam f vt p e = compileGuardTree f f (Just $ sourceInfo p) [vt] (compilePatts [p] $ noGuards e)
+patLam f vt p e = compileGuardTree f f (Just $ SIName (sourceInfo p) "") [vt] (compilePatts [p] $ noGuards e)
 
diff --git a/src/LambdaCube/Compiler/Pretty.hs b/src/LambdaCube/Compiler/Pretty.hs
index 7aba8f77..204a9547 100644
--- a/src/LambdaCube/Compiler/Pretty.hs
+++ b/src/LambdaCube/Compiler/Pretty.hs
@@ -18,6 +18,7 @@ import Data.String
 import Data.Char
 --import qualified Data.Set as Set
 --import qualified Data.Map as Map
+import Control.Applicative
 import Control.Monad.Identity
 import Control.Monad.Reader
 import Control.Monad.State
@@ -239,7 +240,7 @@ renderDoc
             isAlph c = isAlphaNum c || c `elem` ("'_" :: String)
             isOpen c = c `elem` ("({[" :: String)
             isClose c = c `elem` (")}]" :: String)
-            graphicChar = (`elem` ("#<>!.:^&@|-+*/\\~%=$" :: String))
+            --graphicChar = (`elem` ("#<>!.:^&@|-+*/\\~%=$" :: String))
 
 -------------------------------------------------------------------------- combinators
 
@@ -253,6 +254,7 @@ onblue      = DFormat P.ondullblue
 underline   = DFormat P.underline
 
 -- add wl-pprint combinators as necessary here
+hardline = dZero P.hardline
 (<+>)  = dTwo (P.<+>)
 (</>)  = dTwo (P.</>)
 (<$$>) = dTwo (P.<$$>)
@@ -262,6 +264,7 @@ sep    = dList P.sep
 hsep   = dList P.hsep
 vcat   = dList P.vcat
 
+dZero x    = DDocOp (const x) (Const ())
 dOne f     = DDocOp (f . runIdentity) . Identity
 dTwo f x y = DDocOp (\(Two x y) -> f x y) (Two x y)
 dList f    = DDocOp f
@@ -292,8 +295,6 @@ pattern DParen x = DPar "(" x ")"
 pattern DBrace x = DPar "{" x "}"
 pattern DOp s f l r = DInfix f l (SimpleAtom s) r
 pattern DOp0 s f = DOp s f (DText "") (DText "")
---pattern DOpL s f x = DOp s f x (DText "")
---pattern DOpR s f x = DOp s f (DText "") x
 pattern DSep p a b = DOp " " p a b
 pattern DGlue p a b = DOp "" p a b
 
@@ -302,8 +303,6 @@ pattern DArr x y = DArr_ "->" x y
 braces = DBrace
 parens = DParen
 
---dApp (DOp0 s f) x = DOpL s f x
---dApp (DOpL s f x) y = DOp s f x y
 dApp x y = DApp x y
 
 shCstr = DCstr
diff --git a/src/LambdaCube/Compiler/Statements.hs b/src/LambdaCube/Compiler/Statements.hs
index 2112dd69..c9dfa1f7 100644
--- a/src/LambdaCube/Compiler/Statements.hs
+++ b/src/LambdaCube/Compiler/Statements.hs
@@ -75,7 +75,7 @@ compileStmt' ds = fmap concat . sequence $ map (compileStmt (compileGuardTrees S
     h (FunAlt n _ _) (FunAlt m _ _) = m == n
     h _ _ = False
 
-compileStmt :: MonadWriter [ParseCheck] m => (SI -> [(Visibility, SExp)] -> [GuardTrees] -> m SExp) -> [PreStmt] -> [PreStmt] -> m [Stmt]
+compileStmt :: MonadWriter [ParseCheck] m => (SIName -> [(Visibility, SExp)] -> [GuardTrees] -> m SExp) -> [PreStmt] -> [PreStmt] -> m [Stmt]
 compileStmt compilegt ds = \case
     [Instance{}] -> return []
     [Class n ps ms] -> do
@@ -106,7 +106,7 @@ compileStmt compilegt ds = \case
           | num == 0 && length gs > 1 -> fail $ "redefined " ++ sName n ++ ":\n" ++ show (vcat $ pShow . sourceInfo . snd <$> gs)
           | n `elem` [n' | TypeFamily n' _ <- ds] -> return []
           | otherwise -> do
-            cf <- compilegt (mconcat [sourceInfo n | FunAlt n _ _ <- fs]) vs [gt | FunAlt _ _ gt <- fs]
+            cf <- compilegt (SIName_ (mconcat [sourceInfo n | FunAlt n _ _ <- fs]) (getFixity n) $ sName n) vs [gt | FunAlt _ _ gt <- fs]
             return [Let n (listToMaybe [t | TypeAnn n' t <- ds, n' == n]) cf]
         fs -> fail $ "different number of arguments of " ++ sName n ++ ":\n" ++ show (vcat $ pShow . sourceInfo . snd . head <$> fs)
     [Stmt x] -> return [x]
diff --git a/src/LambdaCube/Compiler/Utils.hs b/src/LambdaCube/Compiler/Utils.hs
index 78872b04..8ec2f6b0 100644
--- a/src/LambdaCube/Compiler/Utils.hs
+++ b/src/LambdaCube/Compiler/Utils.hs
@@ -4,6 +4,7 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 module LambdaCube.Compiler.Utils where
 
 import qualified Data.IntSet as IS