@@ -13,7 +13,7 @@
14-----------------------------------------------------------------------------
14-----------------------------------------------------------------------------
16−{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, OverloadedStrings, PatternSynonyms #-}
16+{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, OverloadedStrings, PatternGuards #-}
18module Language.PureScript.TypeChecker.Deriving (
18module Language.PureScript.TypeChecker.Deriving (
19 elaborateInstance
19 elaborateInstance
@@ -56,7 +56,7 @@ mkSpineFunction t = do
56 where caseResult = App (prodConstructor (StringLiteral . runProperName . unQualify $ ctorName)) . ArrayLiteral $ zipWith toSpineFun (map (Var . Qualified Nothing) idents) (argTypes typ)
56 where caseResult = App (prodConstructor (StringLiteral . runProperName . unQualify $ ctorName)) . ArrayLiteral $ zipWith toSpineFun (map (Var . Qualified Nothing) idents) (argTypes typ)
58 toSpineFun :: Expr -> Type -> Expr
58 toSpineFun :: Expr -> Type -> Expr
59− toSpineFun i (ObjectType rec) =
59+ toSpineFun i r | Just rec <- objectType r =
60 lamNull . recordConstructor . ArrayLiteral .
60 lamNull . recordConstructor . ArrayLiteral .
61 map (\(str,typ) -> ObjectLiteral [("recLabel", StringLiteral str), ("recValue", toSpineFun (Accessor str i) typ)])
61 map (\(str,typ) -> ObjectLiteral [("recLabel", StringLiteral str), ("recValue", toSpineFun (Accessor str i) typ)])
62 $ decomposeRec rec
62 $ decomposeRec rec
@@ -73,7 +73,7 @@ mkSignatureFunction t = do
74 mkProdClause (ctorName, (_,_,typ,_)) = ObjectLiteral [("sigConstructor",StringLiteral (runProperName . unQualify $ ctorName)),("sigValues", ArrayLiteral . map mkProductSignature . argTypes $ typ)]
74 mkProdClause (ctorName, (_,_,typ,_)) = ObjectLiteral [("sigConstructor",StringLiteral (runProperName . unQualify $ ctorName)),("sigValues", ArrayLiteral . map mkProductSignature . argTypes $ typ)]
76− mkProductSignature (ObjectType rec) =
76+ mkProductSignature r | Just rec <- objectType r =
77 lamNull . mkSigRec .
77 lamNull . mkSigRec .
78 map (\(str,typ) -> ObjectLiteral [("recLabel", StringLiteral str), ("recValue", mkProductSignature typ)])
78 map (\(str,typ) -> ObjectLiteral [("recLabel", StringLiteral str), ("recValue", mkProductSignature typ)])
79 $ decomposeRec rec
79 $ decomposeRec rec
@@ -93,7 +93,7 @@ mkFromSpineFunction t = do
93 CaseAlternative [ConstructorBinder (findName "SProd" ctors) [StringBinder ctorName, ArrayBinder (map VarBinder idents)]]
93 CaseAlternative [ConstructorBinder (findName "SProd" ctors) [StringBinder ctorName, ArrayBinder (map VarBinder idents)]]
94 . Right $ liftApplicative (mkJust $ Constructor ctor) (zipWith fromSpineFun (map (Var . (Qualified Nothing))idents) (argTypes typ))
94 . Right $ liftApplicative (mkJust $ Constructor ctor) (zipWith fromSpineFun (map (Var . (Qualified Nothing))idents) (argTypes typ))
96− fromSpineFun e (ObjectType rec) = App (lamCase "r" [mkRecCase (decomposeRec rec), CaseAlternative [NullBinder] (Right mkNothing)]) (App e (mkPrelVar "unit"))
96+ fromSpineFun e r | Just rec <- objectType r = App (lamCase "r" [mkRecCase (decomposeRec rec), CaseAlternative [NullBinder] (Right mkNothing)]) (App e (mkPrelVar "unit"))
98 fromSpineFun e _ = App (mkGenVar C.fromSpine) (App e (mkPrelVar "unit"))
98 fromSpineFun e _ = App (mkGenVar C.fromSpine) (App e (mkPrelVar "unit"))
@@ -107,7 +107,9 @@ mkFromSpineFunction t = do
108-- Helpers
108-- Helpers
110+objectType :: Type -> Maybe Type
110−pattern ObjectType rec = TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Object"))) rec
111+objectType (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Object"))) rec) = Just rec
112+objectType _ = Nothing
112lam :: String -> Expr -> Expr
114lam :: String -> Expr -> Expr
113lam s = Abs (Left (Ident s))
115lam s = Abs (Left (Ident s))