@@ -34,14 +34,16 @@ import Language.PureScript.Errors
3434import Language.PureScript.Names
3535import Language.PureScript.TypeChecker.Monad
3636import Language.PureScript.Types
37+import qualified Language.PureScript.Constants as C
3738
39+-- | Takes an expression, and if the head of the expression is a TypeClassInstanceMemberFunction, elaborates that into an instantiation of the actual member function via code generation.
3840elaborateInstance :: (Functor m, MonadState CheckState m, MonadError MultipleErrors m) => Expr -> m Expr
3941elaborateInstance (TypeClassInstanceMemberFunction funName className t) =
4042 fromMaybe noInstanceError $ lookup (unQualify className, funName) derivingList
4143 where noInstanceError = throwError $ MultipleErrors [ErrorInInstance className [TypeConstructor t] (SimpleErrorWrapper $ MissingClassMember funName)]
42− derivingList = [((ProperName "Generic", Ident "toSpine"), mkSpineFunction t)
43− ,((ProperName "Generic", Ident "fromSpine"), mkFromSpineFunction t)
44− ,((ProperName "Generic", Ident "toSignature"), mkSignatureFunction t)]
44+ derivingList = [((ProperName C.generic, Ident C.toSpine), mkSpineFunction t)
45+ ,((ProperName C.generic, Ident C.fromSpine), mkFromSpineFunction t)
46+ ,((ProperName C.generic, Ident C.toSignature), mkSignatureFunction t)]
4547elaborateInstance e = return e
4648
4749mkSpineFunction :: (Functor m, MonadState CheckState m) => Qualified ProperName -> m Expr
@@ -50,19 +52,21 @@ mkSpineFunction t = do
5052 tcs <- M.toList . typeClasses <$> getEnv
5153 let prodConstructor = App (Constructor $ findName "SProd" ctors)
5254 recordConstructor = App (Constructor $ findName "SRecord" ctors)
53− genericModule = case findName "Generic" tcs of (Qualified mn _) -> mn
55+
56+ --TODO always set this
57+ genericModule = case findName C.generic tcs of (Qualified mn _) -> mn
5458
5559 mkCtorClause (ctorName, (_,_,typ,idents)) = CaseAlternative [ConstructorBinder ctorName (map VarBinder idents)] (Right caseResult)
5660 where caseResult = App (prodConstructor (StringLiteral . runProperName . unQualify $ ctorName)) . ArrayLiteral $ zipWith toSpineFun (map (Var . Qualified Nothing) idents) (argTypes typ)
5761
5862 toSpineFun :: Expr -> Type -> Expr
5963 toSpineFun i (ObjectType rec) =
60− lam "q" . recordConstructor . ArrayLiteral .
64+ lamNull . recordConstructor . ArrayLiteral .
6165 map (\(str,typ) -> ObjectLiteral [("recLabel", StringLiteral str), ("recValue", toSpineFun (Accessor str i) typ)])
6266 $ decomposeRec rec
63− toSpineFun i _ = lam "q" $ App (mkVarMn genericModule "toSpine") i
67+ toSpineFun i _ = lamNull $ App (mkVarMn genericModule C.toSpine) i
6468
65− return . lamCase "x" . map mkCtorClause . constructorsForType t $ ctors
69+ return . lamCase "$x" . map mkCtorClause . constructorsForType t $ ctors
6670
6771mkSignatureFunction :: (Functor m, MonadState CheckState m) => Qualified ProperName -> m Expr
6872mkSignatureFunction t = do
@@ -71,18 +75,20 @@ mkSignatureFunction t = do
7175 tcs <- M.toList . typeClasses <$> getEnv
7276 let mkSigProd = App (Constructor $ findName "SigProd" ctors) . ArrayLiteral
7377 mkSigRec = App (Constructor $ findName "SigRecord" ctors) . ArrayLiteral
78+
79+ -- TODO always fix this
7480 genericModule = case findName "Generic" tcs of (Qualified mn _) -> mn
7581
7682 mkProdClause (ctorName, (_,_,typ,_)) = ObjectLiteral [("sigConstructor",StringLiteral (runProperName . unQualify $ ctorName)),("sigValues", ArrayLiteral . map mkProductSignature . argTypes $ typ)]
7783
7884 mkProductSignature (ObjectType rec) =
79− lam "q" . mkSigRec .
85+ lamNull . mkSigRec .
8086 map (\(str,typ) -> ObjectLiteral [("recLabel", StringLiteral str), ("recValue", mkProductSignature typ)])
8187 $ decomposeRec rec
82− mkProductSignature typ = lam "q" $ App (mkVarMn genericModule "toSignature")
88+ mkProductSignature typ = lamNull $ App (mkVarMn genericModule "toSignature")
8389 (TypedValue False (mkVarMn genericModule "anyProxy") (TypeApp (TypeConstructor $ findName "Proxy" envtyps) typ))
8490
85− return . lam "x" . mkSigProd . map mkProdClause . constructorsForType t $ ctors
91+ return . lamNull . mkSigProd . map mkProdClause . constructorsForType t $ ctors
8692
8793mkFromSpineFunction :: (Functor m, MonadState CheckState m) => Qualified ProperName -> m Expr
8894mkFromSpineFunction t = do
@@ -91,6 +97,7 @@ mkFromSpineFunction t = do
9197 let
9298 mkJust = App (Constructor $ findName "Just" ctors)
9399 mkNothing = Constructor $ findName "Nothing" ctors
100+ --TODO hardwire this
94101 genericModule = case findName "Generic" tcs of (Qualified mn _) -> mn
95102
96103 mkAlternative (ctor@(Qualified _ (ProperName ctorName)), (_,_,typ,idents)) =
@@ -99,7 +106,7 @@ mkFromSpineFunction t = do
99106
100107 fromSpineFun e (ObjectType rec) = App (lamCase "r" [mkRecCase (decomposeRec rec), CaseAlternative [NullBinder] (Right mkNothing)]) (App e (mkPrelVar "unit"))
101108
102− fromSpineFun e _ = App (mkVarMn genericModule "fromSpine") (App e (mkPrelVar "unit"))
109+ fromSpineFun e _ = App (mkVarMn genericModule C.fromSpine) (App e (mkPrelVar "unit"))
103110
104111 mkRecCase rs = CaseAlternative [ConstructorBinder (findName "SRecord" ctors) [ArrayBinder (map (VarBinder . Ident . fst) rs)]] . Right $ liftApplicative (mkRecFun rs) (map (\(x,y) -> fromSpineFun (Accessor "recValue" (mkVar x)) y) rs)
105112
@@ -107,7 +114,7 @@ mkFromSpineFunction t = do
107114 mkRecFun xs = mkJust $ foldr (\s e -> lam s e) recLiteral (map fst xs)
108115 where recLiteral = ObjectLiteral $ map (\(s,_) -> (s,mkVar s)) xs
109116
110− return . lamCase "x" $ map mkAlternative (constructorsForType t ctors) ++ [CaseAlternative [NullBinder] (Right mkNothing)]
117+ return . lamCase "$x" $ map mkAlternative (constructorsForType t ctors) ++ [CaseAlternative [NullBinder] (Right mkNothing)]
111118
112119-- Helpers
113120
@@ -116,11 +123,14 @@ pattern ObjectType rec = TypeApp (TypeConstructor (Qualified (Just (ModuleName [
116123lam :: String -> Expr -> Expr
117124lam s = Abs (Left (Ident s))
118125
126+lamNull :: Expr -> Expr
127+lamNull = Abs (Right NullBinder)
128+
119129lamCase :: String -> [CaseAlternative] -> Expr
120130lamCase s = lam s . Case [mkVar s]
121131
122132liftApplicative :: Expr -> [Expr] -> Expr
123−liftApplicative = foldl' (\x e -> App (App (mkPrelVar "ap") x) e)
133+liftApplicative = foldl' (\x e -> App (App (mkPrelVar "apply") x) e)
124134
125135mkVarMn :: Maybe ModuleName -> String -> Expr
126136mkVarMn mn s = Var (Qualified mn (Ident s))
@@ -129,7 +139,7 @@ mkVar :: String -> Expr
129139mkVar s = mkVarMn Nothing s
130140
131141mkPrelVar :: String -> Expr
132−mkPrelVar s = mkVarMn (Just (ModuleName [ProperName "Prelude"])) s
142+mkPrelVar s = mkVarMn (Just (ModuleName [ProperName C.prelude])) s
133143
134144decomposeRec :: Type -> [(String, Type)]
135145decomposeRec = sortBy (comparing fst) . go