Tentative fix for #30 (superclass method access)

src/Language/PureScript/CoreFn/Desugar.hs

@@ -15,7 +15,7 @@ import Language.PureScript.AST.SourcePos (SourceSpan(..), SourceAnn)
 import Language.PureScript.CoreFn.Ann (Ann, ssAnn)
 import Language.PureScript.CoreFn.Binders (Binder(..))
 import Language.PureScript.CoreFn.Expr (Bind(..), CaseAlternative(..), Expr(..), Guard)
-import Language.PureScript.CoreFn.Utils (exprType)
+import Language.PureScript.CoreFn.Utils (exprType, stripQuantifiers)
 import Language.PureScript.CoreFn.Meta (Meta(..))
 import Language.PureScript.CoreFn.Module (Module(..))
 import Language.PureScript.Crash (internalError)
@@ -47,7 +47,7 @@ import Language.PureScript.Names (
   mkQualified,
   runIdent,
   coerceProperName,
-  Name (DctorName), ProperNameType (TypeName))
+  Name (DctorName), ProperNameType (..), disqualify)
 import Language.PureScript.PSString (PSString)
 import Language.PureScript.Types (
   pattern REmptyKinded,
@@ -246,7 +246,6 @@ exprToCoreFn _ ss (Just tyVar) astlit@(A.Literal _ (ArrayLiteral [])) = wrapTrac
   pure $ Literal (ss,[],Nothing) tyVar (ArrayLiteral [])
 exprToCoreFn _ _ Nothing astlit@(A.Literal _ (ArrayLiteral _)) =
   internalError $ "Error while desugaring Array Literal. No type provided for literal:\n" <> renderValue 100 astlit
-
 exprToCoreFn mn ss (Just recTy@(RecordT row)) astlit@(A.Literal _ (ObjectLiteral objFields)) = wrapTrace ("exprToCoreFn OBJECTLIT " <> renderValue 100 astlit) $ do
   traceM $ "ObjLitTy: " <> show row
   let (tyFields,_) = rowToList row
@@ -282,8 +281,29 @@ exprToCoreFn _ _ _ (A.Literal ss (StringLiteral string)) =
 exprToCoreFn mn ss (Just accT) accessor@(A.Accessor name v) = wrapTrace ("exprToCoreFn ACCESSOR " <> renderValue 100 accessor) $ do
   v'  <- exprToCoreFn mn ss Nothing v -- v should always have a type assigned during typechecking (i.e. it will be a TypedValue that will be unwrapped)
   pure $ Accessor (ssA ss) accT name v'
-exprToCoreFn _ _ Nothing accessor@(A.Accessor _ _) =
-  internalError $ "Error while desugaring record accessor. No type provided for expression: \n" <> renderValue 100 accessor
+exprToCoreFn mn ss Nothing accessor@(A.Accessor name v) = do
+  v' <- exprToCoreFn mn ss Nothing v
+  let vTy = exprType v'
+  env <- getEnv
+  case analyzeCtor vTy of
+    Nothing -> internalError $ "(1) Error while desugaring record accessor."
+                  <> " No type provided for expression: \n" <> renderValue 100 accessor
+                  <> "\nRecord type: " <> ppType 1000 vTy
+                  <> "\nsynonyms: " <> show (runProperName . disqualify <$> M.keys env.types)
+    Just (TypeConstructor _ tyNm,_) -> case M.lookup (tyNameToCtorName tyNm) env.dataConstructors of
+      Nothing -> internalError $ "(2) Error while desugaring record accessor."
+                  <> " No type provided for expression: \n" <> renderValue 100 accessor
+      Just (_,_,ty,_) -> case stripQuantifiers ty of
+        (_,RecordT inner :-> _) -> do
+          let tyMap = M.fromList $ (\x -> (runLabel (rowListLabel x),x)) <$> (fst $ rowToList inner)
+          case M.lookup name tyMap of
+            Just (rowListType -> resTy) -> pure $ Accessor (ssA ss) resTy name v'
+            Nothing -> internalError $ "(3) Error while desugaring record accessor."
+                  <> " No type provided for expression: \n" <> renderValue 100 accessor
+        (_,other) -> internalError $ "****DEBUG:\n" <> ppType 100 other
+ where
+   tyNameToCtorName :: Qualified (ProperName 'TypeName) -> Qualified (ProperName 'ConstructorName)
+   tyNameToCtorName (Qualified qb tNm) = Qualified qb (coerceProperName tNm)
 
 exprToCoreFn mn ss (Just recT) objUpd@(A.ObjectUpdate obj vs) = wrapTrace ("exprToCoreFn OBJ UPDATE " <> renderValue 100 objUpd) $ do
   obj' <- exprToCoreFn mn ss Nothing obj
@@ -442,15 +462,14 @@ exprToCoreFn _ _ Nothing ctor@(A.Constructor _ _) =
    those types can be synthesized), we cannot be sure that the whole case expression has an explicit
    type annotation, so we try to deduce the type from the types of the alternative branches.
 
