ref: 99f85b632239fbd05c03d4077bfd6185e428cb97
parent: b27f4ee22b4eaa99d82c1bb3bf841d2109207dd3
author: Lennart Augustsson <lennart@augustsson.net>
date: Sun Nov 5 11:03:41 EST 2023
Use a type class to get locations.
--- a/comb/mhs.comb
+++ b/comb/mhs.comb
@@ -1,3 +1,3 @@
v4.1
-1418
-((A :0 ((B (B (B (B C)))) ((B (B (B C))) ((B (B C)) P)))) ((A :1 (T (BK (BK (BK K))))) ((A :2 (T (K (BK (BK K))))) ((A :3 (T (K (K (BK K))))) ((A :4 (T (K (K (K K))))) ((A :5 (T (K (K (K A))))) ((A :6 (K (noDefault "Alternative.empty"))) ((A :7 (K (noDefault "Alternative.<|>"))) ((A :8 ((S (((S' S') ((B _14) _1)) (((C' _212) ((B _12) _1)) _395))) _5)) ((A :9 ((S (((S' C') _3) _4)) (((C' _13) _1) _394))) ((A :10 (((S' P) _2) (((C' _13) _1) _1165))) ((A :11 ((B (B (B (B C)))) ((B (B (B C))) ((B (B C)) P)))) ((A :12 (T (BK (BK (BK K))))) ((A :13 (T (K (BK (BK K))))) ((A :14 (T (K (K (BK K))))) ((A :15 (T (K (K (K K))))) ((A :16 (T (K (K (K A))))) ((A :17 (K (noDefault "Applicative.pure"))) ((A :18 (K (noDefault "Applicative.<*>"))) ((A :19 (((S' B) _14) (((C' _209) _12) _200))) ((A :20 (((S' B) _14) (((C' _212) _12) _201))) ((A :21 _1250) ((A :22 ((B _1291) _21)) ((A :23 (((S' _1291) _21) I)) ((A :24 _1220) ((A :25 (_24 "undefined")) ((A :26 I) ((A :27 (((C' B) _1249) ((C _199) _26))) ((A :28 (((C' _27) ((_208 _1261) _111)) ((_199 (_34 _1263)) _110))) ((A :29 ((B ((S _1291) (_34 _1263))) _24)) ((A :30 ((B (B (B C))) ((B (B C)) P))) ((A :31 (T (BK (BK K)))) ((A :32 (T (K (BK K)))) ((A :33 (T (K (K K)))) ((A :34 (T (K (K A)))) ((A :35 (K (noDefault "Monad.>>="))) ((A :36 (((C' (C' B)) _32) K)) ((A :37 ((B _13) _31)) ((A :38 (((S' (C' B)) _32) (((S' (C' B)) _32) (B' _34)))) ((A :39 P) ((A :40 (T K)) ((A :41 (T A)) ((A :42 (K _24)) ((A :43 ((B (B Y)) (((S' B) (B' ((B P) ((C _34) _394)))) (((S' (C' B)) ((B (B (C' B))) (B' _32))) (((S' (C' (C' B))) (B' _32)) (((C' B) (B' _34)) _395)))))) ((A :44 ((B (B Y)) (((S' B) (B' ((B P) ((C _34) _1165)))) (((C' (C' B)) ((B (B (C' B))) (B' _32))) BK)))) ((A :45 ((B T) ((C _34) _1165))) ((A :46 ((C _43) _200)) ((A :47 ((B _202) _32)) ((A :48 ((B C) ((B C') _32))) ((A :49 ((B _202) _48)) ((A :50 T) ((A :51 ((_207 ((B (B (_197 _50))) ((B ((C' C) _54)) (B P)))) (_211 _51))) ((A :52 (((((_11 _51) ((B (_197 _50)) P)) (_38 _53)) ((B (B (_197 _50))) (((C' B) ((B C) _54)) (BK _54)))) (_20 _52))) ((A :53 ((((_30 _52) ((B (B (_197 _50))) (((C' B) ((B C) _54)) (B _54)))) (_15 _52)) (_13 _52))) ((A :54 (T I)) ((A :55 ((B (_199 _467)) _54)) ((A :56 ((B (_197 _50)) (B (P _1165)))) ((A :57 ((B (_197 _50)) (BK (P _1165)))) ((A :58 ((_197 _50) ((S P) I))) ((A :59 ((B (_197 _50)) ((C (S' P)) I))) ((A :60 ((_137 ((C ((C S') _65)) I)) (_141 _60))) ((A :61 (((_1389 (K ((P (_1398 "False")) (_1398 "True")))) (_1394 _61)) (_1395 _61))) ((A :62 ((_69 _67) _68)) ((A :63 (R _68)) ((A :64 (T _67)) ((A :65 ((P _68) _67)) ((A :66 _68) ((A :67 K) ((A :68 A) ((A :69 P) ((A :70 (T K)) ((A :71 (T A)) ((A :72 (K (noDefault "Bounded.minBound"))) ((A :73 (K (noDefault "Bounded.maxBound"))) ((A :74 ((_137 _1214) _1215)) ((A :75 ((((((((_427 _74) (_436 _75)) _1216) _1217) _1218) _1219) (_441 _75)) (_442 _75))) ((A :76 ((_137 _1224) (_141 _76))) ((A :77 ((((((((_427 _76) _1223) (((C' (C' (_138 _443))) _1223) _447)) (((C' (C' (_139 _443))) _1223) _449)) (((C' (C' (_138 _443))) _1223) _449)) (((C' (C' (_139 _443))) _1223) _449)) (_441 _77)) (_442 _77))) ((A :78 ((_69 (_79 #0)) (_79 #127))) ((A :79 _1225) ((A :80 _1226) ((A :81 (((S' _64) (_1217 #97)) ((C _1217) #122))) ((A :82 (((S' _64) (_1217 #65)) ((C _1217) #90))) ((A :83 (((S' _63) _81) _82)) ((A :84 (((S' _64) (_1217 #48)) ((C _1217) #57))) ((A :85 (((S' _63) _84) (((S' _63) (((S' _64) (_1217 #97)) ((C _1217) #102))) (((S' _64) (_1217 #70)) ((C _1217) #70))))) ((A :86 (((S' _63) _83) _84)) ((A :87 (((S' _64) (_1217 #32)) ((C _1217) #126))) ((A :88 (((S' _63) ((C (_138 _74)) #32)) (((S' _63) ((C (_138 _74)) #9)) ((C (_138 _74)) #10)))) ((A :89 ((S ((S (((S' _64) (_1217 #48)) ((C _1217) #57))) ((S ((S (((S' _64) (_1217 #97)) ((C _1217) #102))) ((S ((C (((S' _64) (_1217 #65)) ((C _1217) #70))) (_24 "digitToInt"))) (((C' (_413 _213)) _80) (((_413 _213) (_80 #65)) #10))))) (((C' (_413 _213)) _80) (((_413 _213) (_80 #97)) #10))))) (((C' (_413 _213)) _80) (_80 #48)))) ((A :90 ((S ((S (((S' _64) (_1217 #65)) ((C _1217) #90))) (_68 (((noMatch "lib/Data/Char.hs") #82) #9)))) ((B _79) ((
\ No newline at end of file
+1428
+((A :0 ((B (B (B (B C)))) ((B (B (B C))) ((B (B C)) P)))) ((A :1 (T (BK (BK (BK K))))) ((A :2 (T (K (BK (BK K))))) ((A :3 (T (K (K (BK K))))) ((A :4 (T (K (K (K K))))) ((A :5 (T (K (K (K A))))) ((A :6 (K (noDefault "Alternative.empty"))) ((A :7 (K (noDefault "Alternative.<|>"))) ((A :8 ((S (((S' S') ((B _14) _1)) (((C' _212) ((B _12) _1)) _395))) _5)) ((A :9 ((S (((S' C') _3) _4)) (((C' _13) _1) _394))) ((A :10 (((S' P) _2) (((C' _13) _1) _1175))) ((A :11 ((B (B (B (B C)))) ((B (B (B C))) ((B (B C)) P)))) ((A :12 (T (BK (BK (BK K))))) ((A :13 (T (K (BK (BK K))))) ((A :14 (T (K (K (BK K))))) ((A :15 (T (K (K (K K))))) ((A :16 (T (K (K (K A))))) ((A :17 (K (noDefault "Applicative.pure"))) ((A :18 (K (noDefault "Applicative.<*>"))) ((A :19 (((S' B) _14) (((C' _209) _12) _200))) ((A :20 (((S' B) _14) (((C' _212) _12) _201))) ((A :21 _1260) ((A :22 ((B _1301) _21)) ((A :23 (((S' _1301) _21) I)) ((A :24 _1230) ((A :25 (_24 "undefined")) ((A :26 I) ((A :27 (((C' B) _1259) ((C _199) _26))) ((A :28 (((C' _27) ((_208 _1271) _111)) ((_199 (_34 _1273)) _110))) ((A :29 ((B ((S _1301) (_34 _1273))) _24)) ((A :30 ((B (B (B C))) ((B (B C)) P))) ((A :31 (T (BK (BK K)))) ((A :32 (T (K (BK K)))) ((A :33 (T (K (K K)))) ((A :34 (T (K (K A)))) ((A :35 (K (noDefault "Monad.>>="))) ((A :36 (((C' (C' B)) _32) K)) ((A :37 ((B _13) _31)) ((A :38 (((S' (C' B)) _32) (((S' (C' B)) _32) (B' _34)))) ((A :39 P) ((A :40 (T K)) ((A :41 (T A)) ((A :42 (K _24)) ((A :43 ((B (B Y)) (((S' B) (B' ((B P) ((C _34) _394)))) (((S' (C' B)) ((B (B (C' B))) (B' _32))) (((S' (C' (C' B))) (B' _32)) (((C' B) (B' _34)) _395)))))) ((A :44 ((B (B Y)) (((S' B) (B' ((B P) ((C _34) _1175)))) (((C' (C' B)) ((B (B (C' B))) (B' _32))) BK)))) ((A :45 ((B T) ((C _34) _1175))) ((A :46 ((C _43) _200)) ((A :47 ((B _202) _32)) ((A :48 ((B C) ((B C') _32))) ((A :49 ((B _202) _48)) ((A :50 T) ((A :51 ((_207 ((B (B (_197 _50))) ((B ((C' C) _54)) (B P)))) (_211 _51))) ((A :52 (((((_11 _51) ((B (_197 _50)) P)) (_38 _53)) ((B (B (_197 _50))) (((C' B) ((B C) _54)) (BK _54)))) (_20 _52))) ((A :53 ((((_30 _52) ((B (B (_197 _50))) (((C' B) ((B C) _54)) (B _54)))) (_15 _52)) (_13 _52))) ((A :54 (T I)) ((A :55 ((B (_199 _467)) _54)) ((A :56 ((B (_197 _50)) (B (P _1175)))) ((A :57 ((B (_197 _50)) (BK (P _1175)))) ((A :58 ((_197 _50) ((S P) I))) ((A :59 ((B (_197 _50)) ((C (S' P)) I))) ((A :60 ((_137 ((C ((C S') _65)) I)) (_141 _60))) ((A :61 (((_1399 (K ((P (_1408 "False")) (_1408 "True")))) (_1404 _61)) (_1405 _61))) ((A :62 ((_69 _67) _68)) ((A :63 (R _68)) ((A :64 (T _67)) ((A :65 ((P _68) _67)) ((A :66 _68) ((A :67 K) ((A :68 A) ((A :69 P) ((A :70 (T K)) ((A :71 (T A)) ((A :72 (K (noDefault "Bounded.minBound"))) ((A :73 (K (noDefault "Bounded.maxBound"))) ((A :74 ((_137 _1224) _1225)) ((A :75 ((((((((_427 _74) (_436 _75)) _1226) _1227) _1228) _1229) (_441 _75)) (_442 _75))) ((A :76 ((_137 _1234) (_141 _76))) ((A :77 ((((((((_427 _76) _1233) (((C' (C' (_138 _443))) _1233) _447)) (((C' (C' (_139 _443))) _1233) _449)) (((C' (C' (_138 _443))) _1233) _449)) (((C' (C' (_139 _443))) _1233) _449)) (_441 _77)) (_442 _77))) ((A :78 ((_69 (_79 #0)) (_79 #127))) ((A :79 _1235) ((A :80 _1236) ((A :81 (((S' _64) (_1227 #97)) ((C _1227) #122))) ((A :82 (((S' _64) (_1227 #65)) ((C _1227) #90))) ((A :83 (((S' _63) _81) _82)) ((A :84 (((S' _64) (_1227 #48)) ((C _1227) #57))) ((A :85 (((S' _63) _84) (((S' _63) (((S' _64) (_1227 #97)) ((C _1227) #102))) (((S' _64) (_1227 #70)) ((C _1227) #70))))) ((A :86 (((S' _63) _83) _84)) ((A :87 (((S' _64) (_1227 #32)) ((C _1227) #126))) ((A :88 (((S' _63) ((C (_138 _74)) #32)) (((S' _63) ((C (_138 _74)) #9)) ((C (_138 _74)) #10)))) ((A :89 ((S ((S (((S' _64) (_1227 #48)) ((C _1227) #57))) ((S ((S (((S' _64) (_1227 #97)) ((C _1227) #102))) ((S ((C (((S' _64) (_1227 #65)) ((C _1227) #70))) (_24 "digitToInt"))) (((C' (_413 _213)) _80) (((_413 _213) (_80 #65)) #10))))) (((C' (_413 _213)) _80) (((_413 _213) (_80 #97)) #10))))) (((C' (_413 _213)) _80) (_80 #48)))) ((A :90 ((S ((S (((S' _64) (_1227 #65)) ((C _1227) #90))) (_68 (((noMatch "lib/Data/Char.hs") #82) #9)))) ((B _79) ((
\ No newline at end of file
--- a/src/MicroHs/Desugar.hs
+++ b/src/MicroHs/Desugar.hs
@@ -46,7 +46,7 @@
in zipWith dsConstr [0::Int ..] cs
Newtype _ (Constr c _) -> [ (qualIdent mn c, Lit (LPrim "I")) ]
Type _ _ -> []
- Fcn f eqns -> [(f, dsEqns (getSLocIdent f) eqns)]
+ Fcn f eqns -> [(f, dsEqns (getSLoc f) eqns)]
Sign _ _ -> []
Import _ -> []
ForImp ie i _ -> [(i, Lit $ LForImp ie)]
@@ -68,7 +68,7 @@
dsBind :: Ident -> EBind -> [LDef]
dsBind v abind =
case abind of
- BFcn f eqns -> [(f, dsEqns (getSLocIdent f) eqns)]
+ BFcn f eqns -> [(f, dsEqns (getSLoc f) eqns)]
BPat p e ->
let
de = (v, dsExpr e)
@@ -189,12 +189,12 @@
case aexpr of
EVar i -> Var i
EApp f a -> App (dsExpr f) (dsExpr a)
- ELam qs -> dsEqns (getSLocExpr aexpr) qs
+ ELam qs -> dsEqns (getSLoc aexpr) qs
ELit _ (LChar c) -> Lit (LInt (ord c))
ELit _ (LInteger i) -> encodeInteger i
ELit _ (LRat i) -> encodeRational i
ELit _ l -> Lit l
- ECase e as -> dsCase (getSLocExpr aexpr) e as
+ ECase e as -> dsCase (getSLoc aexpr) e as
ELet ads e -> dsBinds ads (dsExpr e)
ETuple es -> Lam (mkIdent "$f") $ foldl App (Var $ mkIdent "$f") $ map dsExpr es
EIf e1 e2 e3 ->
@@ -247,7 +247,7 @@
ECon _ -> ap
EApp f a -> EApp (dsPat f) (dsPat a)
EListish (LList ps) -> dsPat $ foldr (\ x xs -> EApp (EApp consCon x) xs) nilCon ps
- ETuple ps -> dsPat $ foldl EApp (tupleCon (getSLocExpr ap) (length ps)) ps
+ ETuple ps -> dsPat $ foldl EApp (tupleCon (getSLoc ap) (length ps)) ps
EAt i p -> EAt i (dsPat p)
ELit loc (LStr cs) | length cs < 2 -> dsPat (EListish (LList (map (ELit loc . LChar) cs)))
ELit _ _ -> ap
@@ -420,7 +420,7 @@
case pes of
[] -> dflt
[(SPat (ConNew _) [x], arhs)] -> eLet x var arhs
- (SPat (ConLit l) _, arhs) : rpes ->
+ (SPat (ConLit _ l) _, arhs) : rpes ->
let
cond =
case l of
@@ -489,7 +489,7 @@
ECon c -> c
EAt _ p -> pConOf p
EApp p _ -> pConOf p
- ELit _ l -> ConLit l
+ ELit loc l -> ConLit loc l
_ -> impossible
pArgs :: EPat -> [EPat]
@@ -517,9 +517,9 @@
case getDups (==) (filter (/= dummyIdent) $ map fst ds) of
[] -> ds
(i1:_i2:_) : _ ->
- errorMessage (getSLocIdent i1) $ "duplicate definition " ++ showIdent i1
+ errorMessage (getSLoc i1) $ "duplicate definition " ++ showIdent i1
-- XXX mysteriously the location for i2 is the same as i1
- -- ++ ", also at " ++ showSLoc (getSLocIdent i2)
+ -- ++ ", also at " ++ showSLoc (getSLoc i2)
_ -> error "checkDup"
-- Make recursive definitions lazier.
--- a/src/MicroHs/Expr.hs
+++ b/src/MicroHs/Expr.hs
@@ -23,16 +23,16 @@
LHS,
Constr(..), ConstrField,
ConTyInfo,
- Con(..), conIdent, conArity, getSLocCon,
+ Con(..), conIdent, conArity,
tupleConstr, getTupleConstr,
mkTupleSel,
subst,
allVarsExpr, allVarsBind, allVarsEqn,
- getSLocExpr, setSLocExpr,
- getSLocEqns,
+ setSLocExpr,
errorMessage,
Assoc(..), Fixity,
getBindsVars,
+ HasLoc(..),
) where
import Prelude --Xhiding (Monad(..), Applicative(..), MonadFail(..), Functor(..), (<$>), (<>))
import Data.Maybe
@@ -113,7 +113,7 @@
data Con
= ConData ConTyInfo Ident
| ConNew Ident
- | ConLit Lit
+ | ConLit SLoc Lit
--Xderiving(Show)
data Listish
@@ -134,12 +134,12 @@
conArity :: Con -> Int
conArity (ConData cs i) = fromMaybe (error "conArity") $ lookup i cs
conArity (ConNew _) = 1
-conArity (ConLit _) = 0
+conArity (ConLit _ _) = 0
instance Eq Con where
(==) (ConData _ i) (ConData _ j) = i == j
(==) (ConNew i) (ConNew j) = i == j
- (==) (ConLit l) (ConLit k) = l == k
+ (==) (ConLit _ l) (ConLit _ k) = l == k
(==) _ _ = False
data Lit
@@ -244,6 +244,79 @@
---------------------------------
+-- Get the location of a syntactic element
+class HasLoc a where
+ getSLoc :: a -> SLoc
+
+instance HasLoc Ident where
+ getSLoc (Ident l _) = l
+
+-- Approximate location; only identifiers and literals carry a location
+instance HasLoc Expr where
+ getSLoc (EVar i) = getSLoc i
+ getSLoc (EApp e _) = getSLoc e
+ getSLoc (EOper e _) = getSLoc e
+ getSLoc (ELam qs) = getSLoc qs
+ getSLoc (ELit l _) = l
+ getSLoc (ECase e _) = getSLoc e
+ getSLoc (ELet bs _) = getSLoc bs
+ getSLoc (ETuple es) = getSLoc es
+ getSLoc (EListish l) = getSLoc l
+ getSLoc (EDo (Just i) _) = getSLoc i
+ getSLoc (EDo _ ss) = getSLoc ss
+ getSLoc (ESectL e _) = getSLoc e
+ getSLoc (ESectR i _) = getSLoc i
+ getSLoc (EIf e _ _) = getSLoc e
+ getSLoc (ESign e _) = getSLoc e
+ getSLoc (EAt i _) = getSLoc i
+ getSLoc (EUVar _) = error "getSLoc EUVar"
+ getSLoc (ECon c) = getSLoc c
+ getSLoc (EForall [] e) = getSLoc e
+ getSLoc (EForall iks _) = getSLoc iks
+
+instance forall a . HasLoc a => HasLoc [a] where
+ getSLoc [] = error "getSLoc []"
+ getSLoc (a:_) = getSLoc a
+
+instance HasLoc IdKind where
+ getSLoc (IdKind i _) = getSLoc i
+
+instance HasLoc Con where
+ getSLoc (ConData _ i) = getSLoc i
+ getSLoc (ConNew i) = getSLoc i
+ getSLoc (ConLit l _) = l
+
+instance HasLoc Listish where
+ getSLoc (LList es) = getSLoc es
+ getSLoc (LCompr e _) = getSLoc e
+ getSLoc (LFrom e) = getSLoc e
+ getSLoc (LFromTo e _) = getSLoc e
+ getSLoc (LFromThen e _) = getSLoc e
+ getSLoc (LFromThenTo e _ _) = getSLoc e
+
+instance HasLoc EStmt where
+ getSLoc (SBind p _) = getSLoc p
+ getSLoc (SThen e) = getSLoc e
+ getSLoc (SLet bs) = getSLoc bs
+
+instance HasLoc EBind where
+ getSLoc (BFcn i _) = getSLoc i
+ getSLoc (BPat p _) = getSLoc p
+ getSLoc (BSign i _) = getSLoc i
+
+instance HasLoc Eqn where
+ getSLoc (Eqn [] a) = getSLoc a
+ getSLoc (Eqn (p:_) _) = getSLoc p
+
+instance HasLoc EAlts where
+ getSLoc (EAlts as _) = getSLoc as
+
+instance HasLoc EAlt where
+ getSLoc ([], e) = getSLoc e
+ getSLoc (ss, _) = getSLoc ss
+
+---------------------------------
+
data Assoc = AssocLeft | AssocRight | AssocNone
--Xderiving (Show)
@@ -356,18 +429,6 @@
-----------------------------
--- XXX Should use locations in ELit
-getSLocExpr :: Expr -> SLoc
-getSLocExpr e = head $ filter (not . isNoSLoc) (map getSLocIdent (allVarsExpr e)) ++ [noSLoc]
-
-getSLocEqns :: [Eqn] -> SLoc
-getSLocEqns eqns = getSLocExpr $ ELet [BFcn dummyIdent eqns] (EVar dummyIdent)
-
-getSLocCon :: Con -> SLoc
-getSLocCon (ConData _ i) = getSLocIdent i
-getSLocCon (ConNew i) = getSLocIdent i
-getSLocCon _ = noSLoc
-
setSLocExpr :: SLoc -> Expr -> Expr
setSLocExpr l (EVar i) = EVar (setSLocIdent l i)
setSLocExpr l (ECon c) = ECon (setSLocCon l c)
@@ -513,7 +574,7 @@
ppCon :: Con -> Doc
ppCon (ConData _ s) = ppIdent s
ppCon (ConNew s) = ppIdent s
-ppCon (ConLit l) = text (showLit l)
+ppCon (ConLit _ l) = text (showLit l)
-- Literals are tagged the way they appear in the combinator file:
-- # Int
--- a/src/MicroHs/Ident.hs
+++ b/src/MicroHs/Ident.hs
@@ -4,7 +4,7 @@
Line, Col, Loc,
Ident(..),
mkIdent, mkIdentLoc, unIdent, isIdent,
- qualIdent, showIdent, getSLocIdent, setSLocIdent,
+ qualIdent, showIdent, setSLocIdent,
ppIdent,
mkIdentSLoc,
isLower_, isIdentChar, isOperChar, isConIdent,
@@ -63,9 +63,6 @@
unIdent :: Ident -> String
unIdent (Ident _ s) = s
-
-getSLocIdent :: Ident -> SLoc
-getSLocIdent (Ident loc _) = loc
setSLocIdent :: SLoc -> Ident -> Ident
setSLocIdent l (Ident _ s) = Ident l s
--- a/src/MicroHs/TypeCheck.hs
+++ b/src/MicroHs/TypeCheck.hs
@@ -211,7 +211,7 @@
--getFSExps impMap = [ (fe, se) | TModule _ fe _ se _ _ <- M.elems impMap ]
expLookup :: Ident -> SymTab Entry -> Entry
-expLookup i m = either (errorMessage (getSLocIdent i)) id $ stLookup "export" i m
+expLookup i m = either (errorMessage (getSLoc i)) id $ stLookup "export" i m
tyQIdent :: Entry -> Ident
tyQIdent (Entry (EVar qi) _) = qi
@@ -221,7 +221,7 @@
eVarI loc = EVar . mkIdentSLoc loc
expErr :: forall a . Ident -> a
-expErr i = errorMessage (getSLocIdent i) $ "export undefined " ++ showIdent i
+expErr i = errorMessage (getSLoc i) $ "export undefined " ++ showIdent i
getAppCon :: EType -> Ident
getAppCon (EVar i) = i
@@ -342,7 +342,7 @@
mergeInstInfo (InstInfo m1 l1) (InstInfo m2 l2) =
let
m = foldr (uncurry $ M.insertWith mrg) m2 (M.toList m1)
- mrg e1 _e2 = e1 -- XXX improve this if eqExpr e1 e2 then e1 else errorMessage (getSLocExpr e1) $ "Multiple instances: " ++ showSLoc (getSLocExpr e2)
+ mrg e1 _e2 = e1 -- XXX improve this if eqExpr e1 e2 then e1 else errorMessage (getSLoc e1) $ "Multiple instances: " ++ showSLoc (getSLoc e2)
l = unionBy eqInstDict l1 l2
in InstInfo m l
@@ -671,7 +671,7 @@
case M.lookup i syns of
Nothing -> return $ foldl tApp t ts
Just (EForall vks tt) ->
- if length vks /= length ts then tcError (getSLocIdent i) $ "bad synonym use"
+ if length vks /= length ts then tcError (getSLoc i) $ "bad synonym use"
--X ++ "\nXX " ++ show (i, vks, ts)
else expandSyn $ subst (zip (map idKindIdent vks) ts) tt
Just _ -> impossible
@@ -779,11 +779,11 @@
tLookup msg i = do
env <- gets valueTable
case stLookup msg i env of
- Right (Entry e s) -> return (setSLocExpr (getSLocIdent i) e, s)
+ Right (Entry e s) -> return (setSLocExpr (getSLoc i) e, s)
Left e -> do
-- let SymTab m _ = env
-- traceM (showListS showIdent (map fst (M.toList m)))
- tcError (getSLocIdent i) e
+ tcError (getSLoc i) e
tLookupV :: --XHasCallStack =>
Ident -> T (Expr, EType)
@@ -813,7 +813,7 @@
tDict (ae, at) | Just (ctx, t) <- getImplies at = do
u <- newUniq
let d = mkIdentSLoc loc ("dict$" ++ show u)- loc = getSLocExpr ae
+ loc = getSLoc ae
--traceM $ "addConstraint: " ++ showIdent d ++ " :: " ++ showEType ctx ++ " " ++ showSLoc loc
addConstraint d ctx
tDict (EApp ae (EVar d), t)
@@ -1119,7 +1119,7 @@
-- XXX for now, only allow contexts of the form (C t1 ... tn)
let usup as (EVar c) | isConIdent c = return (tApps c as)
usup as (EApp f a) = usup (a:as) f
- usup _ t = tcError (getSLocExpr t) ("bad context " ++ showEType t)+ usup _ t = tcError (getSLoc t) ("bad context " ++ showEType t)usup []
-}
@@ -1134,7 +1134,7 @@
expandInst :: EDef -> T [EDef]
expandInst dinst@(Instance vks ctx cc bs) = do
- let loc = getSLocExpr cc
+ let loc = getSLoc cc
qiCls = getAppCon cc
iInst <- newIdent loc "inst"
let sign = Sign iInst (eForall vks $ addConstraints ctx cc)
@@ -1299,7 +1299,7 @@
tCheckExpr t e | Just (ctx, t') <- getImplies t = do
_ <- undefined -- XXX
u <- newUniq
- let d = mkIdentSLoc (getSLocExpr e) ("adict$" ++ show u)+ let d = mkIdentSLoc (getSLoc e) ("adict$" ++ show u)e' <- withDict d ctx $ tCheckExpr t' e
return $ eLam [EVar d] e'
tCheckExpr t e = tCheck tcExpr t e
@@ -1346,7 +1346,7 @@
tcExprR :: --XHasCallStack =>
Expected -> Expr -> T Expr
tcExprR mt ae =
- let { loc = getSLocExpr ae } in+ let { loc = getSLoc ae } incase ae of
EVar i -> do
tcm <- gets tcMode
@@ -1376,7 +1376,7 @@
_ | isIdent "dict$" i -> do
-- Magic variable that just becomes the dictionary
- d <- newIdent (getSLocIdent i) "dict$"
+ d <- newIdent (getSLoc i) "dict$"
case mt of
Infer _ -> impossible
Check t -> addConstraint d t
@@ -1496,7 +1496,7 @@
let x = eVarI loc "$x"
tcExpr mt (eLam [x] (EApp (EApp (EVar i) x) e))
EIf e1 e2 e3 -> do
- e1' <- tCheckExpr (tBool (getSLocExpr e1)) e1
+ e1' <- tCheckExpr (tBool (getSLoc e1)) e1
case mt of
Check t -> do
e2' <- checkSigma e2 t
@@ -1530,7 +1530,7 @@
ea <- tCheckExpr (tApp (tList loc) v) a
tCheckPat v p $ \ ep -> doStmts (SBind ep ea : rss) ss
SThen a -> do
- ea <- tCheckExpr (tBool (getSLocExpr a)) a
+ ea <- tCheckExpr (tBool (getSLoc a)) a
doStmts (SThen ea : rss) ss
SLet bs ->
tcBinds bs $ \ ebs ->
@@ -1602,7 +1602,7 @@
calc es oos@((oy, (ay, py)):os) iies@((oo@(ox, (ax, px)), e) : ies) =
-- traceM (show ((unIdent (getIdent (fst o)), ay, py), (unIdent i, ax, px)))
if px == py && (ax /= ay || ax == AssocNone) then
- errorMessage (getSLocExpr ox) "ambiguous operator expression"
+ errorMessage (getSLoc ox) "ambiguous operator expression"
else if px < py || ax == AssocLeft && px == py then
doOp es oy os iies
else
@@ -1639,7 +1639,7 @@
tcPats :: forall a . EType -> [EPat] -> (EType -> [EPat] -> T a) -> T a
tcPats t [] ta = ta t []
tcPats t (p:ps) ta = do
- (tp, tr) <- unArrow (getSLocExpr p) t
+ (tp, tr) <- unArrow (getSLoc p) t
tCheckPat tp p $ \ pp -> tcPats tr ps $ \ tt pps -> ta tt (pp : pps)
tcExprLam :: Expected -> [Eqn] -> T Expr
@@ -1651,7 +1651,7 @@
--tcEqns t eqns | trace ("tcEqns: " ++ showEBind (BFcn dummyIdent eqns) ++ " :: " ++ showEType t) False = undefinedtcEqns (EForall iks t) eqns = withExtTyps iks $ tcEqns t eqns
tcEqns t eqns | Just (ctx, t') <- getImplies t = do
- let loc = getSLocEqns eqns
+ let loc = getSLoc eqns
d <- newIdent loc "adict"
f <- newIdent loc "fcnD"
withDict d ctx $ do
@@ -1662,7 +1662,7 @@
_ -> Eqn [EVar d] $ EAlts [([], EVar f)] [BFcn f eqns']
return [eqn]
tcEqns t eqns = do
- let loc = getSLocEqns eqns
+ let loc = getSLoc eqns
f <- newIdent loc "fcnS"
(eqns', ds) <- solveLocalConstraints $ mapM (tcEqn t) eqns
case ds of
@@ -1702,7 +1702,7 @@
(ee, tt) <- tInferExpr e
tCheckPat tt p $ \ pp -> ta (SBind pp ee)
tcGuard (SThen e) ta = do
- ee <- tCheckExpr (tBool (getSLocExpr e)) e
+ ee <- tCheckExpr (tBool (getSLoc e)) e
ta (SThen ee)
tcGuard (SLet bs) ta = tcBinds bs $ \ bbs -> ta (SLet bbs)
@@ -1751,7 +1751,7 @@
multCheck vs =
when (anySame vs) $ do
let v = head vs
- tcError (getSLocIdent v) $ "Multiply defined: " ++ showIdent v
+ tcError (getSLoc v) $ "Multiply defined: " ++ showIdent v
checkArity :: Int -> EPat -> T ()
checkArity n (EApp f a) = do
@@ -1760,9 +1760,9 @@
checkArity n (ECon c) =
let a = conArity c
in if n < a then
- tcError (getSLocCon c) "too few arguments"
+ tcError (getSLoc c) "too few arguments"
else if n > a then
- tcError (getSLocCon c) "too many arguments"
+ tcError (getSLoc c) "too many arguments"
else
return ()
checkArity n (EAt _ p) = checkArity n p
@@ -1777,7 +1777,7 @@
--Xerror (show p)
impossible
where
- check0 = if n /= 0 then tcError (getSLocExpr p) "Bad pattern" else return ()
+ check0 = if n /= 0 then tcError (getSLoc p) "Bad pattern" else return ()
tcBinds :: forall a . [EBind] -> ([EBind] -> T a) -> T a
tcBinds xbs ta = do
@@ -1820,8 +1820,8 @@
EVar _ -> at
EApp f a -> EApp (dsType f) (dsType a)
EOper t ies -> EOper (dsType t) [(i, dsType e) | (i, e) <- ies]
- EListish (LList [t]) -> tApp (tList (getSLocExpr at)) (dsType t)
- ETuple ts -> tApps (tupleConstr (getSLocExpr at) (length ts)) (map dsType ts)
+ EListish (LList [t]) -> tApp (tList (getSLoc at)) (dsType t)
+ ETuple ts -> tApps (tupleConstr (getSLoc at) (length ts)) (map dsType ts)
ESign t k -> ESign (dsType t) k
EForall iks t -> EForall iks (dsType t)
_ -> impossible
@@ -1908,7 +1908,7 @@
newSkolemTyVar :: Ident -> T Ident
newSkolemTyVar tv = do
uniq <- newUniq
- return (mkIdentSLoc (getSLocIdent tv) (unIdent tv ++ "#" ++ show uniq))
+ return (mkIdentSLoc (getSLoc tv) (unIdent tv ++ "#" ++ show uniq))
freeTyVars :: [EType] -> [TyVar]
-- Get the free TyVars from a type; no duplicates in result
@@ -1974,7 +1974,7 @@
esc_tvs <- getFreeTyVars (sigma : env_tys)
let bad_tvs = filter (\ i -> elem i esc_tvs) skol_tvs
when (not (null bad_tvs)) $
- tcErrorTK (getSLocExpr expr) $ "not polymorphic enough: " ++ unwords (map showIdent bad_tvs)
+ tcErrorTK (getSLoc expr) $ "not polymorphic enough: " ++ unwords (map showIdent bad_tvs)
return expr'
subsCheckRho :: --XHasCallStack =>
@@ -2086,7 +2086,7 @@
solve [] uns sol = return (uns, sol)
solve (cns@(di, ct) : cnss) uns sol = do
-- traceM ("trying " ++ showEType ct)- let loc = getSLocIdent di
+ let loc = getSLoc di
(iCls, cts) = getApp ct
case getTupleConstr iCls of
Just _ -> do
@@ -2196,7 +2196,7 @@
t' <- derefUVar t
--is <- gets instTable
--traceM $ "Cannot satisfy constraint: " ++ unlines (map (\ (i, ii) -> showIdent i ++ ":\n" ++ showInstInfo ii) (M.toList is))
- tcError (getSLocIdent i) $ "Cannot satisfy constraint: " ++ showExpr t'
+ tcError (getSLoc i) $ "Cannot satisfy constraint: " ++ showExpr t'
---------------------
--
⑨