ref: 9a21178f2650f172f43e82aa74393167104e4047
parent: a5ca009ee1a1edac5a5c70a163ae1f1d6a269bd9
author: Lennart Augustsson <lennart@augustsson.net>
date: Sun Oct 29 13:44:25 EDT 2023
Fix qualification bug and add sanity checks.
--- a/comb/mhs.comb
+++ b/comb/mhs.comb
@@ -1,3 +1,3 @@
v4.0
-1154
-((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 "Applicative.pure"))) ((A :7 (K (noDefault "Applicative.<*>"))) ((A :8 (((S' B) _3) (((C' _122) _1) _114))) ((A :9 (((S' B) _3) (((C' _125) _1) _115))) ((A :10 _986) ((A :11 ((B _1028) _10)) ((A :12 (((S' _1028) _10) I)) ((A :13 _956) ((A :14 (_13 "undefined")) ((A :15 I) ((A :16 (((C' B) _985) ((C _113) _15))) ((A :17 (((C' _16) ((_121 _999) _102)) ((_113 (_23 _1001)) _101))) ((A :18 ((B ((S _1028) (_23 _1001))) _13)) ((A :19 ((B (B (B C))) ((B (B C)) P))) ((A :20 (T (BK (BK K)))) ((A :21 (T (K (BK K)))) ((A :22 (T (K (K K)))) ((A :23 (T (K (K A)))) ((A :24 (K (noDefault "Monad.>>="))) ((A :25 (((C' (C' B)) _21) K)) ((A :26 ((B _2) _20)) ((A :27 (((S' (C' B)) _21) (((S' (C' B)) _21) (B' _23)))) ((A :28 P) ((A :29 (T K)) ((A :30 (T A)) ((A :31 (K _13)) ((A :32 ((B (B Y)) (((S' B) (B' ((B P) ((C _23) _157)))) (((S' (C' B)) ((B (B (C' B))) (B' _21))) (((S' (C' (C' B))) (B' _21)) (((C' B) (B' _23)) _158)))))) ((A :33 ((B (B Y)) (((S' B) (B' ((B P) ((C _23) _914)))) (((C' (C' B)) ((B (B (C' B))) (B' _21))) BK)))) ((A :34 ((B T) ((C _23) _914))) ((A :35 ((C _32) _114)) ((A :36 ((B _116) _21)) ((A :37 ((B C) ((B C') _21))) ((A :38 ((B _116) _37)) ((A :39 ((_120 _164) (_124 _39))) ((A :40 (((((_0 _39) ((C O) K)) (_27 _41)) (_8 _40)) (_9 _40))) ((A :41 ((((_19 _40) (_116 _163)) (_25 _41)) (_26 _41))) ((A :42 ((_28 _41) (K _157))) ((A :43 ((_120 ((B (P _232)) (B _233))) (_124 _43))) ((A :44 (((((_0 _43) _233) (_27 _45)) (_8 _44)) (_9 _44))) ((A :45 ((((_19 _44) (T _232)) (_25 _45)) (_26 _45))) ((A :46 T) ((A :47 ((_120 ((B (B (_111 _46))) ((B ((C' C) _50)) (B P)))) (_124 _47))) ((A :48 (((((_0 _47) ((B (_111 _46)) P)) (_27 _49)) ((B (B (_111 _46))) (((C' B) ((B C) _50)) (BK _50)))) (_9 _48))) ((A :49 ((((_19 _48) ((B (B (_111 _46))) (((C' B) ((B C) _50)) (B _50)))) (_4 _48)) (_2 _48))) ((A :50 (T I)) ((A :51 ((B (_113 _244)) _50)) ((A :52 ((B (_111 _46)) (B (P _914)))) ((A :53 ((B (_111 _46)) (BK (P _914)))) ((A :54 ((_111 _46) ((S P) I))) ((A :55 ((B (_111 _46)) ((C (S' P)) I))) ((A :56 (R _63)) ((A :57 (T _62)) ((A :58 ((P _63) _62)) ((A :59 _63) ((A :60 ((C ((C S') _58)) I)) ((A :61 ((C S) _58)) ((A :62 K) ((A :63 A) ((A :64 ((_105 _950) _951)) ((A :65 ((_105 _960) (_109 _65))) ((A :66 _961) ((A :67 _962) ((A :68 (((S' _57) (_953 #97)) ((C _953) #122))) ((A :69 (((S' _57) (_953 #65)) ((C _953) #90))) ((A :70 (((S' _56) _68) _69)) ((A :71 (((S' _57) (_953 #48)) ((C _953) #57))) ((A :72 (((S' _57) (_953 #32)) ((C _953) #126))) ((A :73 _950) ((A :74 _951) ((A :75 _953) ((A :76 _952) ((A :77 (((S' _56) ((C (_106 _64)) #32)) (((S' _56) ((C (_106 _64)) #9)) ((C (_106 _64)) #10)))) ((A :78 ((S ((S (((S' _57) (_75 #65)) ((C _75) #90))) (_63 (((noMatch "lib/Data/Char.hs") #3) #8)))) ((B _66) (((C' _126) (((C' _127) _67) (_67 #65))) (_67 #97))))) ((A :79 ((S ((S (((S' _57) (_75 #97)) ((C _75) #97))) (_63 (((noMatch "lib/Data/Char.hs") #3) #8)))) ((B _66) (((C' _126) (((C' _127) _67) (_67 #97))) (_67 #65))))) ((A :80 _921) ((A :81 _922) ((A :82 _923) ((A :83 _924) ((A :84 (_81 %0.0)) ((A :85 _80) ((A :86 _81) ((A :87 _82) ((A :88 _83) ((A :89 ((_105 _925) _926)) ((A :90 (_106 _89)) ((A :91 (_107 _89)) ((A :92 _927) ((A :93 _928) ((A :94 _929) ((A :95 _930) ((A :96 _92) ((A :97 _93) ((A :98 _94) ((A :99 _95) ((A :100 _931) ((A :101 ((B BK) T)) ((A :102 (BK T)) ((A :103 (((S' _105) (((S' C) ((B (C S')) (((C' C) ((B (C C')) ((B _106) (T K)))) (K _62)))) ((B ((C' B) (T (K _62)))) ((B _106) (T A))))) ((B _109) ((B _103) (((S' P) (T K)) (T A)))))) ((A :104 P) ((A :105 P) ((A :106 (T K)) ((A :107 (T A)) ((A :108 (K (noDefault "Eq.=="))) ((A :109 ((B (B (B _58))) _106)) ((A :110 ((_105 ((C ((C S') _58)) I)) (_109 _110))) ((A :111 I) ((A :112 (S _958)) ((A :113 B) ((A :114 I) ((A :115 K) ((A :116 C) ((A :117 _957) ((A :118 ((C ((C S') _244)) _245)) ((A :119 (((C' (S' (C' B))) B) I)) ((A :120 P) ((A :121 (T K)) ((A :122 (T A)) ((A :123
\ No newline at end of file
+1156
+((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 "Applicative.pure"))) ((A :7 (K (noDefault "Applicative.<*>"))) ((A :8 (((S' B) _3) (((C' _123) _1) _115))) ((A :9 (((S' B) _3) (((C' _126) _1) _116))) ((A :10 _988) ((A :11 ((B _1030) _10)) ((A :12 (((S' _1030) _10) I)) ((A :13 _958) ((A :14 (_13 "undefined")) ((A :15 I) ((A :16 (((C' B) _987) ((C _114) _15))) ((A :17 (((C' _16) ((_122 _1001) _103)) ((_114 (_23 _1003)) _102))) ((A :18 ((B ((S _1030) (_23 _1003))) _13)) ((A :19 ((B (B (B C))) ((B (B C)) P))) ((A :20 (T (BK (BK K)))) ((A :21 (T (K (BK K)))) ((A :22 (T (K (K K)))) ((A :23 (T (K (K A)))) ((A :24 (K (noDefault "Monad.>>="))) ((A :25 (((C' (C' B)) _21) K)) ((A :26 ((B _2) _20)) ((A :27 (((S' (C' B)) _21) (((S' (C' B)) _21) (B' _23)))) ((A :28 P) ((A :29 (T K)) ((A :30 (T A)) ((A :31 (K _13)) ((A :32 ((B (B Y)) (((S' B) (B' ((B P) ((C _23) _158)))) (((S' (C' B)) ((B (B (C' B))) (B' _21))) (((S' (C' (C' B))) (B' _21)) (((C' B) (B' _23)) _159)))))) ((A :33 ((B (B Y)) (((S' B) (B' ((B P) ((C _23) _916)))) (((C' (C' B)) ((B (B (C' B))) (B' _21))) BK)))) ((A :34 ((B T) ((C _23) _916))) ((A :35 ((C _32) _115)) ((A :36 ((B _117) _21)) ((A :37 ((B C) ((B C') _21))) ((A :38 ((B _117) _37)) ((A :39 ((_121 _165) (_125 _39))) ((A :40 (((((_0 _39) ((C O) K)) (_27 _41)) (_8 _40)) (_9 _40))) ((A :41 ((((_19 _40) (_117 _164)) (_25 _41)) (_26 _41))) ((A :42 ((_28 _41) (K _158))) ((A :43 ((_121 ((B (P _233)) (B _234))) (_125 _43))) ((A :44 (((((_0 _43) _234) (_27 _45)) (_8 _44)) (_9 _44))) ((A :45 ((((_19 _44) (T _233)) (_25 _45)) (_26 _45))) ((A :46 T) ((A :47 ((_121 ((B (B (_112 _46))) ((B ((C' C) _50)) (B P)))) (_125 _47))) ((A :48 (((((_0 _47) ((B (_112 _46)) P)) (_27 _49)) ((B (B (_112 _46))) (((C' B) ((B C) _50)) (BK _50)))) (_9 _48))) ((A :49 ((((_19 _48) ((B (B (_112 _46))) (((C' B) ((B C) _50)) (B _50)))) (_4 _48)) (_2 _48))) ((A :50 (T I)) ((A :51 ((B (_114 _245)) _50)) ((A :52 ((B (_112 _46)) (B (P _916)))) ((A :53 ((B (_112 _46)) (BK (P _916)))) ((A :54 ((_112 _46) ((S P) I))) ((A :55 ((B (_112 _46)) ((C (S' P)) I))) ((A :56 (R _63)) ((A :57 (T _62)) ((A :58 ((P _63) _62)) ((A :59 _63) ((A :60 ((C ((C S') _58)) I)) ((A :61 ((C S) _58)) ((A :62 K) ((A :63 A) ((A :64 ((_106 _952) _953)) ((A :65 ((_106 _962) (_110 _65))) ((A :66 _963) ((A :67 _964) ((A :68 (((S' _57) (_955 #97)) ((C _955) #122))) ((A :69 (((S' _57) (_955 #65)) ((C _955) #90))) ((A :70 (((S' _56) _68) _69)) ((A :71 (((S' _57) (_955 #48)) ((C _955) #57))) ((A :72 (((S' _56) _70) _71)) ((A :73 (((S' _57) (_955 #32)) ((C _955) #126))) ((A :74 _952) ((A :75 _953) ((A :76 _955) ((A :77 _954) ((A :78 (((S' _56) ((C (_107 _64)) #32)) (((S' _56) ((C (_107 _64)) #9)) ((C (_107 _64)) #10)))) ((A :79 ((S ((S (((S' _57) (_76 #65)) ((C _76) #90))) (_63 (((noMatch "lib/Data/Char.hs") #3) #8)))) ((B _66) (((C' _127) (((C' _128) _67) (_67 #65))) (_67 #97))))) ((A :80 ((S ((S (((S' _57) (_76 #97)) ((C _76) #97))) (_63 (((noMatch "lib/Data/Char.hs") #3) #8)))) ((B _66) (((C' _127) (((C' _128) _67) (_67 #97))) (_67 #65))))) ((A :81 _923) ((A :82 _924) ((A :83 _925) ((A :84 _926) ((A :85 (_82 %0.0)) ((A :86 _81) ((A :87 _82) ((A :88 _83) ((A :89 _84) ((A :90 ((_106 _927) _928)) ((A :91 (_107 _90)) ((A :92 (_108 _90)) ((A :93 _929) ((A :94 _930) ((A :95 _931) ((A :96 _932) ((A :97 _93) ((A :98 _94) ((A :99 _95) ((A :100 _96) ((A :101 _933) ((A :102 ((B BK) T)) ((A :103 (BK T)) ((A :104 (((S' _106) (((S' C) ((B (C S')) (((C' C) ((B (C C')) ((B _107) (T K)))) (K _62)))) ((B ((C' B) (T (K _62)))) ((B _107) (T A))))) ((B _110) ((B _104) (((S' P) (T K)) (T A)))))) ((A :105 P) ((A :106 P) ((A :107 (T K)) ((A :108 (T A)) ((A :109 (K (noDefault "Eq.=="))) ((A :110 ((B (B (B _58))) _107)) ((A :111 ((_106 ((C ((C S') _58)) I)) (_110 _111))) ((A :112 I) ((A :113 (S _960)) ((A :114 B) ((A :115 I) ((A :116 K) ((A :117 C) ((A :118 _959) ((A :119 ((C ((C S') _245)) _246)) ((A :120 (((C' (S' (C' B))) B) I)) ((A :121 P) ((A :122
\ No newline at end of file
--- a/lib/Data/Char.hs
+++ b/lib/Data/Char.hs
@@ -35,6 +35,9 @@
isDigit :: Char -> Bool
isDigit c = (primCharLE '0' c) && (primCharLE c '9')
+isAlphaNum :: Char -> Bool
+isAlphaNum c = isAlpha c || isDigit c
+
isPrint :: Char -> Bool
isPrint c = primCharLE ' ' c && primCharLE c '~'
--- a/src/MicroHs/Desugar.hs
+++ b/src/MicroHs/Desugar.hs
@@ -52,12 +52,12 @@
Class ctx (c, _) bs ->
let f = mkIdent "$f"
meths :: [Ident]
- meths = [ i | (BSign i _) <- bs ]
+ meths = [ qualIdent mn i | (BSign i _) <- bs ]
supers :: [Ident]
- supers = [ mkSuperSel mn c i | i <- [1 .. length ctx] ]
+ supers = [ qualIdent mn $ mkSuperSel c i | i <- [1 .. length ctx] ]
xs = [ mkIdent ("$x" ++ showInt j) | j <- [ 1 .. length ctx + length meths ] ]in (qualIdent mn $ mkClassConstructor c, lams xs $ Lam f $ apps (Var f) (map Var xs)) :
- zipWith (\ i x -> (qualIdent mn i, Lam f $ App (Var f) (lams xs $ Var x))) (supers ++ meths) xs
+ zipWith (\ i x -> (expectQualified i, Lam f $ App (Var f) (lams xs $ Var x))) (supers ++ meths) xs
Instance _ _ _ _ -> []
oneAlt :: Expr -> EAlts
--- a/src/MicroHs/Ident.hs
+++ b/src/MicroHs/Ident.hs
@@ -15,6 +15,7 @@
SLoc(..), noSLoc, isNoSLoc,
showSLoc,
compareIdent,
+ expectQualified,
) where
import Data.Eq
import Prelude --Xhiding(showString)
@@ -79,8 +80,20 @@
eqIdent :: Ident -> Ident -> Bool
eqIdent (Ident _ i) (Ident _ j) = eqString i j
-qualIdent :: Ident -> Ident -> Ident
+qualIdent :: --XHasCallStack =>
+ Ident -> Ident -> Ident
+--XqualIdent _ (Ident _ i) | isQual i = error $ "already qualified " ++ i
qualIdent (Ident loc qi) (Ident _ i) = Ident loc (qi ++ "." ++ i)
+
+expectQualified :: --XHasCallStack =>
+ Ident -> Ident
+--XexpectQualified (Ident _ s) | not (isQual s) = error $ "not qualified " ++ s
+expectQualified i = i
+
+--XisQual :: String -> Bool
+--XisQual (c:'.':_:_) | isAlphaNum c = True
+--XisQual (_:cs) = isQual cs
+--XisQual "" = False
addIdentSuffix :: Ident -> String -> Ident
addIdentSuffix (Ident loc i) s = Ident loc (i ++ s)
--- a/src/MicroHs/TypeCheck.hs
+++ b/src/MicroHs/TypeCheck.hs
@@ -1934,12 +1934,13 @@
let (iks, sups, _, _) = fromMaybe impossible $ M.lookup iCls ct
sub = zip (map idKindIdent iks) args
sups' = map (subst sub) sups
- mn <- gets moduleName
- insts <- concat <$> T.mapM (\ (i, sup) -> expandDict (EVar (mkSuperSel mn iCls i) `EApp` edict) sup) (zip [1 ..] sups')
+-- mn <- gets moduleName
+ insts <- concat <$> T.mapM (\ (i, sup) -> expandDict (EVar (expectQualified $ mkSuperSel iCls i) `EApp` edict) sup) (zip [1 ..] sups')
T.return $ (edict, [], [], cn) : insts
-mkSuperSel :: IdentModule -> Ident -> Int -> Ident
-mkSuperSel mn c i = qualIdent mn $ mkIdent $ unIdent c ++ "$super" ++ showInt i
+mkSuperSel :: --XHasCallStack =>
+ Ident -> Int -> Ident
+mkSuperSel c i = addIdentSuffix c ("$super" ++ showInt i)---------------------------------
--
⑨