@@ -50,6 +50,10 @@ deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@[ty] Derived
5050 , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor ty
5151 , mn == fromMaybe mn mn'
5252 = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveGeneric mn ds tyCon args
53+ | className == Qualified (Just (ModuleName [ ProperName "Prelude" ])) eq
54+ , Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty
55+ , mn == fromMaybe mn mn'
56+ = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveEq mn ds tyCon
5357deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance)
5458 = throwError . errorMessage $ CannotDerive className tys
5559deriveInstance mn ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn ds d
@@ -73,22 +77,193 @@ dataMaybe = ModuleName [ ProperName "Data", ProperName "Maybe" ]
7377typesProxy :: ModuleName
7478typesProxy = ModuleName [ ProperName "Type", ProperName "Proxy" ]
7579
80+eq :: ProperName 'ClassName
81+eq = ProperName "Eq"
82+
7683deriveGeneric
77− :: (Functor m, MonadError MultipleErrors m, MonadSupply m)
84+ :: forall m. (Functor m, MonadError MultipleErrors m, MonadSupply m)
7885 => ModuleName
7986 -> [Declaration]
8087 -> ProperName 'TypeName
8188 -> [Type]
8289 -> m [Declaration]
83−deriveGeneric mn ds tyConNm args = do
90+deriveGeneric mn ds tyConNm dargs = do
8491 tyCon <- findTypeDecl tyConNm ds
85− toSpine <- mkSpineFunction mn tyCon
86− fromSpine <- mkFromSpineFunction mn tyCon
87− let toSignature = mkSignatureFunction mn tyCon args
92+ toSpine <- mkSpineFunction tyCon
93+ fromSpine <- mkFromSpineFunction tyCon
94+ let toSignature = mkSignatureFunction tyCon dargs
8895 return [ ValueDeclaration (Ident C.toSpine) Public [] (Right toSpine)
8996 , ValueDeclaration (Ident C.fromSpine) Public [] (Right fromSpine)
9097 , ValueDeclaration (Ident C.toSignature) Public [] (Right toSignature)
9198 ]
99+ where
100+ mkSpineFunction :: Declaration -> m Expr
101+ mkSpineFunction (DataDeclaration _ _ _ args) = lamCase "$x" <$> mapM mkCtorClause args
102+ where
103+ prodConstructor :: Expr -> Expr
104+ prodConstructor = App (Constructor (Qualified (Just dataGeneric) (ProperName "SProd")))
105+
106+ recordConstructor :: Expr -> Expr
107+ recordConstructor = App (Constructor (Qualified (Just dataGeneric) (ProperName "SRecord")))
108+
109+ mkCtorClause :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative
110+ mkCtorClause (ctorName, tys) = do
111+ idents <- replicateM (length tys) freshIdent'
112+ return $ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)] (Right (caseResult idents))
113+ where
114+ caseResult idents =
115+ App (prodConstructor (StringLiteral . showQualified runProperName $ Qualified (Just mn) ctorName))
116+ . ArrayLiteral
117+ $ zipWith toSpineFun (map (Var . Qualified Nothing) idents) tys
118+
119+ toSpineFun :: Expr -> Type -> Expr
120+ toSpineFun i r | Just rec <- objectType r =
121+ lamNull . recordConstructor . ArrayLiteral .
122+ map (\(str,typ) -> ObjectLiteral [("recLabel", StringLiteral str), ("recValue", toSpineFun (Accessor str i) typ)])
123+ $ decomposeRec rec
124+ toSpineFun i _ = lamNull $ App (mkGenVar C.toSpine) i
125+ mkSpineFunction (PositionedDeclaration _ _ d) = mkSpineFunction d
126+ mkSpineFunction _ = internalError "mkSpineFunction: expected DataDeclaration"
127+
128+ mkSignatureFunction :: Declaration -> [Type] -> Expr
129+ mkSignatureFunction (DataDeclaration _ name tyArgs args) classArgs = lamNull . mkSigProd $ map mkProdClause args
130+ where
131+ mkSigProd :: [Expr] -> Expr
132+ mkSigProd = App (App (Constructor (Qualified (Just dataGeneric) (ProperName "SigProd")))
133+ (StringLiteral (showQualified runProperName (Qualified (Just mn) name)))
134+ ) . ArrayLiteral
135+
136+ mkSigRec :: [Expr] -> Expr
137+ mkSigRec = App (Constructor (Qualified (Just dataGeneric) (ProperName "SigRecord"))) . ArrayLiteral
138+
139+ proxy :: Type -> Type
140+ proxy = TypeApp (TypeConstructor (Qualified (Just typesProxy) (ProperName "Proxy")))
141+
142+ mkProdClause :: (ProperName 'ConstructorName, [Type]) -> Expr
143+ mkProdClause (ctorName, tys) =
144+ ObjectLiteral
145+ [ ("sigConstructor", StringLiteral (showQualified runProperName (Qualified (Just mn) ctorName)))
146+ , ("sigValues", ArrayLiteral . map (mkProductSignature . instantiate) $ tys)
147+ ]
148+
149+ mkProductSignature :: Type -> Expr
150+ mkProductSignature r | Just rec <- objectType r =
151+ lamNull . mkSigRec $ [ ObjectLiteral [ ("recLabel", StringLiteral str)
152+ , ("recValue", mkProductSignature typ)
153+ ]
154+ | (str, typ) <- decomposeRec rec
155+ ]
156+ mkProductSignature typ = lamNull $ App (mkGenVar C.toSignature)
157+ (TypedValue False (mkGenVar "anyProxy") (proxy typ))
158+ instantiate = replaceAllTypeVars (zipWith (\(arg, _) ty -> (arg, ty)) tyArgs classArgs)
159+ mkSignatureFunction (PositionedDeclaration _ _ d) classArgs = mkSignatureFunction d classArgs
160+ mkSignatureFunction _ _ = internalError "mkSignatureFunction: expected DataDeclaration"
161+
162+ mkFromSpineFunction :: Declaration -> m Expr
163+ mkFromSpineFunction (DataDeclaration _ _ _ args) = lamCase "$x" <$> (addCatch <$> mapM mkAlternative args)
164+ where
165+ mkJust :: Expr -> Expr
166+ mkJust = App (Constructor (Qualified (Just dataMaybe) (ProperName "Just")))
167+
168+ mkNothing :: Expr
169+ mkNothing = Constructor (Qualified (Just dataMaybe) (ProperName "Nothing"))
170+
171+ prodBinder :: [Binder] -> Binder
172+ prodBinder = ConstructorBinder (Qualified (Just dataGeneric) (ProperName "SProd"))
173+
174+ recordBinder :: [Binder] -> Binder
175+ recordBinder = ConstructorBinder (Qualified (Just dataGeneric) (ProperName "SRecord"))
176+
177+ mkAlternative :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative
178+ mkAlternative (ctorName, tys) = do
179+ idents <- replicateM (length tys) freshIdent'
180+ return $ CaseAlternative [ prodBinder [ StringBinder (showQualified runProperName (Qualified (Just mn) ctorName)), ArrayBinder (map VarBinder idents)]]
181+ . Right
182+ $ liftApplicative (mkJust $ Constructor (Qualified (Just mn) ctorName))
183+ (zipWith fromSpineFun (map (Var . Qualified Nothing) idents) tys)
184+
185+ addCatch :: [CaseAlternative] -> [CaseAlternative]
186+ addCatch = (++ [catchAll])
187+ where
188+ catchAll = CaseAlternative [NullBinder] (Right mkNothing)
189+
190+ fromSpineFun e r
191+ | Just rec <- objectType r
192+ = App (lamCase "r" [ mkRecCase (decomposeRec rec)
193+ , CaseAlternative [NullBinder] (Right mkNothing)
194+ ])
195+ (App e (mkPrelVar "unit"))
196+
197+ fromSpineFun e _ = App (mkGenVar C.fromSpine) (App e (mkPrelVar "unit"))
198+
199+ mkRecCase rs = CaseAlternative [ recordBinder [ ArrayBinder (map (VarBinder . Ident . fst) rs)
200+ ]
201+ ]
202+ . Right
203+ $ liftApplicative (mkRecFun rs) (map (\(x, y) -> fromSpineFun (Accessor "recValue" (mkVar x)) y) rs)
204+
205+ mkRecFun :: [(String, Type)] -> Expr
206+ mkRecFun xs = mkJust $ foldr lam recLiteral (map fst xs)
207+ where recLiteral = ObjectLiteral $ map (\(s,_) -> (s,mkVar s)) xs
208+ mkFromSpineFunction (PositionedDeclaration _ _ d) = mkFromSpineFunction d
209+ mkFromSpineFunction _ = internalError "mkFromSpineFunction: expected DataDeclaration"
210+
211+ -- Helpers
212+
213+ liftApplicative :: Expr -> [Expr] -> Expr
214+ liftApplicative = foldl' (\x e -> App (App (mkPrelVar "apply") x) e)
215+
216+ mkPrelVar :: String -> Expr
217+ mkPrelVar = mkVarMn (Just (ModuleName [ProperName C.prelude]))
218+
219+ mkGenVar :: String -> Expr
220+ mkGenVar = mkVarMn (Just (ModuleName [ProperName "Data", ProperName C.generic]))
221+
222+deriveEq ::
223+ forall m. (Functor m, MonadError MultipleErrors m, MonadSupply m)
224+ => ModuleName
225+ -> [Declaration]
226+ -> ProperName 'TypeName
227+ -> m [Declaration]
228+deriveEq mn ds tyConNm = do
229+ tyCon <- findTypeDecl tyConNm ds
230+ eqFun <- mkEqFunction tyCon
231+ return [ ValueDeclaration (Ident C.eq) Public [] (Right eqFun) ]
232+ where
233+ mkEqFunction :: Declaration -> m Expr
234+ mkEqFunction (DataDeclaration _ _ _ args) = lamCase2 "$x" "$y" <$> (addCatch <$> mapM mkCtorClause args)
235+ mkEqFunction (PositionedDeclaration _ _ d) = mkEqFunction d
236+ mkEqFunction _ = internalError "mkEqFunction: expected DataDeclaration"
237+
238+ preludeConj :: Expr -> Expr -> Expr
239+ preludeConj = App . App (Var (Qualified (Just (ModuleName [ProperName C.prelude])) (Ident C.conj)))
240+
241+ preludeEq :: Expr -> Expr -> Expr
242+ preludeEq = App . App (Var (Qualified (Just (ModuleName [ProperName C.prelude])) (Ident C.eq)))
243+
244+ addCatch :: [CaseAlternative] -> [CaseAlternative]
245+ addCatch = (++ [catchAll])
246+ where
247+ catchAll = CaseAlternative [NullBinder, NullBinder] (Right (BooleanLiteral False))
248+
249+ mkCtorClause :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative
250+ mkCtorClause (ctorName, tys) = do
251+ [identsL, identsR] <- replicateM 2 (replicateM (length tys) freshIdent')
252+ let tests = zipWith3 toEqTest (map (Var . Qualified Nothing) identsL) (map (Var . Qualified Nothing) identsR) tys
253+ return $ CaseAlternative [caseBinder identsL, caseBinder identsR] (Right (conjAll tests))
254+ where
255+ caseBinder idents = ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)
256+
257+ conjAll :: [Expr] -> Expr
258+ conjAll [] = BooleanLiteral True
259+ conjAll xs = foldl1 preludeConj xs
260+
261+ toEqTest :: Expr -> Expr -> Type -> Expr
262+ toEqTest l r ty | Just rec <- objectType ty =
263+ conjAll
264+ . map (\(str, typ) -> toEqTest (Accessor str l) (Accessor str r) typ)
265+ $ decomposeRec rec
266+ toEqTest l r _ = preludeEq l r
92267
93268findTypeDecl
94269 :: (Functor m, MonadError MultipleErrors m)
@@ -102,123 +277,6 @@ findTypeDecl tyConNm = maybe (throwError . errorMessage $ CannotFindDerivingType
102277 isTypeDecl (PositionedDeclaration _ _ d) = isTypeDecl d
103278 isTypeDecl _ = False
104279
105−mkSpineFunction :: forall m. (Functor m, MonadSupply m) => ModuleName -> Declaration -> m Expr
106−mkSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> mapM mkCtorClause args
107− where
108− prodConstructor :: Expr -> Expr
109− prodConstructor = App (Constructor (Qualified (Just dataGeneric) (ProperName "SProd")))
110−
111− recordConstructor :: Expr -> Expr
112− recordConstructor = App (Constructor (Qualified (Just dataGeneric) (ProperName "SRecord")))
113−
114− mkCtorClause :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative
115− mkCtorClause (ctorName, tys) = do
116− idents <- replicateM (length tys) freshIdent'
117− return $ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)] (Right (caseResult idents))
118− where
119− caseResult idents =
120− App (prodConstructor (StringLiteral . showQualified runProperName $ Qualified (Just mn) ctorName))
121− . ArrayLiteral
122− $ zipWith toSpineFun (map (Var . Qualified Nothing) idents) tys
123−
124− toSpineFun :: Expr -> Type -> Expr
125− toSpineFun i r | Just rec <- objectType r =
126− lamNull . recordConstructor . ArrayLiteral .
127− map (\(str,typ) -> ObjectLiteral [("recLabel", StringLiteral str), ("recValue", toSpineFun (Accessor str i) typ)])
128− $ decomposeRec rec
129− toSpineFun i _ = lamNull $ App (mkGenVar C.toSpine) i
130−mkSpineFunction mn (PositionedDeclaration _ _ d) = mkSpineFunction mn d
131−mkSpineFunction _ _ = internalError "mkSpineFunction: expected DataDeclaration"
132−
133−mkSignatureFunction :: ModuleName -> Declaration -> [Type] -> Expr
134−mkSignatureFunction mn (DataDeclaration _ name tyArgs args) classArgs = lamNull . mkSigProd $ map mkProdClause args
135− where
136− mkSigProd :: [Expr] -> Expr
137− mkSigProd = App (App (Constructor (Qualified (Just dataGeneric) (ProperName "SigProd")))
138− (StringLiteral (showQualified runProperName (Qualified (Just mn) name)))
139− ) . ArrayLiteral
140−
141− mkSigRec :: [Expr] -> Expr
142− mkSigRec = App (Constructor (Qualified (Just dataGeneric) (ProperName "SigRecord"))) . ArrayLiteral
143−
144− proxy :: Type -> Type
145− proxy = TypeApp (TypeConstructor (Qualified (Just typesProxy) (ProperName "Proxy")))
146−
147− mkProdClause :: (ProperName 'ConstructorName, [Type]) -> Expr
148− mkProdClause (ctorName, tys) =
149− ObjectLiteral
150− [ ("sigConstructor", StringLiteral (showQualified runProperName (Qualified (Just mn) ctorName)))
151− , ("sigValues", ArrayLiteral . map (mkProductSignature . instantiate) $ tys)
152− ]
153−
154− mkProductSignature :: Type -> Expr
155− mkProductSignature r | Just rec <- objectType r =
156− lamNull . mkSigRec $ [ ObjectLiteral [ ("recLabel", StringLiteral str)
157− , ("recValue", mkProductSignature typ)
158− ]
159− | (str, typ) <- decomposeRec rec
160− ]
161− mkProductSignature typ = lamNull $ App (mkGenVar C.toSignature)
162− (TypedValue False (mkGenVar "anyProxy") (proxy typ))
163− instantiate = replaceAllTypeVars (zipWith (\(arg, _) ty -> (arg, ty)) tyArgs classArgs)
164−mkSignatureFunction mn (PositionedDeclaration _ _ d) classArgs = mkSignatureFunction mn d classArgs
165−mkSignatureFunction _ _ _ = internalError "mkSignatureFunction: expected DataDeclaration"
166−
167−mkFromSpineFunction :: forall m. (Functor m, MonadSupply m) => ModuleName -> Declaration -> m Expr
168−mkFromSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> (addCatch <$> mapM mkAlternative args)
169− where
170− mkJust :: Expr -> Expr
171− mkJust = App (Constructor (Qualified (Just dataMaybe) (ProperName "Just")))
172−
173− mkNothing :: Expr
174− mkNothing = Constructor (Qualified (Just dataMaybe) (ProperName "Nothing"))
175−
176− prodBinder :: [Binder] -> Binder
177− prodBinder = ConstructorBinder (Qualified (Just dataGeneric) (ProperName "SProd"))
178−
179− recordBinder :: [Binder] -> Binder
180− recordBinder = ConstructorBinder (Qualified (Just dataGeneric) (ProperName "SRecord"))
181−
182− mkAlternative :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative
183− mkAlternative (ctorName, tys) = do
184− idents <- replicateM (length tys) freshIdent'
185− return $ CaseAlternative [ prodBinder [ StringBinder (showQualified runProperName (Qualified (Just mn) ctorName)), ArrayBinder (map VarBinder idents)]]
186− . Right
187− $ liftApplicative (mkJust $ Constructor (Qualified (Just mn) ctorName))
188− (zipWith fromSpineFun (map (Var . Qualified Nothing) idents) tys)
189−
190− addCatch :: [CaseAlternative] -> [CaseAlternative]
191− addCatch = (++ [catchAll])
192− where
193− catchAll = CaseAlternative [NullBinder] (Right mkNothing)
194−
195− fromSpineFun e r
196− | Just rec <- objectType r
197− = App (lamCase "r" [ mkRecCase (decomposeRec rec)
198− , CaseAlternative [NullBinder] (Right mkNothing)
199− ])
200− (App e (mkPrelVar "unit"))
201−
202− fromSpineFun e _ = App (mkGenVar C.fromSpine) (App e (mkPrelVar "unit"))
203−
204− mkRecCase rs = CaseAlternative [ recordBinder [ ArrayBinder (map (VarBinder . Ident . fst) rs)
205− ]
206− ]
207− . Right
208− $ liftApplicative (mkRecFun rs) (map (\(x, y) -> fromSpineFun (Accessor "recValue" (mkVar x)) y) rs)
209−
210− mkRecFun :: [(String, Type)] -> Expr
211− mkRecFun xs = mkJust $ foldr lam recLiteral (map fst xs)
212− where recLiteral = ObjectLiteral $ map (\(s,_) -> (s,mkVar s)) xs
213−mkFromSpineFunction mn (PositionedDeclaration _ _ d) = mkFromSpineFunction mn d
214−mkFromSpineFunction _ _ = internalError "mkFromSpineFunction: expected DataDeclaration"
215−
216−-- Helpers
217−
218−objectType :: Type -> Maybe Type
219−objectType (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Object"))) rec) = Just rec
220−objectType _ = Nothing
221−
222280lam :: String -> Expr -> Expr
223281lam s = Abs (Left (Ident s))
224282
@@ -228,8 +286,8 @@ lamNull = lam "$q"
228286lamCase :: String -> [CaseAlternative] -> Expr
229287lamCase s = lam s . Case [mkVar s]
230288
231−liftApplicative :: Expr -> [Expr] -> Expr
232−liftApplicative = foldl' (\x e -> App (App (mkPrelVar "apply") x) e)
289+lamCase2 :: String -> String -> [CaseAlternative] -> Expr
290+lamCase2 s t = lam s . lam t . Case [mkVar s, mkVar t]
233291
234292mkVarMn :: Maybe ModuleName -> String -> Expr
235293mkVarMn mn s = Var (Qualified mn (Ident s))
@@ -237,13 +295,11 @@ mkVarMn mn s = Var (Qualified mn (Ident s))
237295mkVar :: String -> Expr
238296mkVar = mkVarMn Nothing
239297
240−mkPrelVar :: String -> Expr
241−mkPrelVar = mkVarMn (Just (ModuleName [ProperName C.prelude]))
242−
243−mkGenVar :: String -> Expr
244−mkGenVar = mkVarMn (Just (ModuleName [ProperName "Data", ProperName C.generic]))
298+objectType :: Type -> Maybe Type
299+objectType (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Object"))) rec) = Just rec
300+objectType _ = Nothing
245301
246302decomposeRec :: Type -> [(String, Type)]
247303decomposeRec = sortBy (comparing fst) . go
248− where go (RCons str typ typs) = (str, typ) : decomposeRec typs
249− go _ = []
304+ where go (RCons str typ typs) = (str, typ) : decomposeRec typs
305+ go _ = []