refactoring

3 files changed, 68 insertions, 56 deletions

diff --git a/src/LambdaCube/Compiler/Infer.hs b/src/LambdaCube/Compiler/Infer.hs
index 4a04564c..f68be803 100644
--- a/src/LambdaCube/Compiler/Infer.hs
+++ b/src/LambdaCube/Compiler/Infer.hs
@@ -137,9 +137,7 @@ data FName
     | FSplit
     deriving (Eq, Ord)
 
-cFName mod i (RangeSI (Range fn (r, c) _), s) = fromMaybe (CFName n $ SData s) $ lookup s fntable
-  where
-    n = fileId fn * 2^32 + r * 2^16 + c * 2^3 -- + i
+cFName (RangeSI (Range fn p _), s) = fromMaybe (CFName (hashPos fn p) $ SData s) $ lookup s fntable
 
 fntable =
     [ (,) "'VecScalar"  FVecScalar
@@ -1221,14 +1219,12 @@ inference (x:xs) = do
     y <- handleStmt x
     (y:) <$> withEnv y (inference xs)
 
-modn = 0
-
 handleStmt :: MonadFix m => Stmt -> IM m GlobalEnv
 handleStmt = \case
   Primitive n (trSExp' -> t_) -> do
         t <- inferType =<< ($ t_) <$> addF
         tellType (fst n) t
-        addToEnv n $ flip (,) t $ lamify t $ Neut . DFun_ (FunName (cFName modn 0 n) Nothing t)
+        addToEnv n $ flip (,) t $ lamify t $ Neut . DFun_ (FunName (cFName n) Nothing t)
   Let n mt t_ -> do
         af <- addF
         let t__ = maybe id (flip SAnn . af) mt t_
@@ -1251,7 +1247,7 @@ handleStmt = \case
     vty <- inferType $ addParamsS ps t_
     tellType (fst s) vty
     let
-        sint = cFName modn 2 s
+        sint = cFName s
         pnum' = length $ filter ((== Visible) . fst) ps
         inum = arity vty - length ps
 
@@ -1263,7 +1259,7 @@ handleStmt = \case
                 let     pars = zipWith (\x -> second $ STyped (debugSI "mkConstr1") . flip (,) TType . up_ (1+j) x) [0..] $ drop (length ps) $ fst $ getParams cty
                         act = length . fst . getParams $ cty
                         acts = map fst . fst . getParams $ cty
-                        conn = ConName (cFName modn 1 cn) j cty
+                        conn = ConName (cFName cn) j cty
                 e <- addToEnv cn (Con conn 0 [], cty)
                 return (e, ((conn, cty)
                        , addParamsS pars
@@ -1310,7 +1306,7 @@ withEnv e = local $ second (<> e)
 mkELet n x xt = {-(if null vs then id else trace_ $ "mkELet " ++ show (length vs) ++ " " ++ show n)-} term
   where
     vs = [Var i | i <- Set.toList $ free x <> free xt]
-    fn = FunName (cFName modn 5 n) (Just x) xt
+    fn = FunName (cFName n) (Just x) xt
 
     term = pmLabel fn vs 0 [] $ getFix x 0
 
diff --git a/src/LambdaCube/Compiler/Lexer.hs b/src/LambdaCube/Compiler/Lexer.hs
index 6817f9ed..9a1ac44c 100644
--- a/src/LambdaCube/Compiler/Lexer.hs
+++ b/src/LambdaCube/Compiler/Lexer.hs
@@ -13,9 +13,11 @@ import Data.Monoid
 import Data.List
 import Data.Char
 import Data.Function
+import Data.Bits
 import qualified Data.Set as Set
 import qualified Data.Map as Map
 import Control.Monad.RWS
+import Control.Monad.Except
 import Control.Arrow hiding ((<+>))
 import Control.Applicative
 import Control.DeepSeq
@@ -25,7 +27,7 @@ import Text.Megaparsec
 import Text.Megaparsec as ParseUtils hiding (try, Message)
 import Text.Megaparsec.Lexer hiding (lexeme, symbol, negate)
 
-import LambdaCube.Compiler.Pretty hiding (Doc, braces, parens)
+import LambdaCube.Compiler.Pretty hiding (braces, parens)
 
 -------------------------------------------------------------------------------- utils
 
@@ -112,24 +114,39 @@ parseLit = lexeme (LChar <$> charLiteral <|> LString <$> stringLiteral <|> natFl
 -------------------------------------------------------------------------------- source infos
 
 -- source position without file name
-type SourcePos' = (Int, Int)    -- row, column; starts with (1, 1)
+data SPos = SPos
+    { row    :: !Int    -- 1, 2, 3, ...
+    , column :: !Int    -- 1, 2, 3, ...
+    }
+  deriving (Eq, Ord)
+
+instance PShow SPos where
+    pShowPrec _ (SPos r c) = pShow r <> ":" <> pShow c
+
+toSPos :: SourcePos -> SPos
+toSPos p = SPos (sourceLine p) (sourceColumn p)
 
-toSourcePos' :: SourcePos -> SourcePos'
-toSourcePos' p = (sourceLine p, sourceColumn p)
+getSPos = toSPos <$> getPosition
 
-getPosition' = toSourcePos' <$> getPosition
+-------------
 
 data FileInfo = FileInfo
-    { fileId   :: Int
-    , filePath :: FilePath
+    { fileId      :: !Int
+    , filePath    :: FilePath
     , fileContent :: String
     }
 
 instance Eq FileInfo where (==) = (==) `on` fileId
 instance Ord FileInfo where compare = compare `on` fileId
-instance Show FileInfo where show = show . filePath
 
-data Range = Range !FileInfo !SourcePos' !SourcePos'
+instance PShow FileInfo where pShowPrec _ = text . filePath
+
+showPos :: FileInfo -> SPos -> Doc
+showPos n p = pShow n <> ":" <> pShow p
+
+-------------
+
+data Range = Range !FileInfo !SPos !SPos
     deriving (Eq, Ord)
 
 instance NFData Range where
@@ -137,15 +154,13 @@ instance NFData Range where
 
 -- short version
 instance PShow Range where
-    pShowPrec _ (Range n b e) = text (filePath n) <+> f b <> "-" <> f e
-      where
-        f (r, c) = pShow r <> ":" <> pShow c
+    pShowPrec _ (Range n b e) = pShow n <+> pShow b <> "-" <> pShow e
 
 -- long version
-showRange (Range n (r, c) (r', c')) = intercalate "\n"
-     $ (showPos n (r, c) ++ ":")
-     : (drop (r - 1) $ take r' $ lines $ fileContent n)
-    ++ [replicate (c - 1) ' ' ++ replicate (c' - c) '^' | r' == r]
+showRange (Range n p@(SPos r c) (SPos r' c')) = vcat
+     $ (showPos n p <> ":")
+     : map text (drop (r - 1) $ take r' $ lines $ fileContent n)
+    ++ [text $ replicate (c - 1) ' ' ++ replicate (c' - c) '^' | r' == r]
 
 joinRange :: Range -> Range -> Range
 joinRange (Range n b e) (Range n' b' e') {- | n == n' -} = Range n (min b b') (max e e')
@@ -176,20 +191,17 @@ instance PShow SI where
 
 -- long version
 showSI (NoSI ds) = unwords $ Set.toList ds
-showSI (RangeSI r) = showRange r
-
-showSourcePosSI (NoSI ds) = unwords $ Set.toList ds
-showSourcePosSI (RangeSI (Range n p _)) = showPos n p
-
-showPos n (r, c) = filePath n ++ ":" ++ show r ++ ":" ++ show c
+showSI (RangeSI r) = show $ showRange r
 
--- TODO: remove
-validSI RangeSI{} = True
-validSI _ = False
+hashPos :: FileInfo -> SPos -> Int
+hashPos fn (SPos r c) = fileId fn `shiftL` 32 .|. r `shiftL` 16 .|. c
 
 debugSI a = NoSI (Set.singleton a)
 
 si@(RangeSI r) `validate` xs | all validSI xs && r `notElem` [r | RangeSI r <- xs]  = si
+  where
+    validSI RangeSI{} = True
+    validSI _ = False
 _ `validate` _ = mempty
 
 sourceNameSI (RangeSI (Range n _ _)) = n
@@ -210,7 +222,7 @@ class SetSourceInfo a where
     setSI :: SI -> a -> a
 
 appRange :: Parse r w (SI -> a) -> Parse r w a
-appRange p = (\fi p1 a p2 -> a $ RangeSI $ Range fi p1 p2) <$> asks fileInfo <*> getPosition' <*> p <*> get
+appRange p = (\fi p1 a p2 -> a $ RangeSI $ Range fi p1 p2) <$> asks fileInfo <*> getSPos <*> p <*> get
 
 type SIName = (SI, SName)
 
@@ -220,14 +232,14 @@ data ParseEnv x = ParseEnv
     { fileInfo         :: FileInfo
     , desugarInfo      :: x
     , namespace        :: Namespace
-    , indentationLevel :: SourcePos'
+    , indentationLevel :: SPos
     }
 
-type Parse r w = ParsecT String (RWS (ParseEnv r) [w] SourcePos')
+type Parse r w = ParsecT String (RWS (ParseEnv r) [w] SPos)
 
-runParse env p = (\(a, s, w) -> (a, w)) $ runRWS p env (1, 1)
+runParse env p = (\(a, s, w) -> (a, w)) $ runRWS p env (SPos 1 1)
 
-parseString fi di p s = runParse (ParseEnv fi di ExpNS (0, 0)) $ runParserT p (filePath fi) s
+parseString fi di p s = runParse (ParseEnv fi di ExpNS (SPos 0 0)) $ runParserT p (filePath fi) s
 
 getParseState = (,) <$> asks desugarInfo <*> ((,,,) <$> asks fileInfo <*> asks namespace <*> asks indentationLevel <*> getParserState)
 
@@ -236,21 +248,21 @@ parseWithState p (di, (fi, ns, l, st)) = runParse (ParseEnv fi di ns l) $ runPar
 ----------------------------------------------------------- indentation, white space, symbols
 
 checkIndent = do
-    (r, c) <- asks indentationLevel
-    p@(r', c') <- getPosition'
+    (SPos r c) <- asks indentationLevel
+    p@(SPos r' c') <- getSPos
     if (c' <= c && r' > r) then fail "wrong indentation" else return p
 
 identation allowempty p = (if allowempty then option [] else id) $ do
-    (_, c) <- checkIndent
+    (SPos _ c) <- checkIndent
     (if allowempty then many else some) $ do
-        pos@(_, c') <- getPosition'
+        pos@(SPos _ c') <- getSPos
         guard (c' == c)
         local (\e -> e {indentationLevel = pos}) p
 
 lexemeWithoutSpace p = do
     p1 <- checkIndent
     x <- p
-    p2 <- getPosition'
+    p2 <- getSPos
     put p2
     fi <- asks fileInfo
     return (RangeSI $ Range fi p1 p2, x)
@@ -393,20 +405,20 @@ type Fixity = (FixityDef, Int)
 type FixityMap = Map.Map SName Fixity
 
 calcPrec
-    :: (Show e, Show f)
+    :: (Show e, Show f, MonadError String m)
     => (f -> e -> e -> e)
     -> (f -> Fixity)
     -> e
     -> [(f, e)]
-    -> e
+    -> m e
 calcPrec app getFixity e = compileOps [((Infix, -1000), error "calcPrec", e)]
   where
-    compileOps [(_, _, e)] [] = e
+    compileOps [(_, _, e)] [] = return e
     compileOps acc [] = compileOps (shrink acc) []
     compileOps acc@((p, g, e1): ee) es_@((op, e'): es) = case compareFixity (pr, op) (p, g) of
         Right GT -> compileOps ((pr, op, e'): acc) es
         Right LT -> compileOps (shrink acc) es_
-        Left err -> error err
+        Left err -> throwError err
       where
         pr = getFixity op
 
diff --git a/src/LambdaCube/Compiler/Parser.hs b/src/LambdaCube/Compiler/Parser.hs
index e8f59fad..ca9570b4 100644
--- a/src/LambdaCube/Compiler/Parser.hs
+++ b/src/LambdaCube/Compiler/Parser.hs
@@ -487,20 +487,21 @@ parseTerm_ prec = case prec of
     mkDotDot e f = SBuiltin "fromTo" `SAppV` e `SAppV` f
 
     calculatePrecs :: DesugarInfo -> [Either SIName SExp] -> P SExp
-    calculatePrecs dcls = either fail return . f where
+    calculatePrecs dcls = f where
         f []                 = error "impossible"
-        f (Right t: xs)      = either (\(op, xs) -> Section $ SLamV $ SGlobal op `SAppV` up1 (calcPrec' t xs) `SAppV` SVar (mempty, ".rs") 0) (calcPrec' t) <$> cont xs
+        f (Right t: xs)      = join $ either (\(op, xs) -> calcPrec' t xs <&> \z -> Section $ SLamV $ SGlobal op `SAppV` up1 z `SAppV` SVar (mempty, ".rs") 0) (calcPrec' t) <$> cont xs
         f xs@(Left op@(_, "-"): _) = f $ Right (mkLit $ LInt 0): xs
-        f (Left op: xs)      = g op xs >>= either (const $ Left "TODO: better error message @476")
-                                                  (\((op, e): oe) -> return $ Section $ SLamV $ SGlobal op `SAppV` SVar (mempty, ".ls") 0 `SAppV` up1 (calcPrec' e oe))
+        f (Left op: xs)      = g op xs >>= either (const $ fail "TODO: better error message @476")
+                                                  (\((op, e): oe) -> calcPrec' e oe <&> \z -> Section $ SLamV $ SGlobal op `SAppV` SVar (mempty, ".ls") 0 `SAppV` up1 z)
+
         g op (Right t: xs)   = (second ((op, t):) +++ ((op, t):)) <$> cont xs
         g op []              = return $ Left (op, [])
-        g op _               = Left "two operator is not allowed next to each-other"
+        g op _               = fail "two operator is not allowed next to each-other"
         cont (Left op: xs)   = g op xs
         cont []              = return $ Right []
         cont _               = error "impossible"
 
-        calcPrec' = calcPrec (\op x y -> SGlobal op `SAppV` x `SAppV` y) (getFixity dcls . snd)
+        calcPrec' = (postponedCheck .) . calcPrec (\op x y -> SGlobal op `SAppV` x `SAppV` y) (getFixity dcls . snd)
 
     generator, letdecl, boolExpression :: P (SExp -> SExp)
     generator = do
@@ -601,7 +602,7 @@ parsePat = \case
   PrecAnn ->
         patType <$> parsePat PrecOp <*> parseType (Just $ Wildcard SType)
   PrecOp ->
-        calculatePatPrecs <$> dsInfo <*> p_
+        join $ calculatePatPrecs <$> dsInfo <*> p_
     where
         p_ = (,) <$> parsePat PrecApp <*> option [] (colonSymbols >>= p)
         p op = do (exp, op') <- try "pattern" ((,) <$> parsePat PrecApp <*> colonSymbols)
@@ -647,7 +648,7 @@ parsePat = \case
     patType p (Wildcard SType) = p
     patType p t = PatType (ParPat [p]) t
 
-    calculatePatPrecs dcls (e, xs) = calcPrec (\op x y -> PCon op $ ParPat . (:[]) <$> [x, y]) (getFixity dcls . snd) e xs
+    calculatePatPrecs dcls (e, xs) = postponedCheck $ calcPrec (\op x y -> PCon op $ ParPat . (:[]) <$> [x, y]) (getFixity dcls . snd) e xs
 
 longPattern = parsePat PrecAnn <&> (getPVars &&& id)
 --patternAtom = parsePat PrecAtom <&> (getPVars &&& id)
@@ -665,6 +666,9 @@ checkPattern ns = lift $ tell $ pure $
     [] -> Nothing
     xs -> Just $ "multiple pattern vars:\n" ++ unlines [n ++ " is defined at " ++ ppShow si | ns <- xs, (si, n) <- ns]
 
+postponedCheck x = do
+    lift $ tell [either Just (const Nothing) x]
+    return $ either (const $ error "impossible") id x
 
 -------------------------------------------------------------------------------- pattern match compilation