380de16 · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

on golang help sign in

Add naive functor deriving (#2515)

380de16Liam Goodacre10 years ago

examples/passing/DerivingFunctor.pursnew file+24

compare with golang

unifiedsplit

@@ -0,0 +1,24 @@

1+module Main where

3+import Prelude

4+import Control.Monad.Eff.Console (log)

5+import Test.Assert

7+data M f a

8+ = M0 a (Array a)

9+ | M1 Int

10+ | M2 (f a)

11+ | M3 { foo :: Int, bar :: a, baz :: f a }

12+

13+derive instance eqM :: (Eq (f a), Eq a) => Eq (M f a)

14+

15+derive instance functorM :: Functor f => Functor (M f)

16+

17+type MA = M Array

18+

19+main = do

20+ assert $ map show (M0 0 [1, 2] :: MA Int) == M0 "0" ["1", "2"]

21+ assert $ map show (M1 0 :: MA Int) == M1 0

22+ assert $ map show (M2 [0, 1] :: MA Int) == M2 ["0", "1"]

23+ assert $ map show (M3 {foo: 0, bar: 1, baz: [2, 3]} :: MA Int) == M3 {foo: 0, bar: "1", baz: ["2", "3"]}

24+ log "Done"

src/Language/PureScript/Constants.hs+3

@@ -139,6 +139,9 @@ compose = "compose"

139composeFlipped :: Text

140composeFlipped = "composeFlipped"

141

142+map :: Text

143+map = "map"

144+

142-- Functions

145-- Functions

143

146

144negate :: Text

147negate :: Text

src/Language/PureScript/Sugar/TypeClasses/Deriving.hs+79−2

@@ -6,7 +6,7 @@ module Language.PureScript.Sugar.TypeClasses.Deriving (deriveInstances) where

6import Prelude.Compat

8import Control.Arrow (second)

9−import Control.Monad (replicateM)

9+import Control.Monad (replicateM, zipWithM)

10import Control.Monad.Error.Class (MonadError(..))

11import Control.Monad.Supply.Class (MonadSupply)

@@ -19,9 +19,10 @@ import Language.PureScript.AST

19import Language.PureScript.Crash

20import Language.PureScript.Environment

21import Language.PureScript.Errors

22+import Language.PureScript.Kinds

22import Language.PureScript.Names

23import Language.PureScript.Names

23−import Language.PureScript.Types

24import Language.PureScript.TypeChecker (checkNewtype)

25+import Language.PureScript.Types

25import qualified Language.PureScript.Constants as C

26import qualified Language.PureScript.Constants as C

27-- | Elaborates deriving instance declarations by code generation.

28-- | Elaborates deriving instance declarations by code generation.

@@ -44,14 +45,22 @@ deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@[ty] Derived

44 , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor ty

45 , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor ty

45 , mn == fromMaybe mn mn'

46 , mn == fromMaybe mn mn'

46 = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveGeneric mn ds tyCon args

47 = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveGeneric mn ds tyCon args

48+

47 | className == Qualified (Just dataEq) (ProperName "Eq")

49 | className == Qualified (Just dataEq) (ProperName "Eq")

48 , Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty

50 , Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty

49 , mn == fromMaybe mn mn'

51 , mn == fromMaybe mn mn'

50 = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveEq mn ds tyCon

52 = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveEq mn ds tyCon

53+

51 | className == Qualified (Just dataOrd) (ProperName "Ord")

54 | className == Qualified (Just dataOrd) (ProperName "Ord")

52 , Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty

55 , Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty

53 , mn == fromMaybe mn mn'

56 , mn == fromMaybe mn mn'

54 = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveOrd mn ds tyCon

57 = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveOrd mn ds tyCon

58+

59+ | className == Qualified (Just dataFunctor) (ProperName "Functor")

60+ , Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty

61+ , mn == fromMaybe mn mn'

62+ = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveFunctor mn ds tyCon

63+

55deriveInstance mn ds (TypeInstanceDeclaration nm deps className [wrappedTy, unwrappedTy] DerivedInstance)

64deriveInstance mn ds (TypeInstanceDeclaration nm deps className [wrappedTy, unwrappedTy] DerivedInstance)

56 | className == Qualified (Just dataNewtype) (ProperName "Newtype")

65 | className == Qualified (Just dataNewtype) (ProperName "Newtype")

57 , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor wrappedTy

66 , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor wrappedTy

@@ -143,6 +152,9 @@ dataOrd = ModuleName [ ProperName "Data", ProperName "Ord" ]

143dataNewtype :: ModuleName

152dataNewtype :: ModuleName

144dataNewtype = ModuleName [ ProperName "Data", ProperName "Newtype" ]

153dataNewtype = ModuleName [ ProperName "Data", ProperName "Newtype" ]

145

154

155+dataFunctor :: ModuleName

156+dataFunctor = ModuleName [ ProperName "Data", ProperName "Functor" ]

157+

146deriveGeneric

158deriveGeneric

147 :: forall m. (MonadError MultipleErrors m, MonadSupply m)

159 :: forall m. (MonadError MultipleErrors m, MonadSupply m)

148 => ModuleName

160 => ModuleName

@@ -702,3 +714,68 @@ decomposeRec :: Type -> [(Text, Type)]

702decomposeRec = sortBy (comparing fst) . go

714decomposeRec = sortBy (comparing fst) . go

703 where go (RCons str typ typs) = (str, typ) : decomposeRec typs

715 where go (RCons str typ typs) = (str, typ) : decomposeRec typs

704 go _ = []

716 go _ = []

717+

718+deriveFunctor

719+ :: forall m

720+ . (MonadError MultipleErrors m, MonadSupply m)

721+ => ModuleName

722+ -> [Declaration]

723+ -> ProperName 'TypeName

724+ -> m [Declaration]

725+deriveFunctor mn ds tyConNm = do

726+ tyCon <- findTypeDecl tyConNm ds

727+ mapFun <- mkMapFunction tyCon

728+ return [ ValueDeclaration (Ident C.map) Public [] (Right mapFun) ]

729+ where

730+ mkMapFunction :: Declaration -> m Expr

731+ mkMapFunction (DataDeclaration _ _ tys ctors) = case reverse tys of

732+ [] -> throwError . errorMessage $ KindsDoNotUnify (FunKind kindType kindType) kindType

733+ ((iTy, _) : _) -> do

734+ f <- freshIdent "f"

735+ m <- freshIdent "m"

736+ lam f . lamCase m <$> mapM (mkCtorClause iTy f) ctors

737+ mkMapFunction (PositionedDeclaration _ _ d) = mkMapFunction d

738+ mkMapFunction _ = internalError "mkMapFunction: expected DataDeclaration"

739+

740+ mkCtorClause :: Text -> Ident -> (ProperName 'ConstructorName, [Type]) -> m CaseAlternative

741+ mkCtorClause iTyName f (ctorName, ctorTys) = do

742+ idents <- replicateM (length ctorTys) (freshIdent "v")

743+ args <- zipWithM transformArg idents ctorTys

744+ let ctor = Constructor (Qualified (Just mn) ctorName)

745+ rebuilt = foldl App ctor args

746+ caseBinder = ConstructorBinder (Qualified (Just mn) ctorName) (VarBinder <$> idents)

747+ return $ CaseAlternative [caseBinder] (Right rebuilt)

748+ where

749+ fVar = mkVar f

750+ mapVar = mkVarMn (Just dataFunctor) (Ident C.map)

751+

752+ -- TODO: deal with type synonyms, ala https://github.com/purescript/purescript/pull/2516

753+ transformArg :: Ident -> Type -> m Expr

754+ transformArg ident = fmap (foldr App (mkVar ident)) . goType where

755+

756+ goType :: Type -> m (Maybe Expr)

757+ -- argument matches the index type

758+ goType (TypeVar t) | t == iTyName = return (Just fVar)

759+

760+ -- records

761+ goType recTy | Just row <- objectType recTy =

762+ traverse buildUpdate (decomposeRec row) >>= (traverse buildRecord . justUpdates)

763+ where

764+ justUpdates :: [Maybe (Text, Expr)] -> Maybe [(Text, Expr)]

765+ justUpdates = foldMap (fmap return)

766+

767+ buildUpdate :: (Text, Type) -> m (Maybe (Text, Expr))

768+ buildUpdate (lbl, ty) = do upd <- goType ty

769+ return ((lbl,) <$> upd)

770+

771+ buildRecord :: [(Text, Expr)] -> m Expr

772+ buildRecord updates = do arg <- freshIdent "o"

773+ let argVar = mkVar arg

774+ mkAssignment (l, x) = (l, App x (Accessor l argVar))

775+ return (lam arg (ObjectUpdate argVar (mkAssignment <$> updates)))

776+

777+ -- under a `* -> *`, just assume functor for now

778+ goType (TypeApp _ t) = fmap (App mapVar) <$> goType t

779+

780+ -- otherwise do nothing - will fail type checking if type does actually contain index

781+ goType _ = return Nothing