git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Add naive functor deriving (#2515)

* Add naive functor deriving * Add support for records in functor deriving

commit380de1662b35eb8c23343afd994dba95348530a0 authorLiam Goodacre <goodacre.liam@gmail.com> dateSat 31 Dec 2016, 21:50 (10 years ago) parent751018b
3 files changed+106−2
compare with golang
unifiedsplit
examples/passing/DerivingFunctor.purs+24 src/Language/PureScript/Constants.hs+3 src/Language/PureScript/Sugar/TypeClasses/Deriving.hs+79−2
examples/passing/DerivingFunctor.pursnew file+24
@@ -0,0 +1,24 @@
1+module Main where
2+
3+import Prelude
4+import Control.Monad.Eff.Console (log)
5+import Test.Assert
6+
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"
139139composeFlipped :: Text
140140composeFlipped = "composeFlipped"
141141
142+map :: Text
143+map = "map"
144+
142145-- Functions
143146
144147negate :: Text
src/Language/PureScript/Sugar/TypeClasses/Deriving.hs+79−2
@@ -6,7 +6,7 @@ module Language.PureScript.Sugar.TypeClasses.Deriving (deriveInstances) where
66import Prelude.Compat
77
88import Control.Arrow (second)
9−import Control.Monad (replicateM)
9+import Control.Monad (replicateM, zipWithM)
1010import Control.Monad.Error.Class (MonadError(..))
1111import Control.Monad.Supply.Class (MonadSupply)
1212
@@ -19,9 +19,10 @@ import Language.PureScript.AST
1919import Language.PureScript.Crash
2020import Language.PureScript.Environment
2121import Language.PureScript.Errors
22+import Language.PureScript.Kinds
2223import Language.PureScript.Names
23−import Language.PureScript.Types
2424import Language.PureScript.TypeChecker (checkNewtype)
25+import Language.PureScript.Types
2526import qualified Language.PureScript.Constants as C
2627
2728-- | Elaborates deriving instance declarations by code generation.
@@ -44,14 +45,22 @@ deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@[ty] Derived
4445 , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor ty
4546 , mn == fromMaybe mn mn'
4647 = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveGeneric mn ds tyCon args
48+
4749 | className == Qualified (Just dataEq) (ProperName "Eq")
4850 , Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty
4951 , mn == fromMaybe mn mn'
5052 = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveEq mn ds tyCon
53+
5154 | className == Qualified (Just dataOrd) (ProperName "Ord")
5255 , Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty
5356 , mn == fromMaybe mn mn'
5457 = 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+
5564deriveInstance mn ds (TypeInstanceDeclaration nm deps className [wrappedTy, unwrappedTy] DerivedInstance)
5665 | className == Qualified (Just dataNewtype) (ProperName "Newtype")
5766 , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor wrappedTy
@@ -143,6 +152,9 @@ dataOrd = ModuleName [ ProperName "Data", ProperName "Ord" ]
143152dataNewtype :: ModuleName
144153dataNewtype = ModuleName [ ProperName "Data", ProperName "Newtype" ]
145154
155+dataFunctor :: ModuleName
156+dataFunctor = ModuleName [ ProperName "Data", ProperName "Functor" ]
157+
146158deriveGeneric
147159 :: forall m. (MonadError MultipleErrors m, MonadSupply m)
148160 => ModuleName
@@ -702,3 +714,68 @@ decomposeRec :: Type -> [(Text, Type)]
702714decomposeRec = sortBy (comparing fst) . go
703715 where go (RCons str typ typs) = (str, typ) : decomposeRec typs
704716 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