git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Ord deriving
d5d0adfPhil Freeman
src/Language/PureScript/Constants.hs+3
compare with golang
unifiedsplit
@@ -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+61−4
@@ -50,10 +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" ])) eq
53+ | className == Qualified (Just (ModuleName [ ProperName "Prelude" ])) (ProperName "Eq")
54 , Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty
54 , Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty
55 , mn == fromMaybe mn mn'
55 , mn == fromMaybe mn mn'
56 = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveEq mn ds tyCon
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
57deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance)
61deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance)
58 = throwError . errorMessage $ CannotDerive className tys
62 = throwError . errorMessage $ CannotDerive className tys
59deriveInstance 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
@@ -77,9 +81,6 @@ dataMaybe = ModuleName [ ProperName "Data", ProperName "Maybe" ]
77typesProxy :: ModuleName
81typesProxy :: ModuleName
78typesProxy = ModuleName [ ProperName "Type", ProperName "Proxy" ]
82typesProxy = ModuleName [ ProperName "Type", ProperName "Proxy" ]
79
83
80−eq :: ProperName 'ClassName
81−eq = ProperName "Eq"
82−
83deriveGeneric
84deriveGeneric
84 :: forall m. (Functor m, MonadError MultipleErrors m, MonadSupply m)
85 :: forall m. (Functor m, MonadError MultipleErrors m, MonadSupply m)
85 => ModuleName
86 => ModuleName
@@ -265,6 +266,62 @@ deriveEq mn ds tyConNm = do
265 $ decomposeRec rec
266 $ decomposeRec rec
266 toEqTest l r _ = preludeEq l r
267 toEqTest l r _ = preludeEq l r
267
268
269+deriveOrd ::
270+ forall m. (Functor m, MonadError MultipleErrors m, MonadSupply m)
271+ => ModuleName
272+ -> [Declaration]
273+ -> ProperName 'TypeName
274+ -> m [Declaration]
275+deriveOrd mn ds tyConNm = do
276+ tyCon <- findTypeDecl tyConNm ds
277+ compareFun <- mkCompareFunction tyCon
278+ return [ ValueDeclaration (Ident C.compare) Public [] (Right compareFun) ]
279+ where
280+ mkCompareFunction :: Declaration -> m Expr
281+ mkCompareFunction (DataDeclaration _ _ _ args) = lamCase2 "$x" "$y" <$> (concat <$> mapM mkCtorClauses args)
282+ mkCompareFunction (PositionedDeclaration _ _ d) = mkCompareFunction d
283+ mkCompareFunction _ = internalError "mkCompareFunction: expected DataDeclaration"
284+
285+ preludeCtor :: String -> Expr
286+ preludeCtor = Constructor . Qualified (Just (ModuleName [ProperName C.prelude])) . ProperName
287+
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
292+ preludeCompare = App . App (Var (Qualified (Just (ModuleName [ProperName C.prelude])) (Ident C.compare)))
293+
294+ mkCtorClauses :: (ProperName 'ConstructorName, [Type]) -> m [CaseAlternative]
295+ mkCtorClauses (ctorName, tys) = do
296+ [identsL, identsR] <- replicateM 2 (replicateM (length tys) freshIdent')
297+ let tests = zipWith3 toOrdering (map (Var . Qualified Nothing) identsL) (map (Var . Qualified Nothing) identsR) tys
298+ return [ CaseAlternative [ caseBinder identsL
299+ , caseBinder identsR
300+ ]
301+ (Right (appendAll tests))
302+ , CaseAlternative [ ConstructorBinder (Qualified (Just mn) ctorName) (replicate (length tys) NullBinder)
303+ , NullBinder
304+ ]
305+ (Right (preludeCtor "LT"))
306+ , CaseAlternative [ NullBinder
307+ , ConstructorBinder (Qualified (Just mn) ctorName) (replicate (length tys) NullBinder)
308+ ]
309+ (Right (preludeCtor "GT"))
310+ ]
311+ where
312+ caseBinder idents = ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)
313+
314+ appendAll :: [Expr] -> Expr
315+ appendAll [] = preludeCtor "EQ"
316+ appendAll xs = foldl1 preludeAppend xs
317+
318+ toOrdering :: Expr -> Expr -> Type -> Expr
319+ toOrdering l r ty | Just rec <- objectType ty =
320+ appendAll
321+ . map (\(str, typ) -> toOrdering (Accessor str l) (Accessor str r) typ)
322+ $ decomposeRec rec
323+ toOrdering l r _ = preludeCompare l r
324+
268findTypeDecl
325findTypeDecl
269 :: (Functor m, MonadError MultipleErrors m)
326 :: (Functor m, MonadError MultipleErrors m)
270 => ProperName 'TypeName
327 => ProperName 'TypeName