git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Merge pull request #1870 from purescript/eq-deriving
291ff0bPhil Freeman
examples/passing/Deriving.pursnew file+31
compare with golang
unifiedsplit
@@ -0,0 +1,31 @@
1+module Main where
2+
3+import Prelude
4+import Test.Assert
5+
6+data V
7+
8+derive instance eqV :: Eq V
9+
10+derive instance ordV :: Ord V
11+
12+data X = X Int | Y String
13+
14+derive instance eqX :: Eq X
15+
16+derive instance ordX :: Ord X
17+
18+newtype Z = Z { left :: X, right :: X }
19+
20+derive instance eqZ :: Eq Z
21+
22+main = do
23+ assert $ X 0 == X 0
24+ assert $ X 0 /= X 1
25+ assert $ Y "Foo" == Y "Foo"
26+ assert $ Y "Foo" /= Y "Bar"
27+ assert $ X 0 < X 1
28+ assert $ X 0 < Y "Foo"
29+ assert $ Y "Bar" < Y "Baz"
30+ assert $ z == z where
31+ z = Z { left: X 0, right: Y "Foo" }
src/Language/PureScript/Constants.hs+3
@@ -98,6 +98,9 @@ eq = "eq"
98notEq :: String
98notEq :: String
99notEq = "notEq"
99notEq = "notEq"
100
100
101+compare :: String
102+compare = "compare"
103+
101(&&) :: String
104(&&) :: String
102(&&) = "&&"
105(&&) = "&&"
103
106
src/Language/PureScript/Sugar/TypeClasses/Deriving.hs+285−138
@@ -50,6 +50,14 @@ deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@[ty] Derived
50 , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor ty
50 , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor ty
51 , mn == fromMaybe mn mn'
51 , mn == fromMaybe mn mn'
52 = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveGeneric mn ds tyCon args
52 = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveGeneric mn ds tyCon args
53+ | className == Qualified (Just (ModuleName [ ProperName "Prelude" ])) (ProperName "Eq")
54+ , Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty
55+ , mn == fromMaybe mn mn'
56+ = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveEq mn ds tyCon
57+ | className == Qualified (Just (ModuleName [ ProperName "Prelude" ])) (ProperName "Ord")
58+ , Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty
59+ , mn == fromMaybe mn mn'
60+ = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveOrd mn ds tyCon
53deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance)
61deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance)
54 = throwError . errorMessage $ CannotDerive className tys
62 = throwError . errorMessage $ CannotDerive className tys
55deriveInstance mn ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn ds d
63deriveInstance mn ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn ds d
@@ -74,21 +82,279 @@ typesProxy :: ModuleName
74typesProxy = ModuleName [ ProperName "Type", ProperName "Proxy" ]
82typesProxy = ModuleName [ ProperName "Type", ProperName "Proxy" ]
75
83
76deriveGeneric
84deriveGeneric
77− :: (Functor m, MonadError MultipleErrors m, MonadSupply m)
85+ :: forall m. (Functor m, MonadError MultipleErrors m, MonadSupply m)
78 => ModuleName
86 => ModuleName
79 -> [Declaration]
87 -> [Declaration]
80 -> ProperName 'TypeName
88 -> ProperName 'TypeName
81 -> [Type]
89 -> [Type]
82 -> m [Declaration]
90 -> m [Declaration]
83−deriveGeneric mn ds tyConNm args = do
91+deriveGeneric mn ds tyConNm dargs = do
84 tyCon <- findTypeDecl tyConNm ds
92 tyCon <- findTypeDecl tyConNm ds
85− toSpine <- mkSpineFunction mn tyCon
93+ toSpine <- mkSpineFunction tyCon
86− fromSpine <- mkFromSpineFunction mn tyCon
94+ fromSpine <- mkFromSpineFunction tyCon
87− let toSignature = mkSignatureFunction mn tyCon args
95+ let toSignature = mkSignatureFunction tyCon dargs
88 return [ ValueDeclaration (Ident C.toSpine) Public [] (Right toSpine)
96 return [ ValueDeclaration (Ident C.toSpine) Public [] (Right toSpine)
89 , ValueDeclaration (Ident C.fromSpine) Public [] (Right fromSpine)
97 , ValueDeclaration (Ident C.fromSpine) Public [] (Right fromSpine)
90 , ValueDeclaration (Ident C.toSignature) Public [] (Right toSignature)
98 , ValueDeclaration (Ident C.toSignature) Public [] (Right toSignature)
91 ]
99 ]
100+ where
101+ mkSpineFunction :: Declaration -> m Expr
102+ mkSpineFunction (DataDeclaration _ _ _ args) = do
103+ x <- freshIdent'
104+ lamCase x <$> mapM mkCtorClause args
105+ where
106+ prodConstructor :: Expr -> Expr
107+ prodConstructor = App (Constructor (Qualified (Just dataGeneric) (ProperName "SProd")))
108+
109+ recordConstructor :: Expr -> Expr
110+ recordConstructor = App (Constructor (Qualified (Just dataGeneric) (ProperName "SRecord")))
111+
112+ mkCtorClause :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative
113+ mkCtorClause (ctorName, tys) = do
114+ idents <- replicateM (length tys) freshIdent'
115+ return $ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)] (Right (caseResult idents))
116+ where
117+ caseResult idents =
118+ App (prodConstructor (StringLiteral . showQualified runProperName $ Qualified (Just mn) ctorName))
119+ . ArrayLiteral
120+ $ zipWith toSpineFun (map (Var . Qualified Nothing) idents) tys
121+
122+ toSpineFun :: Expr -> Type -> Expr
123+ toSpineFun i r | Just rec <- objectType r =
124+ lamNull . recordConstructor . ArrayLiteral .
125+ map (\(str,typ) -> ObjectLiteral [("recLabel", StringLiteral str), ("recValue", toSpineFun (Accessor str i) typ)])
126+ $ decomposeRec rec
127+ toSpineFun i _ = lamNull $ App (mkGenVar (Ident C.toSpine)) i
128+ mkSpineFunction (PositionedDeclaration _ _ d) = mkSpineFunction d
129+ mkSpineFunction _ = internalError "mkSpineFunction: expected DataDeclaration"
130+
131+ mkSignatureFunction :: Declaration -> [Type] -> Expr
132+ mkSignatureFunction (DataDeclaration _ name tyArgs args) classArgs = lamNull . mkSigProd $ map mkProdClause args
133+ where
134+ mkSigProd :: [Expr] -> Expr
135+ mkSigProd = App (App (Constructor (Qualified (Just dataGeneric) (ProperName "SigProd")))
136+ (StringLiteral (showQualified runProperName (Qualified (Just mn) name)))
137+ ) . ArrayLiteral
138+
139+ mkSigRec :: [Expr] -> Expr
140+ mkSigRec = App (Constructor (Qualified (Just dataGeneric) (ProperName "SigRecord"))) . ArrayLiteral
141+
142+ proxy :: Type -> Type
143+ proxy = TypeApp (TypeConstructor (Qualified (Just typesProxy) (ProperName "Proxy")))
144+
145+ mkProdClause :: (ProperName 'ConstructorName, [Type]) -> Expr
146+ mkProdClause (ctorName, tys) =
147+ ObjectLiteral
148+ [ ("sigConstructor", StringLiteral (showQualified runProperName (Qualified (Just mn) ctorName)))
149+ , ("sigValues", ArrayLiteral . map (mkProductSignature . instantiate) $ tys)
150+ ]
151+
152+ mkProductSignature :: Type -> Expr
153+ mkProductSignature r | Just rec <- objectType r =
154+ lamNull . mkSigRec $ [ ObjectLiteral [ ("recLabel", StringLiteral str)
155+ , ("recValue", mkProductSignature typ)
156+ ]
157+ | (str, typ) <- decomposeRec rec
158+ ]
159+ mkProductSignature typ = lamNull $ App (mkGenVar (Ident C.toSignature))
160+ (TypedValue False (mkGenVar (Ident "anyProxy")) (proxy typ))
161+ instantiate = replaceAllTypeVars (zipWith (\(arg, _) ty -> (arg, ty)) tyArgs classArgs)
162+ mkSignatureFunction (PositionedDeclaration _ _ d) classArgs = mkSignatureFunction d classArgs
163+ mkSignatureFunction _ _ = internalError "mkSignatureFunction: expected DataDeclaration"
164+
165+ mkFromSpineFunction :: Declaration -> m Expr
166+ mkFromSpineFunction (DataDeclaration _ _ _ args) = do
167+ x <- freshIdent'
168+ 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 :: Expr -> Type -> Expr
196+ fromSpineFun e r
197+ | Just rec <- objectType r
198+ = App (lamCase (Ident "r") [ mkRecCase (decomposeRec rec)
199+ , CaseAlternative [NullBinder] (Right mkNothing)
200+ ])
201+ (App e (mkPrelVar (Ident "unit")))
202+ fromSpineFun e _ = App (mkGenVar (Ident C.fromSpine)) (App e (mkPrelVar (Ident "unit")))
203+
204+ mkRecCase :: [(String, Type)] -> CaseAlternative
205+ mkRecCase rs = CaseAlternative [ recordBinder [ ArrayBinder (map (VarBinder . Ident . fst) rs)
206+ ]
207+ ]
208+ . Right
209+ $ liftApplicative (mkRecFun rs) (map (\(x, y) -> fromSpineFun (Accessor "recValue" (mkVar (Ident x))) y) rs)
210+
211+ mkRecFun :: [(String, Type)] -> Expr
212+ mkRecFun xs = mkJust $ foldr lam recLiteral (map (Ident . fst) xs)
213+ where recLiteral = ObjectLiteral $ map (\(s,_) -> (s, mkVar (Ident s))) xs
214+ mkFromSpineFunction (PositionedDeclaration _ _ d) = mkFromSpineFunction d
215+ mkFromSpineFunction _ = internalError "mkFromSpineFunction: expected DataDeclaration"
216+
217+ -- Helpers
218+
219+ liftApplicative :: Expr -> [Expr] -> Expr
220+ liftApplicative = foldl' (\x e -> App (App (mkPrelVar (Ident "apply")) x) e)
221+
222+ mkPrelVar :: Ident -> Expr
223+ mkPrelVar = mkVarMn (Just (ModuleName [ProperName C.prelude]))
224+
225+ mkGenVar :: Ident -> Expr
226+ mkGenVar = mkVarMn (Just (ModuleName [ProperName "Data", ProperName C.generic]))
227+
228+deriveEq ::
229+ forall m. (Functor m, MonadError MultipleErrors m, MonadSupply m)
230+ => ModuleName
231+ -> [Declaration]
232+ -> ProperName 'TypeName
233+ -> m [Declaration]
234+deriveEq mn ds tyConNm = do
235+ tyCon <- findTypeDecl tyConNm ds
236+ eqFun <- mkEqFunction tyCon
237+ return [ ValueDeclaration (Ident C.eq) Public [] (Right eqFun) ]
238+ where
239+ mkEqFunction :: Declaration -> m Expr
240+ mkEqFunction (DataDeclaration _ _ _ args) = do
241+ x <- freshIdent "x"
242+ y <- freshIdent "y"
243+ lamCase2 x y <$> (addCatch <$> mapM mkCtorClause args)
244+ mkEqFunction (PositionedDeclaration _ _ d) = mkEqFunction d
245+ mkEqFunction _ = internalError "mkEqFunction: expected DataDeclaration"
246+
247+ preludeConj :: Expr -> Expr -> Expr
248+ preludeConj = App . App (Var (Qualified (Just (ModuleName [ProperName C.prelude])) (Ident C.conj)))
249+
250+ preludeEq :: Expr -> Expr -> Expr
251+ preludeEq = App . App (Var (Qualified (Just (ModuleName [ProperName C.prelude])) (Ident C.eq)))
252+
253+ addCatch :: [CaseAlternative] -> [CaseAlternative]
254+ addCatch xs
255+ | length xs /= 1 = xs ++ [catchAll]
256+ | otherwise = xs -- Avoid redundant case
257+ where
258+ catchAll = CaseAlternative [NullBinder, NullBinder] (Right (BooleanLiteral False))
259+
260+ mkCtorClause :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative
261+ mkCtorClause (ctorName, tys) = do
262+ identsL <- replicateM (length tys) (freshIdent "l")
263+ identsR <- replicateM (length tys) (freshIdent "r")
264+ let tests = zipWith3 toEqTest (map (Var . Qualified Nothing) identsL) (map (Var . Qualified Nothing) identsR) tys
265+ return $ CaseAlternative [caseBinder identsL, caseBinder identsR] (Right (conjAll tests))
266+ where
267+ caseBinder idents = ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)
268+
269+ conjAll :: [Expr] -> Expr
270+ conjAll [] = BooleanLiteral True
271+ conjAll xs = foldl1 preludeConj xs
272+
273+ toEqTest :: Expr -> Expr -> Type -> Expr
274+ toEqTest l r ty | Just rec <- objectType ty =
275+ conjAll
276+ . map (\(str, typ) -> toEqTest (Accessor str l) (Accessor str r) typ)
277+ $ decomposeRec rec
278+ toEqTest l r _ = preludeEq l r
279+
280+deriveOrd ::
281+ forall m. (Functor m, MonadError MultipleErrors m, MonadSupply m)
282+ => ModuleName
283+ -> [Declaration]
284+ -> ProperName 'TypeName
285+ -> m [Declaration]
286+deriveOrd mn ds tyConNm = do
287+ tyCon <- findTypeDecl tyConNm ds
288+ compareFun <- mkCompareFunction tyCon
289+ return [ ValueDeclaration (Ident C.compare) Public [] (Right compareFun) ]
290+ where
291+ mkCompareFunction :: Declaration -> m Expr
292+ mkCompareFunction (DataDeclaration _ _ _ args) = do
293+ x <- freshIdent "x"
294+ y <- freshIdent "y"
295+ lamCase2 x y <$> (addCatch . concat <$> mapM mkCtorClauses (splitLast args))
296+ mkCompareFunction (PositionedDeclaration _ _ d) = mkCompareFunction d
297+ mkCompareFunction _ = internalError "mkCompareFunction: expected DataDeclaration"
298+
299+ splitLast :: [a] -> [(a, Bool)]
300+ splitLast [] = []
301+ splitLast [x] = [(x, True)]
302+ splitLast (x : xs) = (x, False) : splitLast xs
303+
304+ addCatch :: [CaseAlternative] -> [CaseAlternative]
305+ addCatch xs
306+ | null xs = [catchAll] -- No type constructors
307+ | otherwise = xs
308+ where
309+ catchAll = CaseAlternative [NullBinder, NullBinder] (Right (preludeCtor "EQ"))
310+
311+ preludeCtor :: String -> Expr
312+ preludeCtor = Constructor . Qualified (Just (ModuleName [ProperName C.prelude])) . ProperName
313+
314+ preludeCompare :: Expr -> Expr -> Expr
315+ preludeCompare = App . App (Var (Qualified (Just (ModuleName [ProperName C.prelude])) (Ident C.compare)))
316+
317+ mkCtorClauses :: ((ProperName 'ConstructorName, [Type]), Bool) -> m [CaseAlternative]
318+ mkCtorClauses ((ctorName, tys), isLast) = do
319+ identsL <- replicateM (length tys) (freshIdent "l")
320+ identsR <- replicateM (length tys) (freshIdent "r")
321+ let tests = zipWith3 toOrdering (map (Var . Qualified Nothing) identsL) (map (Var . Qualified Nothing) identsR) tys
322+ extras | not isLast = [ CaseAlternative [ ConstructorBinder (Qualified (Just mn) ctorName) (replicate (length tys) NullBinder)
323+ , NullBinder
324+ ]
325+ (Right (preludeCtor "LT"))
326+ , CaseAlternative [ NullBinder
327+ , ConstructorBinder (Qualified (Just mn) ctorName) (replicate (length tys) NullBinder)
328+ ]
329+ (Right (preludeCtor "GT"))
330+ ]
331+ | otherwise = []
332+ return $ CaseAlternative [ caseBinder identsL
333+ , caseBinder identsR
334+ ]
335+ (Right (appendAll tests))
336+ : extras
337+
338+ where
339+ caseBinder idents = ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)
340+
341+ appendAll :: [Expr] -> Expr
342+ appendAll [] = preludeCtor "EQ"
343+ appendAll [x] = x
344+ appendAll (x : xs) = Case [x] [ CaseAlternative [ ConstructorBinder (Qualified (Just (ModuleName [ProperName C.prelude])) (ProperName "LT")) [] ]
345+ (Right (preludeCtor "LT"))
346+ , CaseAlternative [ ConstructorBinder (Qualified (Just (ModuleName [ProperName C.prelude])) (ProperName "GT")) [] ]
347+ (Right (preludeCtor "GT"))
348+ , CaseAlternative [ NullBinder ]
349+ (Right (appendAll xs))
350+ ]
351+
352+ toOrdering :: Expr -> Expr -> Type -> Expr
353+ toOrdering l r ty | Just rec <- objectType ty =
354+ appendAll
355+ . map (\(str, typ) -> toOrdering (Accessor str l) (Accessor str r) typ)
356+ $ decomposeRec rec
357+ toOrdering l r _ = preludeCompare l r
92
358
93findTypeDecl
359findTypeDecl
94 :: (Functor m, MonadError MultipleErrors m)
360 :: (Functor m, MonadError MultipleErrors m)
@@ -102,148 +368,29 @@ findTypeDecl tyConNm = maybe (throwError . errorMessage $ CannotFindDerivingType
102 isTypeDecl (PositionedDeclaration _ _ d) = isTypeDecl d
368 isTypeDecl (PositionedDeclaration _ _ d) = isTypeDecl d
103 isTypeDecl _ = False
369 isTypeDecl _ = False
104
370
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−
222−lam :: String -> Expr -> Expr
371+lam :: Ident -> Expr -> Expr
223−lam s = Abs (Left (Ident s))
372+lam = Abs . Left
224
373
225lamNull :: Expr -> Expr
374lamNull :: Expr -> Expr
226−lamNull = lam "$q"
375+lamNull = lam (Ident "$q") -- TODO: use GenIdent
227
376
228−lamCase :: String -> [CaseAlternative] -> Expr
377+lamCase :: Ident -> [CaseAlternative] -> Expr
229lamCase s = lam s . Case [mkVar s]
378lamCase s = lam s . Case [mkVar s]
230
379
231−liftApplicative :: Expr -> [Expr] -> Expr
380+lamCase2 :: Ident -> Ident -> [CaseAlternative] -> Expr
232−liftApplicative = foldl' (\x e -> App (App (mkPrelVar "apply") x) e)
381+lamCase2 s t = lam s . lam t . Case [mkVar s, mkVar t]
233
382
234−mkVarMn :: Maybe ModuleName -> String -> Expr
383+mkVarMn :: Maybe ModuleName -> Ident -> Expr
235−mkVarMn mn s = Var (Qualified mn (Ident s))
384+mkVarMn mn = Var . Qualified mn
236
385
237−mkVar :: String -> Expr
386+mkVar :: Ident -> Expr
238mkVar = mkVarMn Nothing
387mkVar = mkVarMn Nothing
239
388
240−mkPrelVar :: String -> Expr
389+objectType :: Type -> Maybe Type
241−mkPrelVar = mkVarMn (Just (ModuleName [ProperName C.prelude]))
390+objectType (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Object"))) rec) = Just rec
242−
391+objectType _ = Nothing
243−mkGenVar :: String -> Expr
244−mkGenVar = mkVarMn (Just (ModuleName [ProperName "Data", ProperName C.generic]))
245
392
246decomposeRec :: Type -> [(String, Type)]
393decomposeRec :: Type -> [(String, Type)]
247decomposeRec = sortBy (comparing fst) . go
394decomposeRec = sortBy (comparing fst) . go
248− where go (RCons str typ typs) = (str, typ) : decomposeRec typs
395+ where go (RCons str typ typs) = (str, typ) : decomposeRec typs
249− go _ = []
396+ go _ = []