-   NOTE: This is kind of a hack to let us reuse (rather than rewrite) the existing case
+   NOTE: This is kind of a hack to let us reuse (rather than rewrite) the existing case/guard
          desugaring machinery. In order to correctly type the generated `let` bindings
          (see Language.PureScript.Sugar.CaseDeclarations), we must manually construct a polymorphic
          type that the PS typechecker cannot infer or deduce. We cannot construct such a type without
          the initial PS typechecker pass. We could write two nearly-identical versions of the
          case desugaring machinery and try to run the typechecker twice, but that adds a lot of
          complexity (machinery is complicated) and would not be good for performance (typechecking
          and inference have bad complexity).
-
 -}
 exprToCoreFn mn ss (Just caseTy) astCase@(A.Case vs alts) = wrapTrace "exprToCoreFn CASE" $ do
   traceM $ "CASE:\n" <> renderValue 100 astCase
@@ -531,18 +550,7 @@ altToCoreFn  mn ss ret boundTypes (A.CaseAlternative bs vs) = wrapTrace "altToCo
   guardToExpr [A.ConditionGuard cond] = cond
   guardToExpr _ = internalError "Guard not correctly desugared"
 
-{- Dirty hacks. If something breaks, odds are pretty good that it has something do with something here.
 
-   These two functions are adapted from utilities in Language.PureScript.TypeChecker.Types:
-     - transformLetBindings is a modification of inferLetBindings
-     - inferBinder' is a modification of inferBinder'
-
-   We need functions that perform the same tasks as those in TypeChecker.Types, but we cannot use the
-   existing functions because they call instantiatePolyTypeWithUnknowns. Instantiating a polytype to
-   an unknown type is correct *during the initial typechecking phase*, but it is disastrous for us
-   because we need to preserve the quantifiers explicitly in the typed AST.
-
--}
 transformLetBindings :: forall m. M m => ModuleName -> SourceSpan -> [Bind Ann] -> [A.Declaration] -> A.Expr -> m ([Bind Ann], Expr Ann)
 transformLetBindings mn ss seen [] ret = (seen,) <$> withBindingGroupVisible (exprToCoreFn mn ss Nothing ret)
 transformLetBindings mn _ss seen ((A.ValueDecl sa@(ss,_) ident nameKind [] [A.MkUnguarded (A.TypedValue checkType val ty)]) : rest) ret =

src/Language/PureScript/Environment.hs

@@ -390,6 +390,9 @@ pattern RecordT :: Type a -> Type a
 pattern RecordT a <-
   TypeApp _ (TypeConstructor _ C.Record) a
 
+mkRecordT :: SourceType -> SourceType
+mkRecordT = TypeApp nullSourceAnn (TypeConstructor nullSourceAnn C.Record)
+
 getFunArgTy :: Type a -> Type a
 getFunArgTy = \case
   a :-> _ -> a

src/Language/PureScript/TypeChecker/Entailment.hs

@@ -33,10 +33,10 @@ import Data.Text qualified as T
 import Data.List.NonEmpty (NonEmpty(..))
 import Data.List.NonEmpty qualified as NEL
 
-import Language.PureScript.AST (Binder(..), ErrorMessageHint(..), Expr(..), Literal(..), pattern NullSourceSpan, everywhereOnValuesTopDownM, nullSourceSpan, everythingOnValues)
+import Language.PureScript.AST (Binder(..), ErrorMessageHint(..), Expr(..), Literal(..), pattern NullSourceSpan, everywhereOnValuesTopDownM, nullSourceSpan, everythingOnValues, nullSourceAnn)
 import Language.PureScript.AST.Declarations (UnknownsHint(..))
 import Language.PureScript.Crash (internalError)
-import Language.PureScript.Environment (Environment(..), FunctionalDependency(..), TypeClassData(..), dictTypeName, kindRow, tyBoolean, tyInt, tyString)
+import Language.PureScript.Environment (Environment(..), FunctionalDependency(..), TypeClassData(..), dictTypeName, kindRow, tyBoolean, tyInt, tyString, mkRecordT)
 import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), addHint, addHints, errorMessage, rethrow)
 import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), byMaybeModuleName, coerceProperName, disqualify, freshIdent, getQual)
 import Language.PureScript.TypeChecker.Entailment.Coercible (GivenSolverState(..), WantedSolverState(..), initialGivenSolverState, initialWantedSolverState, insoluble, solveGivens, solveWanteds)
