refactoring & fix build

4 files changed, 34 insertions, 10 deletions

diff --git a/src/LambdaCube/Compiler/DesugaredSource.hs b/src/LambdaCube/Compiler/DesugaredSource.hs
index 72327b99..3982d897 100644
--- a/src/LambdaCube/Compiler/DesugaredSource.hs
+++ b/src/LambdaCube/Compiler/DesugaredSource.hs
@@ -78,14 +78,18 @@ data FileInfo = FileInfo
 instance Eq FileInfo where (==) = (==) `on` fileId
 instance Ord FileInfo where compare = compare `on` fileId
 
-instance PShow FileInfo where pShow = text . (++ ".lc") . fileModule
+instance PShow FileInfo where pShow = text . filePath --(++ ".lc") . fileModule
 
 showPos :: FileInfo -> SPos -> Doc
 showPos n p = pShow n <> ":" <> pShow p
 
 -------------------------------------------------------------------------------- range
 
-data Range = Range !FileInfo !SPos !SPos
+data Range = Range
+    { rangeFile  :: !FileInfo
+    , rangeStart :: !SPos
+    , rangeStop  :: !SPos
+    }
     deriving (Eq, Ord)
 
 instance Show Range where show = ppShow
@@ -96,6 +100,8 @@ instance PShow Range
              : map text (drop (r - 1) $ take r' $ lines $ fileContent n)
             ++ [text $ replicate (c - 1) ' ' ++ replicate (c' - c) '^' | r' == r]
 
+showRangeWithoutFileName (Range _ b e) = pShow b <> "-" <> pShow e
+
 joinRange :: Range -> Range -> Range
 joinRange (Range n b e) (Range n' b' e') {- | n == n' -} = Range n (min b b') (max e e')
 
@@ -553,7 +559,7 @@ instance PShow Stmt where
 
 instance DeBruijnify SIName Stmt where
     deBruijnify_ k v = \case
-        StLet sn mt e -> StLet sn (deBruijnify_ k v <$> mt) (deBruijnify_ k v e)
+        StmtLet sn e -> StmtLet sn (deBruijnify_ k v e)
         x@PrecDef{} -> x
         x -> error $ "deBruijnify @ " ++ ppShow x
 
diff --git a/src/LambdaCube/Compiler/Infer.hs b/src/LambdaCube/Compiler/Infer.hs
index c2657f0e..ecd18b46 100644
--- a/src/LambdaCube/Compiler/Infer.hs
+++ b/src/LambdaCube/Compiler/Infer.hs
@@ -271,6 +271,12 @@ inferN_ tellTrace = infer  where
             = infer te $ x `SAppV` SLamV (SLamV (STyped (subst (n'+2) (Var 1) $ up1_ (n'+3) $ up 2 t, TType))) `SAppV` a `SAppV` b `SAppV` SVar siv v
 -}
         | SRHS x <- e = checkN (ERHS te) x t
+{- TODO
+        | SAnn v a <- e = do
+            let x = t
+            let same = checkSame te a x
+            if same then checkN te v x else  error $ "checkSame:\n" ++ ppShow a ++ "\nwith\n" ++ showEnvExp te (ET x TType)
+-}
         | SLHS n x <- e = checkN (ELHS n te) x t
         | SApp_ si h a b <- e = infer (CheckAppType si h t te b) a
         | SLam h a b <- e, Pi h' x y <- t, h == h' = do
diff --git a/src/LambdaCube/Compiler/InferMonad.hs b/src/LambdaCube/Compiler/InferMonad.hs
index b084647f..e2895389 100644
--- a/src/LambdaCube/Compiler/InferMonad.hs
+++ b/src/LambdaCube/Compiler/InferMonad.hs
@@ -17,6 +17,7 @@ module LambdaCube.Compiler.InferMonad where
 
 import Data.Monoid
 import Data.List
+import Data.Maybe
 import qualified Data.Set as Set
 import qualified Data.Map as Map
 
@@ -80,15 +81,16 @@ throwError' e = tell [IError e] >> throwError e
 mkInfoItem (RangeSI r) i = [Info r i]
 mkInfoItem _ _ = mempty
 
-listAllInfos m = h "trace"  (listTraceInfos m)
-             ++  h "tooltips" [ nest 4 $ shortForm $ pShow r <$$> hsep (intersperse "|" is) | (r, is) <- listTypeInfos m ]
-             ++  h "warnings" [ pShow w | ParseWarning w <- m ]
+listAllInfos f m
+    = h "trace"  (listTraceInfos m) ++ listAllInfos' f m
   where
     h x [] = []
     h x xs = ("------------" <+> x) : xs
 
-listAllInfos' m = h "tooltips" [ nest 4 $ shortForm $ pShow r <$$> hsep (intersperse "|" is) | (r, is) <- listTypeInfos m ]
-              ++  h "warnings" [ pShow w | ParseWarning w <- m ]
+listAllInfos' f m
+    =   h "tooltips" [ nest 4 $ shortForm $ showRangeWithoutFileName r <$$> hsep (intersperse "|" is)
+                     | (r, is) <- listTypeInfos m, maybe False (rangeFile r ==) f ]
+    ++  h "warnings" [ pShow w | ParseWarning w <- m ]
   where
     h x [] = []
     h x xs = ("------------" <+> x) : xs
diff --git a/src/LambdaCube/Compiler/Statements.hs b/src/LambdaCube/Compiler/Statements.hs
index 01add12c..3cd1edf1 100644
--- a/src/LambdaCube/Compiler/Statements.hs
+++ b/src/LambdaCube/Compiler/Statements.hs
@@ -49,7 +49,7 @@ mkLets_ mkLet = mkLets' mkLet . concatMap desugarMutual . sortDefs
 
 mkLets' mkLet = f where
     f [] e = e
-    f (StLet n mt x: ds) e = mkLet n (maybe id (flip SAnn) mt x) (deBruijnify [n] $ f ds e)
+    f (StmtLet n x: ds) e = mkLet n x (deBruijnify [n] $ f ds e)
     f (PrecDef{}: ds) e = f ds e
     f (x: ds) e = error $ "mkLets: " ++ ppShow x
 
@@ -106,7 +106,7 @@ compileStmt lhs compilegt ds = \case
           | n `elem` [n' | TypeFamily n' _ <- ds] -> return []
           | otherwise -> do
             cf <- compilegt (SIName_ (mconcat [sourceInfo n | FunAlt n _ _ <- fs]) (nameFixity n) $ sName n) vs [gt | FunAlt _ _ gt <- fs]
-            return [StLet n (listToMaybe [t | TypeAnn n' t <- ds, n' == n]) $ lhs n cf]
+            return [StLet n (listToMaybe [t | TypeAnn n' t <- ds, n' == n]{-TODO: fail if more-}) $ lhs n cf]
         fs -> fail $ "different number of arguments of " ++ sName n ++ ":\n" ++ show (vcat $ pShow . sourceInfo . snd . head <$> fs)
     [Stmt x] -> return [x]
   where
@@ -127,6 +127,7 @@ desugarValueDef p e = sequence
     dns = reverse $ getPVars p
     n = mangleNames dns
 
+--getLet (StmtLet x dx) = Just (x, dx)
 getLet (StLet x mt dx) = Just (x, mt, dx)
 getLet _ = Nothing
 
@@ -137,10 +138,14 @@ desugarMutual [x@Primitive{}] = [x]
 desugarMutual [x@Data{}] = [x]
 desugarMutual [x@PrecDef{}] = [x]
 desugarMutual [StLet n nt nd] = [StLet n nt $ addFix n nt nd]
+--desugarMutual [StmtLet n nd] = [StmtLet n $ addFix n nd]
 desugarMutual (traverse getLet -> Just (unzip3 -> (ns, ts, ds))) = fst' $ runWriter $ do
+--desugarMutual (traverse getLet -> Just (unzip -> (ns, ds))) = fst' $ runWriter $ do
     ss <- compileStmt'_ sLHS SRHS SRHS =<< desugarValueDef (foldr cHCons cHNil $ PVarSimp <$> ns) (SGlobal xy)
     return $
+--        StLet xy ty (addFix xy $ mkLets' SLet ss $ foldr HCons HNil ds) : ss
         StLet xy ty (addFix xy ty $ mkLets' SLet ss $ foldr HCons HNil ds) : ss
+
   where
     ty = Nothing -- TODO:  Just $ HList $ foldr BCons BNil $ const (Wildcard SType) <$> ts
     xy = mangleNames ns
@@ -148,6 +153,11 @@ desugarMutual xs = error "desugarMutual"
 
 addFix n nt x
     | usedS n x = SBuiltin FprimFix `SAppV` SLam Visible (maybe (Wildcard SType) id nt) (deBruijnify [n] x)
+
+{-
+addFix n x
+    | usedS n x = SBuiltin FprimFix `SAppV` SLamV (deBruijnify [n] x)
+-}
     | otherwise = x
 
 mangleNames xs = SIName (foldMap sourceInfo xs) $ "_" ++ intercalate "_" (sName <$> xs)