Fix objects introduced by forall without typeclass constraints

src/Language/PureScript/CoreFn/Desugar.hs

@@ -176,6 +176,36 @@ lookupType sp tn = do
       traceM $ "lookupType: " <> showIdent' tn <> " :: " <> ppType 10 ty
       pure (ty,nv)
 
+getInnerArrayTy :: Type a -> Maybe (Type a)
+getInnerArrayTy (ArrayT arr) = Just arr
+getInnerArrayTy (ForAll _ _ _ _ ty _) = getInnerArrayTy ty
+getInnerArrayTy _ = Nothing
+
+{-| Extracts inner type of an object if it is behind foralls
+-}
+getInnerObjectTy :: Type a -> Maybe (Type a)
+getInnerObjectTy (RecordT row) = Just row
+getInnerObjectTy (ForAll _ _ _ _ ty _) = getInnerObjectTy ty
+getInnerObjectTy _ = Nothing
+
+objectToCoreFn :: forall m. M m => ModuleName -> SourceSpan -> SourceType -> SourceType -> [(PSString, A.Expr)] -> m (Expr Ann)
+objectToCoreFn mn ss recTy row objFields = do
+  traceM $ "ObjLitTy: " <> show row
+  let (tyFields,_) = rowToList row
+      tyMap = M.fromList $ (\x -> (runLabel (rowListLabel x),x)) <$> tyFields
+  resolvedFields <- foldM (go tyMap) [] objFields
+  pure $ Literal (ss,[],Nothing) recTy (ObjectLiteral resolvedFields)
+ where
+   go :: M.Map PSString (RowListItem SourceAnn) -> [(PSString, Expr Ann)] -> (PSString, A.Expr) -> m [(PSString, Expr Ann)]
+   go tyMap acc (lbl,expr) = case M.lookup lbl tyMap of
+     Just rowListItem -> do
+       let fieldTy = rowListType rowListItem
+       expr' <- exprToCoreFn mn ss (Just fieldTy) expr
+       pure $ (lbl,expr'):acc
+     Nothing -> do -- error $ "row type missing field " <> T.unpack (prettyPrintString lbl)
+       expr' <- exprToCoreFn mn ss Nothing expr
+       pure $ (lbl,expr') : acc
+
 {- Converts declarations from their AST to CoreFn representation, deducing types when possible & inferring them when not possible.
 
    TODO: The module name can be retrieved from the monadic context and doesn't need to be passed around
@@ -237,32 +267,23 @@ declToCoreFn _ _ = pure []
 exprToCoreFn :: forall m. M m => ModuleName -> SourceSpan -> Maybe SourceType -> A.Expr -> m (Expr Ann)
 -- Array & Object literals can contain non-literal expressions. Both of these types should always be tagged
 -- (i.e. returned as an AST.TypedValue) after the initial typechecking phase, so we expect the type to be passed in
-exprToCoreFn mn ss (Just arrT@(ArrayT ty)) astlit@(A.Literal _ (ArrayLiteral ts)) = wrapTrace ("exprToCoreFn ARRAYLIT " <> renderValue 100 astlit) $ do
-  traceM $ ppType 100 arrT
-  arr <- ArrayLiteral <$> traverse (exprToCoreFn mn ss (Just ty)) ts
-  pure $ Literal (ss,[],Nothing) arrT  arr
--- An empty list could either have a TyVar or a quantified type (or a concrete type, which is handled by the previous case)
-exprToCoreFn _ ss (Just tyVar) astlit@(A.Literal _ (ArrayLiteral [])) = wrapTrace ("exprToCoreFn ARRAYLIT EMPTY " <> renderValue 100 astlit) $ do
-  pure $ Literal (ss,[],Nothing) tyVar (ArrayLiteral [])
+exprToCoreFn mn ss (Just arrT) astlit@(A.Literal _ (ArrayLiteral ts))
+  | Just ty <- getInnerArrayTy arrT
+  = wrapTrace ("exprToCoreFn ARRAYLIT " <> renderValue 100 astlit) $ do
+      traceM $ ppType 100 arrT
+      arr <- ArrayLiteral <$> traverse (exprToCoreFn mn ss (Just ty)) ts
+      pure $ Literal (ss,[],Nothing) arrT  arr
+
 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
-      tyMap = M.fromList $ (\x -> (runLabel (rowListLabel x),x)) <$> tyFields
-  resolvedFields <- foldM (go tyMap) [] objFields
-  pure $ Literal (ss,[],Nothing) recTy (ObjectLiteral resolvedFields)
- where
-   go :: M.Map PSString (RowListItem SourceAnn) -> [(PSString, Expr Ann)] -> (PSString, A.Expr) -> m [(PSString, Expr Ann)]
-   go tyMap acc (lbl,expr) = case M.lookup lbl tyMap of
-     Just rowListItem -> do
-       let fieldTy = rowListType rowListItem
-       expr' <- exprToCoreFn mn ss (Just fieldTy) expr
-       pure $ (lbl,expr'):acc
-     Nothing -> do -- error $ "row type missing field " <> T.unpack (prettyPrintString lbl)
-       expr' <- exprToCoreFn mn ss Nothing expr
-       pure $ (lbl,expr') : acc
+exprToCoreFn mn ss (Just recTy) (A.Literal _ (ObjectLiteral objFields))
+  | Just row <- getInnerObjectTy recTy
+  = objectToCoreFn mn ss recTy row objFields
+
+exprToCoreFn _ _ (Just ty) (A.Literal _ (ObjectLiteral _)) =
+  internalError $ "Error while desugaring Object Literal. Unexpected type:\n" <> show ty
+
 exprToCoreFn _ _ Nothing astlit@(A.Literal _ (ObjectLiteral _)) =
   internalError $ "Error while desugaring Object Literal. No type provided for literal:\n" <> renderValue 100 astlit
 

tests/purus/passing/Misc/Lib.purs

@@ -220,6 +220,15 @@ consEmptyList1 = cons 1 emptyList
 
 consEmptyList2 = cons "hello" emptyList
 
+id :: forall t. t -> t
+id x = x
+
+objForall :: forall a b. {getIdA :: a -> a, getIdB :: b -> b}
+objForall = {getIdA: id, getIdB: id}
+
+arrForall :: forall a. Array (a -> a)
+arrForall = [id]
+
 {- We should probably just remove guarded case branches, see slack msg
 guardedCase :: Int
 guardedCase = case polyInObj of

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

@@ -57,6 +57,9 @@ Exports:
   emptyList,
   consEmptyList1,
   consEmptyList2,
+  id,
+  objForall,
+  arrForall,
   eqInt,
   eq2IntBoolean
 Re-Exports: 
@@ -253,6 +256,16 @@ minus = \(v: Int) -> \(v1: Int) -> (42: Int)
 main :: Int
 main = (plus: Int -> Int -> Int) (1: Int) (1: Int)
 
+id :: forall (t :: Type). t -> t
+id = \(x: t) -> (x: t)
+
+objForall :: forall (a :: Type) (b :: Type). { getIdA :: a -> a, getIdB :: b -> b }
+objForall = 
+  ({
+     getIdB: (id: forall (t :: Type). t -> t),
+     getIdA: (id: forall (t :: Type). t -> t)
+   }: forall (a :: Type) (b :: Type). { getIdA :: a -> a, getIdB :: b -> b })
+
 eq2 :: forall (@a :: Type) (@b :: Type). (Eq2$Dict a b) -> a -> b -> Boolean
 eq2 = 
   \(dict: (Eq2$Dict a b)) -> 
@@ -286,8 +299,8 @@ workingEven =
        true -> (1: Int)
        _ -> (42: Int)
 
-emptyList :: forall (t100 :: Type). Array t100
-emptyList = ([]: forall (t100 :: Type). Array t100)
+emptyList :: forall (t107 :: Type). Array t107
+emptyList = ([]: forall (t107 :: Type). Array t107)
 
 cons :: forall (a :: Type). a -> Array a -> Array a
 cons = \(x: a) -> \(xs: Array a) -> ([(x: a)]: Array a)
@@ -296,13 +309,13 @@ consEmptyList1 :: Array Int
 consEmptyList1 = 
   (cons: forall (a :: Type). a -> Array a -> Array a)
   (1: Int)
-  (emptyList: forall (t100 :: Type). Array t100)
+  (emptyList: forall (t107 :: Type). Array t107)
 
 consEmptyList2 :: Array String
 consEmptyList2 = 
   (cons: forall (a :: Type). a -> Array a -> Array a)
   ("hello": String)
-  (emptyList: forall (t100 :: Type). Array t100)
+  (emptyList: forall (t107 :: Type). Array t107)
 
 brokenEven :: Int -> Int
 brokenEven = 
@@ -312,6 +325,10 @@ brokenEven =
        _ -> 
          (brokenEven: Int -> Int) ((minus: Int -> Int -> Int) (n: Int) (2: Int))
 
+arrForall :: forall (a :: Type). Array a -> a
+arrForall = 
+  ([(id: forall (t :: Type). t -> t)]: forall (a :: Type). Array a -> a)
+
 anObj :: { foo :: Int }
 anObj = ({ foo: (3: Int) }: { foo :: Int })
 
@@ -419,7 +436,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 t136)
      (go: forall (z :: Type). z -> Int)
 
 aBool :: Boolean