@@ -232,6 +232,9 @@ entails SolverOptions{..} constraint context hints =
     valUndefined :: Expr
     valUndefined = Var nullSourceSpan C.I_undefined
 
+    typedEmptyRecord :: Expr
+    typedEmptyRecord = TypedValue False (Literal nullSourceSpan $ ObjectLiteral []) (mkRecordT $ REmpty nullSourceAnn)
+
     solve :: SourceConstraint -> WriterT (Any, [(Ident, InstanceContext, SourceConstraint)]) (StateT InstanceContext m) Expr
     solve = go 0 hints
       where
@@ -466,7 +469,7 @@ entails SolverOptions{..} constraint context hints =
         -- Turn a DictionaryValue into a Expr
         subclassDictionaryValue :: Expr -> Qualified (ProperName 'ClassName) -> Integer -> Expr
         subclassDictionaryValue dict className index =
-          App (Accessor (mkString (superclassName className index)) dict) valUndefined
+          App (Accessor (mkString (superclassName className index)) dict) typedEmptyRecord -- valUndefined
 
     solveCoercible :: Environment -> InstanceContext -> [SourceType] -> [SourceType] -> m (Maybe [TypeClassDict])
     solveCoercible env ctx kinds [a, b] = do

tests/purus/passing/Misc/Lib.purs

@@ -227,3 +227,21 @@ guardedCase = case polyInObj of
               | eq @Int x 4 -> x
   _ -> 0
 -}
+
+{-
+id :: forall a. a -> a
+id a = a
+
+-- Works with signature, throws without
+-- inner :: { getId :: forall a. a -> a}
+inner = {getId: id}
+-}
+
+class Eq a <= Ord a where
+  compare :: a -> a -> Int
+
+instance Ord Int where
+  compare _ _ = 42
+
+testEqViaOrd :: forall a. Ord a => a -> a -> Boolean
+testEqViaOrd a b = eq a b

tests/purus/passing/Misc/output/Lib/index.cfn.pretty

@@ -4,6 +4,7 @@ Imported Modules:
   Lib,
   Prim
 Exports: 
+  compare,
   eq,
   eq2,
   minus,
@@ -57,8 +58,10 @@ Exports:
   emptyList,
   consEmptyList1,
   consEmptyList2,
+  testEqViaOrd,
   eqInt,
-  eq2IntBoolean
+  eq2IntBoolean,
+  ordInt
 Re-Exports: 
 
 Foreign: 
@@ -71,6 +74,11 @@ Eq2$Dict =
 Eq$Dict :: forall a. { eq :: a -> a -> Boolean } -> { eq :: a -> a -> Boolean }
 Eq$Dict = \(x: { eq :: a -> a -> Boolean }) -> (x: { eq :: a -> a -> Boolean })
 
+Ord$Dict :: forall a. { compare :: a -> a -> Int, Eq0 :: Record {} -> Eq$Dict a } -> { compare :: a -> a -> Int, Eq0 :: Record {} -> Eq$Dict a }
+Ord$Dict = 
+  \(x: {   compare :: a -> a -> Int, Eq0 :: Record {} -> Eq$Dict a }) -> 
+    (x: {   compare :: a -> a -> Int, Eq0 :: Record {} -> Eq$Dict a })
+
 ConInt :: Int -> TestBinderSum
 ConInt = ConInt
 
@@ -121,6 +129,21 @@ eqInt =
                                                          Int -> Boolean
                                                        })
 
+ordInt :: Ord$Dict Int
+ordInt = 
+  (Ord$Dict: {
+               compare :: Int -> Int -> Int,
+               Eq0 :: Record {}@Type -> Eq$Dict Int
+             } ->
+  Ord$Dict Int)
+  ({
+     Eq0: \($__unused: Record {}@Type) -> 
+       (eqInt: Eq$Dict Int),
+     compare: \(v: Int) -> 
+       \(v1: Int) -> 
+         (42: Int)
+   }: { compare :: Int -> Int -> Int, Eq0 :: Record {}@Type -> Eq$Dict Int })
+
 eq2IntBoolean :: (Eq2$Dict Int Boolean)
 eq2IntBoolean = 
   (Eq2$Dict: {   eq2 :: Int -> Boolean -> Boolean } -> (Eq2$Dict Int Boolean))
@@ -279,15 +302,25 @@ testEq =
   (1: Int)
   (2: Int)
 
