git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
More efficient derived instances for Ord
14de647Phil Freeman
src/Language/PureScript/Sugar/TypeClasses/Deriving.hs+50−33
compare with golang
unifiedsplit
@@ -99,7 +99,9 @@ deriveGeneric mn ds tyConNm dargs = do
99 ]
99 ]
100 where
100 where
101 mkSpineFunction :: Declaration -> m Expr
101 mkSpineFunction :: Declaration -> m Expr
102− mkSpineFunction (DataDeclaration _ _ _ args) = lamCase "$x" <$> mapM mkCtorClause args
102+ mkSpineFunction (DataDeclaration _ _ _ args) = do
103+ x <- freshIdent'
104+ lamCase x <$> mapM mkCtorClause args
103 where
105 where
104 prodConstructor :: Expr -> Expr
106 prodConstructor :: Expr -> Expr
105 prodConstructor = App (Constructor (Qualified (Just dataGeneric) (ProperName "SProd")))
107 prodConstructor = App (Constructor (Qualified (Just dataGeneric) (ProperName "SProd")))
@@ -122,7 +124,7 @@ deriveGeneric mn ds tyConNm dargs = do
122 lamNull . recordConstructor . ArrayLiteral .
124 lamNull . recordConstructor . ArrayLiteral .
123 map (\(str,typ) -> ObjectLiteral [("recLabel", StringLiteral str), ("recValue", toSpineFun (Accessor str i) typ)])
125 map (\(str,typ) -> ObjectLiteral [("recLabel", StringLiteral str), ("recValue", toSpineFun (Accessor str i) typ)])
124 $ decomposeRec rec
126 $ decomposeRec rec
125− toSpineFun i _ = lamNull $ App (mkGenVar C.toSpine) i
127+ toSpineFun i _ = lamNull $ App (mkGenVar (Ident C.toSpine)) i
126 mkSpineFunction (PositionedDeclaration _ _ d) = mkSpineFunction d
128 mkSpineFunction (PositionedDeclaration _ _ d) = mkSpineFunction d
127 mkSpineFunction _ = internalError "mkSpineFunction: expected DataDeclaration"
129 mkSpineFunction _ = internalError "mkSpineFunction: expected DataDeclaration"
128
130
@@ -154,14 +156,16 @@ deriveGeneric mn ds tyConNm dargs = do
154 ]
156 ]
155 | (str, typ) <- decomposeRec rec
157 | (str, typ) <- decomposeRec rec
156 ]
158 ]
157− mkProductSignature typ = lamNull $ App (mkGenVar C.toSignature)
159+ mkProductSignature typ = lamNull $ App (mkGenVar (Ident C.toSignature))
158− (TypedValue False (mkGenVar "anyProxy") (proxy typ))
160+ (TypedValue False (mkGenVar (Ident "anyProxy")) (proxy typ))
159 instantiate = replaceAllTypeVars (zipWith (\(arg, _) ty -> (arg, ty)) tyArgs classArgs)
161 instantiate = replaceAllTypeVars (zipWith (\(arg, _) ty -> (arg, ty)) tyArgs classArgs)
160 mkSignatureFunction (PositionedDeclaration _ _ d) classArgs = mkSignatureFunction d classArgs
162 mkSignatureFunction (PositionedDeclaration _ _ d) classArgs = mkSignatureFunction d classArgs
161 mkSignatureFunction _ _ = internalError "mkSignatureFunction: expected DataDeclaration"
163 mkSignatureFunction _ _ = internalError "mkSignatureFunction: expected DataDeclaration"
162
164
163 mkFromSpineFunction :: Declaration -> m Expr
165 mkFromSpineFunction :: Declaration -> m Expr
164− mkFromSpineFunction (DataDeclaration _ _ _ args) = lamCase "$x" <$> (addCatch <$> mapM mkAlternative args)
166+ mkFromSpineFunction (DataDeclaration _ _ _ args) = do
167+ x <- freshIdent'
168+ lamCase x <$> (addCatch <$> mapM mkAlternative args)
165 where
169 where
166 mkJust :: Expr -> Expr
170 mkJust :: Expr -> Expr
167 mkJust = App (Constructor (Qualified (Just dataMaybe) (ProperName "Just")))
171 mkJust = App (Constructor (Qualified (Just dataMaybe) (ProperName "Just")))
@@ -188,36 +192,37 @@ deriveGeneric mn ds tyConNm dargs = do
188 where
192 where
189 catchAll = CaseAlternative [NullBinder] (Right mkNothing)
193 catchAll = CaseAlternative [NullBinder] (Right mkNothing)
190
194
195+ fromSpineFun :: Expr -> Type -> Expr
191 fromSpineFun e r
196 fromSpineFun e r
192 | Just rec <- objectType r
197 | Just rec <- objectType r
193− = App (lamCase "r" [ mkRecCase (decomposeRec rec)
198+ = App (lamCase (Ident "r") [ mkRecCase (decomposeRec rec)
194− , CaseAlternative [NullBinder] (Right mkNothing)
199+ , CaseAlternative [NullBinder] (Right mkNothing)
195− ])
200+ ])
196− (App e (mkPrelVar "unit"))
201+ (App e (mkPrelVar (Ident "unit")))
197−
198− fromSpineFun e _ = App (mkGenVar C.fromSpine) (App e (mkPrelVar "unit"))
202+ fromSpineFun e _ = App (mkGenVar (Ident C.fromSpine)) (App e (mkPrelVar (Ident "unit")))
199
203
204+ mkRecCase :: [(String, Type)] -> CaseAlternative
200 mkRecCase rs = CaseAlternative [ recordBinder [ ArrayBinder (map (VarBinder . Ident . fst) rs)
205 mkRecCase rs = CaseAlternative [ recordBinder [ ArrayBinder (map (VarBinder . Ident . fst) rs)
201 ]
206 ]
202 ]
207 ]
203 . Right
208 . Right
204− $ liftApplicative (mkRecFun rs) (map (\(x, y) -> fromSpineFun (Accessor "recValue" (mkVar x)) y) rs)
209+ $ liftApplicative (mkRecFun rs) (map (\(x, y) -> fromSpineFun (Accessor "recValue" (mkVar (Ident x))) y) rs)
205
210
206 mkRecFun :: [(String, Type)] -> Expr
211 mkRecFun :: [(String, Type)] -> Expr
207− mkRecFun xs = mkJust $ foldr lam recLiteral (map fst xs)
212+ mkRecFun xs = mkJust $ foldr lam recLiteral (map (Ident . fst) xs)
208− where recLiteral = ObjectLiteral $ map (\(s,_) -> (s,mkVar s)) xs
213+ where recLiteral = ObjectLiteral $ map (\(s,_) -> (s, mkVar (Ident s))) xs
209 mkFromSpineFunction (PositionedDeclaration _ _ d) = mkFromSpineFunction d
214 mkFromSpineFunction (PositionedDeclaration _ _ d) = mkFromSpineFunction d
210 mkFromSpineFunction _ = internalError "mkFromSpineFunction: expected DataDeclaration"
215 mkFromSpineFunction _ = internalError "mkFromSpineFunction: expected DataDeclaration"
211
216
212 -- Helpers
217 -- Helpers
213
218
214 liftApplicative :: Expr -> [Expr] -> Expr
219 liftApplicative :: Expr -> [Expr] -> Expr
215− liftApplicative = foldl' (\x e -> App (App (mkPrelVar "apply") x) e)
220+ liftApplicative = foldl' (\x e -> App (App (mkPrelVar (Ident "apply")) x) e)
216
221
217− mkPrelVar :: String -> Expr
222+ mkPrelVar :: Ident -> Expr
218 mkPrelVar = mkVarMn (Just (ModuleName [ProperName C.prelude]))
223 mkPrelVar = mkVarMn (Just (ModuleName [ProperName C.prelude]))
219
224
220− mkGenVar :: String -> Expr
225+ mkGenVar :: Ident -> Expr
221 mkGenVar = mkVarMn (Just (ModuleName [ProperName "Data", ProperName C.generic]))
226 mkGenVar = mkVarMn (Just (ModuleName [ProperName "Data", ProperName C.generic]))
222
227
223deriveEq ::
228deriveEq ::
@@ -232,7 +237,10 @@ deriveEq mn ds tyConNm = do
232 return [ ValueDeclaration (Ident C.eq) Public [] (Right eqFun) ]
237 return [ ValueDeclaration (Ident C.eq) Public [] (Right eqFun) ]
233 where
238 where
234 mkEqFunction :: Declaration -> m Expr
239 mkEqFunction :: Declaration -> m Expr
240+ mkEqFunction (DataDeclaration _ _ _ args) = do
241+ x <- freshIdent "x"
242+ y <- freshIdent "y"
235− mkEqFunction (DataDeclaration _ _ _ args) = lamCase2 "$x" "$y" <$> (addCatch <$> mapM mkCtorClause args)
243+ lamCase2 x y <$> (addCatch <$> mapM mkCtorClause args)
236 mkEqFunction (PositionedDeclaration _ _ d) = mkEqFunction d
244 mkEqFunction (PositionedDeclaration _ _ d) = mkEqFunction d
237 mkEqFunction _ = internalError "mkEqFunction: expected DataDeclaration"
245 mkEqFunction _ = internalError "mkEqFunction: expected DataDeclaration"
238
246
@@ -249,7 +257,8 @@ deriveEq mn ds tyConNm = do
249
257
250 mkCtorClause :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative
258 mkCtorClause :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative
251 mkCtorClause (ctorName, tys) = do
259 mkCtorClause (ctorName, tys) = do
260+ identsL <- replicateM (length tys) (freshIdent "l")
252− [identsL, identsR] <- replicateM 2 (replicateM (length tys) freshIdent')
261+ identsR <- replicateM (length tys) (freshIdent "r")
253 let tests = zipWith3 toEqTest (map (Var . Qualified Nothing) identsL) (map (Var . Qualified Nothing) identsR) tys
262 let tests = zipWith3 toEqTest (map (Var . Qualified Nothing) identsL) (map (Var . Qualified Nothing) identsR) tys
254 return $ CaseAlternative [caseBinder identsL, caseBinder identsR] (Right (conjAll tests))
263 return $ CaseAlternative [caseBinder identsL, caseBinder identsR] (Right (conjAll tests))
255 where
264 where
@@ -278,22 +287,23 @@ deriveOrd mn ds tyConNm = do
278 return [ ValueDeclaration (Ident C.compare) Public [] (Right compareFun) ]
287 return [ ValueDeclaration (Ident C.compare) Public [] (Right compareFun) ]
279 where
288 where
280 mkCompareFunction :: Declaration -> m Expr
289 mkCompareFunction :: Declaration -> m Expr
281− mkCompareFunction (DataDeclaration _ _ _ args) = lamCase2 "$x" "$y" <$> (concat <$> mapM mkCtorClauses args)
290+ mkCompareFunction (DataDeclaration _ _ _ args) = do
291+ x <- freshIdent "x"
292+ y <- freshIdent "y"
293+ lamCase2 x y <$> (concat <$> mapM mkCtorClauses args)
282 mkCompareFunction (PositionedDeclaration _ _ d) = mkCompareFunction d
294 mkCompareFunction (PositionedDeclaration _ _ d) = mkCompareFunction d
283 mkCompareFunction _ = internalError "mkCompareFunction: expected DataDeclaration"
295 mkCompareFunction _ = internalError "mkCompareFunction: expected DataDeclaration"
284
296
285 preludeCtor :: String -> Expr
297 preludeCtor :: String -> Expr
286 preludeCtor = Constructor . Qualified (Just (ModuleName [ProperName C.prelude])) . ProperName
298 preludeCtor = Constructor . Qualified (Just (ModuleName [ProperName C.prelude])) . ProperName
287
299
288− preludeAppend :: Expr -> Expr -> Expr
289− preludeAppend = App . App (Var (Qualified (Just (ModuleName [ProperName C.prelude])) (Ident C.append)))
290−
291 preludeCompare :: Expr -> Expr -> Expr
300 preludeCompare :: Expr -> Expr -> Expr
292 preludeCompare = App . App (Var (Qualified (Just (ModuleName [ProperName C.prelude])) (Ident C.compare)))
301 preludeCompare = App . App (Var (Qualified (Just (ModuleName [ProperName C.prelude])) (Ident C.compare)))
293
302
294 mkCtorClauses :: (ProperName 'ConstructorName, [Type]) -> m [CaseAlternative]
303 mkCtorClauses :: (ProperName 'ConstructorName, [Type]) -> m [CaseAlternative]
295 mkCtorClauses (ctorName, tys) = do
304 mkCtorClauses (ctorName, tys) = do
305+ identsL <- replicateM (length tys) (freshIdent "l")
296− [identsL, identsR] <- replicateM 2 (replicateM (length tys) freshIdent')
306+ identsR <- replicateM (length tys) (freshIdent "r")
297 let tests = zipWith3 toOrdering (map (Var . Qualified Nothing) identsL) (map (Var . Qualified Nothing) identsR) tys
307 let tests = zipWith3 toOrdering (map (Var . Qualified Nothing) identsL) (map (Var . Qualified Nothing) identsR) tys
298 return [ CaseAlternative [ caseBinder identsL
308 return [ CaseAlternative [ caseBinder identsL
299 , caseBinder identsR
309 , caseBinder identsR
@@ -313,7 +323,14 @@ deriveOrd mn ds tyConNm = do
313
323
314 appendAll :: [Expr] -> Expr
324 appendAll :: [Expr] -> Expr
315 appendAll [] = preludeCtor "EQ"
325 appendAll [] = preludeCtor "EQ"
316− appendAll xs = foldl1 preludeAppend xs
326+ appendAll [x] = x
327+ appendAll (x : xs) = Case [x] [ CaseAlternative [ ConstructorBinder (Qualified (Just (ModuleName [ProperName C.prelude])) (ProperName "LT")) [] ]
328+ (Right (preludeCtor "LT"))
329+ , CaseAlternative [ ConstructorBinder (Qualified (Just (ModuleName [ProperName C.prelude])) (ProperName "GT")) [] ]
330+ (Right (preludeCtor "GT"))
331+ , CaseAlternative [ NullBinder ]
332+ (Right (appendAll xs))
333+ ]
317
334
318 toOrdering :: Expr -> Expr -> Type -> Expr
335 toOrdering :: Expr -> Expr -> Type -> Expr
319 toOrdering l r ty | Just rec <- objectType ty =
336 toOrdering l r ty | Just rec <- objectType ty =
@@ -334,22 +351,22 @@ findTypeDecl tyConNm = maybe (throwError . errorMessage $ CannotFindDerivingType
334 isTypeDecl (PositionedDeclaration _ _ d) = isTypeDecl d
351 isTypeDecl (PositionedDeclaration _ _ d) = isTypeDecl d
335 isTypeDecl _ = False
352 isTypeDecl _ = False
336
353
337−lam :: String -> Expr -> Expr
354+lam :: Ident -> Expr -> Expr
338−lam s = Abs (Left (Ident s))
355+lam = Abs . Left
339
356
340lamNull :: Expr -> Expr
357lamNull :: Expr -> Expr
341−lamNull = lam "$q"
358+lamNull = lam (Ident "$q") -- TODO: use GenIdent
342
359
343−lamCase :: String -> [CaseAlternative] -> Expr
360+lamCase :: Ident -> [CaseAlternative] -> Expr
344lamCase s = lam s . Case [mkVar s]
361lamCase s = lam s . Case [mkVar s]
345
362
346−lamCase2 :: String -> String -> [CaseAlternative] -> Expr
363+lamCase2 :: Ident -> Ident -> [CaseAlternative] -> Expr
347lamCase2 s t = lam s . lam t . Case [mkVar s, mkVar t]
364lamCase2 s t = lam s . lam t . Case [mkVar s, mkVar t]
348
365
349−mkVarMn :: Maybe ModuleName -> String -> Expr
366+mkVarMn :: Maybe ModuleName -> Ident -> Expr
350−mkVarMn mn s = Var (Qualified mn (Ident s))
367+mkVarMn mn = Var . Qualified mn
351
368
352−mkVar :: String -> Expr
369+mkVar :: Ident -> Expr
353mkVar = mkVarMn Nothing
370mkVar = mkVarMn Nothing
354
371
355objectType :: Type -> Maybe Type
372objectType :: Type -> Maybe Type