Skip to content

Commit 469b5ae

Browse files
paf31paf31
committed
Eq deriving
1 parent 2380c68 commit 469b5ae

File tree

1 file changed

+187
-131
lines changed

1 file changed

+187
-131
lines changed

‎src/Language/PureScript/Sugar/TypeClasses/Deriving.hs‎

Lines changed: 187 additions & 131 deletions
Original file line numberDiff line numberDiff line change
@@ -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
5357
deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance)
5458
= throwError . errorMessage $ CannotDerive className tys
5559
deriveInstance mn ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn ds d
@@ -73,22 +77,193 @@ dataMaybe = ModuleName [ ProperName "Data", ProperName "Maybe" ]
7377
typesProxy :: ModuleName
7478
typesProxy = ModuleName [ ProperName "Type", ProperName "Proxy" ]
7579

80+
eq :: ProperName 'ClassName
81+
eq = ProperName "Eq"
82+
7683
deriveGeneric
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

93268
findTypeDecl
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-
222280
lam :: String -> Expr -> Expr
223281
lam s = Abs (Left (Ident s))
224282

@@ -228,22 +286,20 @@ lamNull = lam "$q"
228286
lamCase :: String -> [CaseAlternative] -> Expr
229287
lamCase 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

234292
mkVarMn :: Maybe ModuleName -> String -> Expr
235293
mkVarMn mn s = Var (Qualified mn (Ident s))
236294

237295
mkVar :: String -> Expr
238296
mkVar = 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

246302
decomposeRec :: Type -> [(String, Type)]
247303
decomposeRec = 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 _ = []

0 commit comments

Comments
 (0)