shithub: MicroHs

Info  •  Files  •  Log  •  Branches

Make literals have a location

--- a/src/MicroHs/Desugar.hs

+++ b/src/MicroHs/Desugar.hs

@@ -113,9 +113,9 @@

     EVar i -> Var i

     EApp f a -> App (dsExpr f) (dsExpr a)

     ELam xs e -> dsLam xs e

-    ELit (LChar c) -> Lit (LInt (ord c))

---    ELit (LStr cs) -> dsExpr $ EList $ map (ELit . LChar) cs

-    ELit l -> Lit l

+    ELit _ (LChar c) -> Lit (LInt (ord c))

+--    ELit _ (LStr cs) -> dsExpr $ EList $ map (ELit . LChar) cs

+    ELit _ l -> Lit l

     ECase e as -> dsCase e as

 -- For now, just sequential bindings; each recursive

     ELet ads e -> dsBinds ads (dsExpr e)

@@ -206,7 +206,7 @@

     EList ps -> dsPat $ foldr (\ x xs -> EApp (EApp consCon x) xs) nilCon ps

     ETuple ps -> dsPat $ foldl EApp (tupleCon (length ps)) ps

     EAt i p -> EAt i (dsPat p)

-    ELit _ -> ap

+    ELit _ _ -> ap

     _ -> impossible

 consCon :: EPat

@@ -233,7 +233,7 @@

 dummyIdent = mkIdent "_"

 eError :: String -> Expr

-eError s = EApp (ELit (LPrim "error")) (ELit $ LStr s)

+eError s = EApp (ELit noSLoc (LPrim "error")) (ELit noSLoc $ LStr s)

 lams :: [Ident] -> Exp -> Exp

 lams xs e = foldr Lam e xs

@@ -454,7 +454,7 @@

     ECon c -> c

     EAt _ p -> pConOf p

     EApp p _ -> pConOf p

-    ELit l -> ConLit l

+    ELit _ l -> ConLit l

     _ -> impossible

 pArgs :: EPat -> [EPat]

@@ -462,7 +462,7 @@

   case ap of

     ECon _ -> []

     EApp f a -> pArgs f ++ [a]

-    ELit _ -> []

+    ELit _ _ -> []

     _ -> impossible

 -- XXX quadratic

--- a/src/MicroHs/Expr.hs

+++ b/src/MicroHs/Expr.hs

@@ -61,7 +61,7 @@

   = EVar Ident

   | EApp Expr Expr

   | ELam [EPat] Expr

-  | ELit Lit

+  | ELit SLoc Lit

   | ECase Expr [ECaseArm]

   | ELet [EBind] Expr

   | ETuple [Expr]

@@ -216,7 +216,7 @@

     EVar i -> [i]

     EApp e1 e2 -> allVarsExpr e1 ++ allVarsExpr e2

     ELam ps e -> concatMap allVarsPat ps ++ allVarsExpr e

-    ELit _ -> []

+    ELit _ _ -> []

     ECase e as -> allVarsExpr e ++ concatMap allVarsCaseArm as

     ELet bs e -> concatMap allVarsBind bs ++ allVarsExpr e

     ETuple es -> concatMap allVarsExpr es

@@ -298,7 +298,7 @@

     EVar v -> showIdent v

     EApp _ _ -> showApp [] ae

     ELam ps e -> "(\\" ++ unwords (map showExpr ps) ++ " -> " ++ showExpr e ++ ")"

-    ELit i -> showLit i

+    ELit _ i -> showLit i

     ECase e as -> "case " ++ showExpr e ++ " of {\n" ++ unlines (map showCaseArm as) ++ "}"

     ELet bs e -> "let\n" ++ unlines (map showEBind bs) ++ "in " ++ showExpr e

     ETuple es -> "(" ++ intercalate "," (map showExpr es) ++ ")"

--- a/src/MicroHs/Parse.hs

+++ b/src/MicroHs/Parse.hs

@@ -187,13 +187,15 @@

 pParens :: forall a . P a -> P a

 pParens p = pSpec '(' *> p <* pSpec ')'

-pLit :: P Lit

-pLit = satisfyM "Lit" is

-  where

-    is (TString _ s) = Just (LStr s)

-    is (TChar _ c) = Just (LChar c)

-    is (TInt _ i) = Just (LInt i)

+pLit :: P Expr