+testEqViaOrd :: forall (a :: Type). Ord$Dict a -> a -> a -> Boolean
+testEqViaOrd = 
+  \(dictOrd: Ord$Dict a) -> 
+    \(a: a) -> 
+      \(b: a) -> 
+        (eq: forall (@a :: Type). Eq$Dict a -> a -> a -> Boolean)
+        (((dictOrd: Ord$Dict a).Eq0) ({  }: Record {}))
+        (a: a)
+        (b: a)
+
 workingEven :: Int -> Int
 workingEven = 
   \(n: Int) -> 
     case ((eq: forall (@a :: Type). Eq$Dict a -> a -> a -> Boolean) (eqInt: Eq$Dict Int) (n: Int) (0: Int)) of 
        true -> (1: Int)
        _ -> (42: Int)
 
-emptyList :: forall (t100 :: Type). Array t100
-emptyList = ([]: forall (t100 :: Type). Array t100)
+emptyList :: forall (t114 :: Type). Array t114
+emptyList = ([]: forall (t114 :: Type). Array t114)
 
 cons :: forall (a :: Type). a -> Array a -> Array a
 cons = \(x: a) -> \(xs: Array a) -> ([(x: a)]: Array a)
@@ -296,13 +329,21 @@ consEmptyList1 :: Array Int
 consEmptyList1 = 
   (cons: forall (a :: Type). a -> Array a -> Array a)
   (1: Int)
-  (emptyList: forall (t100 :: Type). Array t100)
+  (emptyList: forall (t114 :: Type). Array t114)
 
 consEmptyList2 :: Array String
 consEmptyList2 = 
   (cons: forall (a :: Type). a -> Array a -> Array a)
   ("hello": String)
-  (emptyList: forall (t100 :: Type). Array t100)
+  (emptyList: forall (t114 :: Type). Array t114)
+
+compare :: forall (@a :: Type). Ord$Dict a -> a -> a -> Int
+compare = 
+  \(dict: Ord$Dict a) -> 
+    case (dict: Ord$Dict a) of 
+       Ord$Dict v -> 
+         (v: {   compare :: a -> a -> Int, Eq0 :: Record {}@Type -> Eq$Dict a })
+         .compare
 
 brokenEven :: Int -> Int
 brokenEven = 
@@ -339,8 +380,8 @@ guardedCase =
   \(w: Int) -> 
     \(x: Int) -> 
       let
-        v :: forall $19. $19 -> Int
-        v = \(v1: $19) -> (0: Int)
+        v :: forall $23. $23 -> Int
+        v = \(v1: $23) -> (0: Int)
       in case (w: Int) (x: Int) of 
             y z -> 
               let
@@ -378,13 +419,13 @@ guardedCase =
                                       in case (v4: Boolean) of 
                                             true -> (2: Int)
                                             _ -> 
-                                              (v: forall $19. $19 -> Int)
+                                              (v: forall $23. $23 -> Int)
                                               (true: Boolean)
                                     _ -> 
-                                      (v: forall $19. $19 -> Int)
+                                      (v: forall $23. $23 -> Int)
                                       (true: Boolean)
-                            _ -> (v: forall $19. $19 -> Int) (true: Boolean)
-                    _ -> (v: forall $19. $19 -> Int) (true: Boolean)
+                            _ -> (v: forall $23. $23 -> Int) (true: Boolean)
+                    _ -> (v: forall $23. $23 -> Int) (true: Boolean)
 
 aList :: Array Int
 aList = ([(1: Int), (2: Int), (3: Int), (4: Int), (5: Int)]: Array Int)
@@ -419,7 +460,7 @@ aFunction6 =
     go :: forall (z :: Type). z -> Int
     go = \(v: z) -> (10: Int)
   in (aFunction: forall (x :: Type). x -> forall (y :: Type). y -> Int -> Int)
-     ([]: Array t127)
+     ([]: Array t142)
      (go: forall (z :: Type). z -> Int)
 
 aBool :: Boolean

tests/purus/passing/Misc/output/cache-db.json

@@ -1 +1 @@
-{"Lib":{"tests/purus/passing/Misc/Lib.purs":["2024-04-19T00:36:37.461381134Z","6a7bd73644f4f79c945356ede14f4a08a06d729012cc63a20c616cc7c60a167d892faeef84146c0ec59a065464f2015d337b90d4e424bc8e963b464a72b09d69"]}}
+{"Lib":{"tests/purus/passing/Misc/Lib.purs":["2024-04-30T21:13:07.94977279Z","0ac28732887c03d8bd11824313d60f9d11cb934980f2320c3cf5d5dd8b29926707176329944ca6ca3c2fc7f18caa005e09cf6b3c2a42cc949ad763c03961abe0"]}}