+pLit = P.do

+  fn <- getFileName

+  let

+    is (TString (l, c) s) = Just (ELit (SLoc fn l c) (LStr s))

+    is (TChar   (l, c) a) = Just (ELit (SLoc fn l c) (LChar a))

+    is (TInt    (l, c) i) = Just (ELit (SLoc fn l c) (LInt i))

     is _ = Nothing

+  satisfyM "literal" is

 pString :: P String

 pString = satisfyM "string" is

@@ -290,7 +292,7 @@

 pAType =

       (EVar <$> pLQIdentSym)

   <|> (EVar <$> pUQIdentSym)

-  <|> (ELit <$> pLit)

+  <|> pLit

   <|> (eTuple <$> (pSpec '(' *> esepBy1 pType (pSpec ',') <* pSpec ')'))

   <|> (EList . (:[]) <$> (pSpec '[' *> pType <* pSpec ']'))  -- Unlike expressions, only allow a single element.

@@ -306,7 +308,7 @@

 pAPat =

       (EVar <$> pLIdentSym)

   <|> (EVar <$> pUQIdentSym)

-  <|> (ELit <$> pLit)

+  <|> pLit

   <|> (eTuple <$> (pSpec '(' *> esepBy1 pPat (pSpec ',') <* pSpec ')'))

   <|> (EList <$> (pSpec '[' *> esepBy1 pPat (pSpec ',') <* pSpec ']'))

   <|> (EAt <$> (pLIdentSym <* pSymbol "@") <*> pAPat)

@@ -435,13 +437,13 @@

 pAExpr = (

       (EVar   <$> pLQIdentSym)

   <|> (EVar   <$> pUQIdentSym)

-  <|> (ELit   <$> pLit)

+  <|> pLit

   <|> (eTuple <$> (pSpec '(' *> esepBy1 pExpr (pSpec ',') <* pSpec ')'))

   <|> (EList  <$> (pSpec '[' *> esepBy1 pExpr (pSpec ',') <* pSpec ']'))

   <|> (ESectL <$> (pSpec '(' *> pExprArg) <*> (pOper <* pSpec ')'))

   <|> (ESectR <$> (pSpec '(' *> pOper) <*> (pExprArg <* pSpec ')'))

   <|> (ECompr <$> (pSpec '[' *> pExpr <* pSymbol "|") <*> (esepBy1 pStmt (pSpec ',') <* pSpec ']'))

-  <|> (ELit . LPrim <$> (pKeyword "primitive" *> pString))

+  <|> (ELit noSLoc . LPrim <$> (pKeyword "primitive" *> pString))

   )

   -- This weirdly slows down parsing

   -- <?> "aexpr"

--- a/src/MicroHs/TypeCheck.hs

+++ b/src/MicroHs/TypeCheck.hs

@@ -655,7 +655,7 @@

       (ef, _) <- tcExpr (Just (tArrow ta tr)) f

       T.return (EApp ef ea, tr)

     ELam is e -> tcExprLam mt is e

-    ELit l -> tcLit mt l

+    ELit loc l -> tcLit mt loc l

     ECase a arms -> T.do

       (ea, ta) <- tcExpr Nothing a

       tt <- unMType mt

@@ -764,9 +764,9 @@

     EUVar _ -> impossible -- shouldn't happen

     ECon _ -> impossible

-tcLit :: Maybe EType -> Lit -> T (Typed Expr)

-tcLit mt l =

-  let { lit t = T.do { munify mt t; T.return (ELit l, t) } } in

+tcLit :: Maybe EType -> SLoc -> Lit -> T (Typed Expr)

+tcLit mt loc l =

+  let { lit t = T.do { munify mt t; T.return (ELit loc l, t) } } in

   case l of

     LInt _ -> lit (tConI "Primitives.Int")

     LChar _ -> lit (tConI "Primitives.Char")

@@ -773,7 +773,7 @@

     LStr _ -> lit (tApps (mkIdent "Data.List.[]") [tConI "Primitives.Char"])

     LPrim _ -> T.do

       t <- unMType mt  -- pretend it is anything

-      T.return (ELit l, t)

+      T.return (ELit loc l, t)

 unArrow :: Maybe EType -> T (EType, EType)

 unArrow Nothing = T.do { a <- newUVar; r <- newUVar; T.return (a, r) }

-- 

⑨