git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Derive instances when data types use type synonyms (#2516)
cd535c1Phil Freeman
examples/passing/DeriveNewtype.purs+3−1
compare with golang
unifiedsplit
@@ -4,7 +4,9 @@ import Control.Monad.Eff.Console (log)
4
4
5import Data.Newtype
5import Data.Newtype
6
6
7+type MyString = String
8+
7−newtype Test = Test String
9+newtype Test = Test MyString
8
10
9derive instance newtypeTest :: Newtype Test _
11derive instance newtypeTest :: Newtype Test _
10
12
examples/passing/DeriveWithNestedSynonyms.pursnew file+29
@@ -0,0 +1,29 @@
1+module Main where
2+
3+import Prelude
4+import Control.Monad.Eff.Console (log)
5+
6+type L = {}
7+data X = X L
8+derive instance eqX :: Eq X
9+
10+type M = {}
11+data Y = Y {foo :: M}
12+derive instance eqY :: Eq Y
13+
14+type N = {}
15+data Z = Z N
16+derive instance eqZ :: Eq Z
17+
18+type Foo = String
19+
20+type Bar = { foo :: Foo }
21+
22+type Baz = { baz :: Bar }
23+
24+newtype T = T Baz
25+
26+derive instance eqT :: Eq T
27+derive instance ordT :: Ord T
28+
29+main = log "Done"
examples/passing/Deriving.purs+3−1
@@ -10,7 +10,9 @@ derive instance eqV :: Eq V
10
10
11derive instance ordV :: Ord V
11derive instance ordV :: Ord V
12
12
13+type MyString = String
14+
13−data X = X Int | Y String
15+data X = X Int | Y MyString
14
16
15derive instance eqX :: Eq X
17derive instance eqX :: Eq X
16
18
examples/passing/DerivingFunctor.purs+4
@@ -4,11 +4,14 @@ import Prelude
4import Control.Monad.Eff.Console (log)
4import Control.Monad.Eff.Console (log)
5import Test.Assert
5import Test.Assert
6
6
7+type MyRecord a = { myField :: a }
8+
7data M f a
9data M f a
8 = M0 a (Array a)
10 = M0 a (Array a)
9 | M1 Int
11 | M1 Int
10 | M2 (f a)
12 | M2 (f a)
11 | M3 { foo :: Int, bar :: a, baz :: f a }
13 | M3 { foo :: Int, bar :: a, baz :: f a }
14+ | M4 (MyRecord a)
12
15
13derive instance eqM :: (Eq (f a), Eq a) => Eq (M f a)
16derive instance eqM :: (Eq (f a), Eq a) => Eq (M f a)
14
17
@@ -21,4 +24,5 @@ main = do
21 assert $ map show (M1 0 :: MA Int) == M1 0
24 assert $ map show (M1 0 :: MA Int) == M1 0
22 assert $ map show (M2 [0, 1] :: MA Int) == M2 ["0", "1"]
25 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"]}
26 assert $ map show (M3 {foo: 0, bar: 1, baz: [2, 3]} :: MA Int) == M3 {foo: 0, bar: "1", baz: ["2", "3"]}
27+ assert $ map show (M4 { myField: 42 }) == M4 { myField: "42" } :: MA String
24 log "Done"
28 log "Done"
examples/passing/GenericsRep.purs+3−1
@@ -27,7 +27,9 @@ derive instance genericZ :: Generic Z _
27instance eqZ :: Eq Z where
27instance eqZ :: Eq Z where
28 eq x y = genericEq x y
28 eq x y = genericEq x y
29
29
30+type MyString = String
31+
30−newtype W = W { x :: Int, y :: String }
32+newtype W = W { x :: Int, y :: MyString }
31
33
32derive instance genericW :: Generic W _
34derive instance genericW :: Generic W _
33
35
examples/passing/NewtypeInstance.purs+3−1
@@ -4,7 +4,9 @@ import Prelude
4import Control.Monad.Eff
4import Control.Monad.Eff
5import Control.Monad.Eff.Console
5import Control.Monad.Eff.Console
6
6
7+type MyString = String
8+
7−newtype X = X String
9+newtype X = X MyString
8
10
9derive newtype instance showX :: Show X
11derive newtype instance showX :: Show X
10
12
src/Language/PureScript/Sugar.hs+1−1
@@ -62,6 +62,6 @@ desugar externs =
62 >=> desugarImports externs
62 >=> desugarImports externs
63 >=> rebracket externs
63 >=> rebracket externs
64 >=> traverse checkFixityExports
64 >=> traverse checkFixityExports
65− >=> traverse deriveInstances
65+ >=> traverse (deriveInstances externs)
66 >=> desugarTypeClasses externs
66 >=> desugarTypeClasses externs
67 >=> traverse createBindingGroupsModule
67 >=> traverse createBindingGroupsModule
src/Language/PureScript/Sugar/TypeClasses/Deriving.hs+92−63
@@ -3,86 +3,102 @@
3--
3--
4module Language.PureScript.Sugar.TypeClasses.Deriving (deriveInstances) where
4module Language.PureScript.Sugar.TypeClasses.Deriving (deriveInstances) where
5
5
6−import Prelude.Compat
6+import Prelude.Compat
7−
7+
8−import Control.Arrow (second)
8+import Control.Arrow (second)
9−import Control.Monad (replicateM, zipWithM)
9+import Control.Monad (replicateM, zipWithM)
10−import Control.Monad.Error.Class (MonadError(..))
10+import Control.Monad.Error.Class (MonadError(..))
11−import Control.Monad.Supply.Class (MonadSupply)
11+import Control.Monad.Supply.Class (MonadSupply)
12−
13−import Data.List (foldl', find, sortBy, unzip5)
12+import Data.List (foldl', find, sortBy, unzip5)
13+import qualified Data.Map as M
14−import Data.Maybe (fromMaybe)
14+import Data.Maybe (fromMaybe, mapMaybe)
15−import Data.Ord (comparing)
15+import Data.Ord (comparing)
16−import Data.Text (Text)
16+import Data.Text (Text)
17−
18−import Language.PureScript.AST
17+import Language.PureScript.AST
19−import Language.PureScript.Crash
20−import Language.PureScript.Environment
21−import Language.PureScript.Errors
22−import Language.PureScript.Kinds
23−import Language.PureScript.Names
24−import Language.PureScript.TypeChecker (checkNewtype)
25−import Language.PureScript.Types
26import qualified Language.PureScript.Constants as C
18import qualified Language.PureScript.Constants as C
19+import Language.PureScript.Crash
20+import Language.PureScript.Environment
21+import Language.PureScript.Errors
22+import Language.PureScript.Externs
23+import Language.PureScript.Kinds
24+import Language.PureScript.Names
25+import Language.PureScript.Types
26+import Language.PureScript.TypeChecker (checkNewtype)
27+import Language.PureScript.TypeChecker.Synonyms (SynonymMap, replaceAllTypeSynonymsM)
27
28
28-- | Elaborates deriving instance declarations by code generation.
29-- | Elaborates deriving instance declarations by code generation.
29deriveInstances
30deriveInstances
31+ :: forall m
30− :: (MonadError MultipleErrors m, MonadSupply m)
32+ . (MonadError MultipleErrors m, MonadSupply m)
33+ => [ExternsFile]
31− => Module
34+ -> Module
32 -> m Module
35 -> m Module
36+deriveInstances externs (Module ss coms mn ds exts) =
33−deriveInstances (Module ss coms mn ds exts) = Module ss coms mn <$> mapM (deriveInstance mn ds) ds <*> pure exts
37+ Module ss coms mn <$> mapM (deriveInstance mn synonyms ds) ds <*> pure exts
38+ where
39+ -- We need to collect type synonym information, since synonyms will not be
40+ -- removed until later, during type checking.
41+ synonyms :: SynonymMap
42+ synonyms =
43+ M.fromList $ (externs >>= \ExternsFile{..} -> mapMaybe (fromExternsDecl efModuleName) efDeclarations)
44+ ++ mapMaybe fromLocalDecl ds
45+ where
46+ fromExternsDecl mn' (EDTypeSynonym name args ty) = Just (Qualified (Just mn') name, (args, ty))
47+ fromExternsDecl _ _ = Nothing
48+
49+ fromLocalDecl (TypeSynonymDeclaration name args ty) = do
50+ Just (Qualified (Just mn) name, (args, ty))
51+ fromLocalDecl (PositionedDeclaration _ _ d) = fromLocalDecl d
52+ fromLocalDecl _ = Nothing
34
53
35-- | Takes a declaration, and if the declaration is a deriving TypeInstanceDeclaration,
54-- | Takes a declaration, and if the declaration is a deriving TypeInstanceDeclaration,
36-- elaborates that into an instance declaration via code generation.
55-- elaborates that into an instance declaration via code generation.
37deriveInstance
56deriveInstance
38 :: (MonadError MultipleErrors m, MonadSupply m)
57 :: (MonadError MultipleErrors m, MonadSupply m)
39 => ModuleName
58 => ModuleName
59+ -> SynonymMap
40 -> [Declaration]
60 -> [Declaration]
41 -> Declaration
61 -> Declaration
42 -> m Declaration
62 -> m Declaration
43−deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@[ty] DerivedInstance)
63+deriveInstance mn syns ds (TypeInstanceDeclaration nm deps className tys@[ty] DerivedInstance)
44 | className == Qualified (Just dataGeneric) (ProperName C.generic)
64 | className == Qualified (Just dataGeneric) (ProperName C.generic)
45 , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor ty
65 , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor ty
46 , mn == fromMaybe mn mn'
66 , mn == fromMaybe mn mn'
47− = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveGeneric mn ds tyCon args
67+ = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveGeneric mn syns ds tyCon args
48−
49 | className == Qualified (Just dataEq) (ProperName "Eq")
68 | className == Qualified (Just dataEq) (ProperName "Eq")
50 , Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty
69 , Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty
51 , mn == fromMaybe mn mn'
70 , mn == fromMaybe mn mn'
52− = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveEq mn ds tyCon
71+ = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveEq mn syns ds tyCon
53−
54 | className == Qualified (Just dataOrd) (ProperName "Ord")
72 | className == Qualified (Just dataOrd) (ProperName "Ord")
55 , Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty
73 , Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty
56 , mn == fromMaybe mn mn'
74 , mn == fromMaybe mn mn'
57− = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveOrd mn ds tyCon
75+ = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveOrd mn syns ds tyCon
58−
59 | className == Qualified (Just dataFunctor) (ProperName "Functor")
76 | className == Qualified (Just dataFunctor) (ProperName "Functor")
60 , Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty
77 , Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty
61 , mn == fromMaybe mn mn'
78 , mn == fromMaybe mn mn'
62− = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveFunctor mn ds tyCon
79+ = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveFunctor mn syns ds tyCon
63−
64−deriveInstance mn ds (TypeInstanceDeclaration nm deps className [wrappedTy, unwrappedTy] DerivedInstance)
80+deriveInstance mn syns ds (TypeInstanceDeclaration nm deps className [wrappedTy, unwrappedTy] DerivedInstance)
65 | className == Qualified (Just dataNewtype) (ProperName "Newtype")
81 | className == Qualified (Just dataNewtype) (ProperName "Newtype")
66 , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor wrappedTy
82 , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor wrappedTy
67 , mn == fromMaybe mn mn'
83 , mn == fromMaybe mn mn'
68− = do (inst, actualUnwrappedTy) <- deriveNewtype mn ds tyCon args unwrappedTy
84+ = do (inst, actualUnwrappedTy) <- deriveNewtype mn syns ds tyCon args unwrappedTy
69 return $ TypeInstanceDeclaration nm deps className [wrappedTy, actualUnwrappedTy] (ExplicitInstance inst)
85 return $ TypeInstanceDeclaration nm deps className [wrappedTy, actualUnwrappedTy] (ExplicitInstance inst)
70−deriveInstance mn ds (TypeInstanceDeclaration nm deps className [actualTy, repTy] DerivedInstance)
86+deriveInstance mn syns ds (TypeInstanceDeclaration nm deps className [actualTy, repTy] DerivedInstance)
71 | className == Qualified (Just dataGenericRep) (ProperName C.generic)
87 | className == Qualified (Just dataGenericRep) (ProperName C.generic)
72 , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor actualTy
88 , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor actualTy
73 , mn == fromMaybe mn mn'
89 , mn == fromMaybe mn mn'
74− = do (inst, inferredRepTy) <- deriveGenericRep mn ds tyCon args repTy
90+ = do (inst, inferredRepTy) <- deriveGenericRep mn syns ds tyCon args repTy
75 return $ TypeInstanceDeclaration nm deps className [actualTy, inferredRepTy] (ExplicitInstance inst)
91 return $ TypeInstanceDeclaration nm deps className [actualTy, inferredRepTy] (ExplicitInstance inst)
76−deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance)
92+deriveInstance _ _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance)
77 = throwError . errorMessage $ CannotDerive className tys
93 = throwError . errorMessage $ CannotDerive className tys
78−deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@(_ : _) NewtypeInstance)
94+deriveInstance mn syns ds (TypeInstanceDeclaration nm deps className tys@(_ : _) NewtypeInstance)
79 | Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor (last tys)
95 | Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor (last tys)
80 , mn == fromMaybe mn mn'
96 , mn == fromMaybe mn mn'
81− = TypeInstanceDeclaration nm deps className tys . NewtypeInstanceWithDictionary <$> deriveNewtypeInstance className ds tys tyCon args
97+ = TypeInstanceDeclaration nm deps className tys . NewtypeInstanceWithDictionary <$> deriveNewtypeInstance syns className ds tys tyCon args
82−deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys NewtypeInstance)
98+deriveInstance _ _ _ (TypeInstanceDeclaration _ _ className tys NewtypeInstance)
83 = throwError . errorMessage $ InvalidNewtypeInstance className tys
99 = throwError . errorMessage $ InvalidNewtypeInstance className tys
84−deriveInstance mn ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn ds d
100+deriveInstance mn syns ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn syns ds d
85−deriveInstance _ _ e = return e
101+deriveInstance _ _ _ e = return e
86
102
87unwrapTypeConstructor :: Type -> Maybe (Qualified (ProperName 'TypeName), [Type])
103unwrapTypeConstructor :: Type -> Maybe (Qualified (ProperName 'TypeName), [Type])
88unwrapTypeConstructor = fmap (second reverse) . go
104unwrapTypeConstructor = fmap (second reverse) . go
@@ -96,13 +112,14 @@ unwrapTypeConstructor = fmap (second reverse) . go
96deriveNewtypeInstance
112deriveNewtypeInstance
97 :: forall m
113 :: forall m
98 . MonadError MultipleErrors m
114 . MonadError MultipleErrors m
115+ => SynonymMap
99− => Qualified (ProperName 'ClassName)
116+ -> Qualified (ProperName 'ClassName)
100 -> [Declaration]
117 -> [Declaration]
101 -> [Type]
118 -> [Type]
102 -> ProperName 'TypeName
119 -> ProperName 'TypeName
103 -> [Type]
120 -> [Type]
104 -> m Expr
121 -> m Expr
105−deriveNewtypeInstance className ds tys tyConNm dargs = do
122+deriveNewtypeInstance syns className ds tys tyConNm dargs = do
106 tyCon <- findTypeDecl tyConNm ds
123 tyCon <- findTypeDecl tyConNm ds
107 go tyCon
124 go tyCon
108 where
125 where
@@ -118,7 +135,8 @@ deriveNewtypeInstance className ds tys tyConNm dargs = do
118 -- type argument
135 -- type argument
119 | Just wrapped' <- stripRight (takeReverse (length tyArgNames - length dargs) tyArgNames) wrapped =
136 | Just wrapped' <- stripRight (takeReverse (length tyArgNames - length dargs) tyArgNames) wrapped =
120 do let subst = zipWith (\(name, _) t -> (name, t)) tyArgNames dargs
137 do let subst = zipWith (\(name, _) t -> (name, t)) tyArgNames dargs
138+ wrapped'' <- replaceAllTypeSynonymsM syns wrapped'
121− return (DeferredDictionary className (init tys ++ [replaceAllTypeVars subst wrapped']))
139+ return (DeferredDictionary className (init tys ++ [replaceAllTypeVars subst wrapped'']))
122 go (PositionedDeclaration _ _ d) = go d
140 go (PositionedDeclaration _ _ d) = go d
123 go _ = throwError . errorMessage $ InvalidNewtypeInstance className tys
141 go _ = throwError . errorMessage $ InvalidNewtypeInstance className tys
124
142
@@ -158,11 +176,12 @@ dataFunctor = ModuleName [ ProperName "Data", ProperName "Functor" ]
158deriveGeneric
176deriveGeneric
159 :: forall m. (MonadError MultipleErrors m, MonadSupply m)
177 :: forall m. (MonadError MultipleErrors m, MonadSupply m)
160 => ModuleName
178 => ModuleName
179+ -> SynonymMap
161 -> [Declaration]
180 -> [Declaration]
162 -> ProperName 'TypeName
181 -> ProperName 'TypeName
163 -> [Type]
182 -> [Type]
164 -> m [Declaration]
183 -> m [Declaration]
165−deriveGeneric mn ds tyConNm dargs = do
184+deriveGeneric mn syns ds tyConNm dargs = do
166 tyCon <- findTypeDecl tyConNm ds
185 tyCon <- findTypeDecl tyConNm ds
167 toSpine <- mkSpineFunction tyCon
186 toSpine <- mkSpineFunction tyCon
168 fromSpine <- mkFromSpineFunction tyCon
187 fromSpine <- mkFromSpineFunction tyCon
@@ -186,12 +205,12 @@ deriveGeneric mn ds tyConNm dargs = do
186 mkCtorClause :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative
205 mkCtorClause :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative
187 mkCtorClause (ctorName, tys) = do
206 mkCtorClause (ctorName, tys) = do
188 idents <- replicateM (length tys) freshIdent'
207 idents <- replicateM (length tys) freshIdent'
189− return $ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)] (Right (caseResult idents))
208+ tys' <- mapM (replaceAllTypeSynonymsM syns) tys
190− where
209+ let caseResult =
191− caseResult idents =
192− App (prodConstructor (Literal . StringLiteral . showQualified runProperName $ Qualified (Just mn) ctorName))
210+ App (prodConstructor (Literal . StringLiteral . showQualified runProperName $ Qualified (Just mn) ctorName))
193− . Literal . ArrayLiteral
211+ . Literal . ArrayLiteral
194− $ zipWith toSpineFun (map (Var . Qualified Nothing) idents) tys
212+ $ zipWith toSpineFun (map (Var . Qualified Nothing) idents) tys'
213+ return $ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)] (Right caseResult)
195
214
196 toSpineFun :: Expr -> Type -> Expr
215 toSpineFun :: Expr -> Type -> Expr
197 toSpineFun i r | Just rec <- objectType r =
216 toSpineFun i r | Just rec <- objectType r =
@@ -326,12 +345,13 @@ deriveGenericRep
326 :: forall m
345 :: forall m
327 . (MonadError MultipleErrors m, MonadSupply m)
346 . (MonadError MultipleErrors m, MonadSupply m)
328 => ModuleName
347 => ModuleName
348+ -> SynonymMap
329 -> [Declaration]
349 -> [Declaration]
330 -> ProperName 'TypeName
350 -> ProperName 'TypeName
331 -> [Type]
351 -> [Type]
332 -> Type
352 -> Type
333 -> m ([Declaration], Type)
353 -> m ([Declaration], Type)
334−deriveGenericRep mn ds tyConNm tyConArgs repTy = do
354+deriveGenericRep mn syns ds tyConNm tyConArgs repTy = do
335 checkIsWildcard tyConNm repTy
355 checkIsWildcard tyConNm repTy
336 go =<< findTypeDecl tyConNm ds
356 go =<< findTypeDecl tyConNm ds
337 where
357 where
@@ -382,7 +402,8 @@ deriveGenericRep mn ds tyConNm tyConArgs repTy = do
382 :: (ProperName 'ConstructorName, [Type])
402 :: (ProperName 'ConstructorName, [Type])
383 -> m (Type, CaseAlternative, CaseAlternative)
403 -> m (Type, CaseAlternative, CaseAlternative)
384 makeInst (ctorName, args) = do
404 makeInst (ctorName, args) = do
405+ args' <- mapM (replaceAllTypeSynonymsM syns) args
385− (ctorTy, matchProduct, ctorArgs, matchCtor, mkProduct) <- makeProduct args
406+ (ctorTy, matchProduct, ctorArgs, matchCtor, mkProduct) <- makeProduct args'
386 return ( TypeApp (TypeApp (TypeConstructor constructor)
407 return ( TypeApp (TypeApp (TypeConstructor constructor)
387 (TypeLevelString (runProperName ctorName)))
408 (TypeLevelString (runProperName ctorName)))
388 ctorTy
409 ctorTy
@@ -506,10 +527,11 @@ checkIsWildcard tyConNm _ =
506deriveEq ::
527deriveEq ::
507 forall m. (MonadError MultipleErrors m, MonadSupply m)
528 forall m. (MonadError MultipleErrors m, MonadSupply m)
508 => ModuleName
529 => ModuleName
530+ -> SynonymMap
509 -> [Declaration]
531 -> [Declaration]
510 -> ProperName 'TypeName
532 -> ProperName 'TypeName
511 -> m [Declaration]
533 -> m [Declaration]
512−deriveEq mn ds tyConNm = do
534+deriveEq mn syns ds tyConNm = do
513 tyCon <- findTypeDecl tyConNm ds
535 tyCon <- findTypeDecl tyConNm ds
514 eqFun <- mkEqFunction tyCon
536 eqFun <- mkEqFunction tyCon
515 return [ ValueDeclaration (Ident C.eq) Public [] (Right eqFun) ]
537 return [ ValueDeclaration (Ident C.eq) Public [] (Right eqFun) ]
@@ -539,7 +561,8 @@ deriveEq mn ds tyConNm = do
539 mkCtorClause (ctorName, tys) = do
561 mkCtorClause (ctorName, tys) = do
540 identsL <- replicateM (length tys) (freshIdent "l")
562 identsL <- replicateM (length tys) (freshIdent "l")
541 identsR <- replicateM (length tys) (freshIdent "r")
563 identsR <- replicateM (length tys) (freshIdent "r")
564+ tys' <- mapM (replaceAllTypeSynonymsM syns) tys
542− let tests = zipWith3 toEqTest (map (Var . Qualified Nothing) identsL) (map (Var . Qualified Nothing) identsR) tys
565+ let tests = zipWith3 toEqTest (map (Var . Qualified Nothing) identsL) (map (Var . Qualified Nothing) identsR) tys'
543 return $ CaseAlternative [caseBinder identsL, caseBinder identsR] (Right (conjAll tests))
566 return $ CaseAlternative [caseBinder identsL, caseBinder identsR] (Right (conjAll tests))
544 where
567 where
545 caseBinder idents = ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)
568 caseBinder idents = ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)
@@ -558,10 +581,11 @@ deriveEq mn ds tyConNm = do
558deriveOrd ::
581deriveOrd ::
559 forall m. (MonadError MultipleErrors m, MonadSupply m)
582 forall m. (MonadError MultipleErrors m, MonadSupply m)
560 => ModuleName
583 => ModuleName
584+ -> SynonymMap
561 -> [Declaration]
585 -> [Declaration]
562 -> ProperName 'TypeName
586 -> ProperName 'TypeName
563 -> m [Declaration]
587 -> m [Declaration]
564−deriveOrd mn ds tyConNm = do
588+deriveOrd mn syns ds tyConNm = do
565 tyCon <- findTypeDecl tyConNm ds
589 tyCon <- findTypeDecl tyConNm ds
566 compareFun <- mkCompareFunction tyCon
590 compareFun <- mkCompareFunction tyCon
567 return [ ValueDeclaration (Ident C.compare) Public [] (Right compareFun) ]
591 return [ ValueDeclaration (Ident C.compare) Public [] (Right compareFun) ]
@@ -602,7 +626,8 @@ deriveOrd mn ds tyConNm = do
602 mkCtorClauses ((ctorName, tys), isLast) = do
626 mkCtorClauses ((ctorName, tys), isLast) = do
603 identsL <- replicateM (length tys) (freshIdent "l")
627 identsL <- replicateM (length tys) (freshIdent "l")
604 identsR <- replicateM (length tys) (freshIdent "r")
628 identsR <- replicateM (length tys) (freshIdent "r")
629+ tys' <- mapM (replaceAllTypeSynonymsM syns) tys
605− let tests = zipWith3 toOrdering (map (Var . Qualified Nothing) identsL) (map (Var . Qualified Nothing) identsR) tys
630+ let tests = zipWith3 toOrdering (map (Var . Qualified Nothing) identsL) (map (Var . Qualified Nothing) identsR) tys'
606 extras | not isLast = [ CaseAlternative [ ConstructorBinder (Qualified (Just mn) ctorName) (replicate (length tys) NullBinder)
631 extras | not isLast = [ CaseAlternative [ ConstructorBinder (Qualified (Just mn) ctorName) (replicate (length tys) NullBinder)
607 , NullBinder
632 , NullBinder
608 ]
633 ]
@@ -644,12 +669,13 @@ deriveNewtype
644 :: forall m
669 :: forall m
645 . (MonadError MultipleErrors m, MonadSupply m)
670 . (MonadError MultipleErrors m, MonadSupply m)
646 => ModuleName
671 => ModuleName
672+ -> SynonymMap
647 -> [Declaration]
673 -> [Declaration]
648 -> ProperName 'TypeName
674 -> ProperName 'TypeName
649 -> [Type]
675 -> [Type]
650 -> Type
676 -> Type
651 -> m ([Declaration], Type)
677 -> m ([Declaration], Type)
652−deriveNewtype mn ds tyConNm tyConArgs unwrappedTy = do
678+deriveNewtype mn syns ds tyConNm tyConArgs unwrappedTy = do
653 checkIsWildcard tyConNm unwrappedTy
679 checkIsWildcard tyConNm unwrappedTy
654 go =<< findTypeDecl tyConNm ds
680 go =<< findTypeDecl tyConNm ds
655 where
681 where
@@ -661,7 +687,8 @@ deriveNewtype mn ds tyConNm tyConArgs unwrappedTy = do
661 wrappedIdent <- freshIdent "n"
687 wrappedIdent <- freshIdent "n"
662 unwrappedIdent <- freshIdent "a"
688 unwrappedIdent <- freshIdent "a"
663 let (ctorName, [ty]) = head dctors
689 let (ctorName, [ty]) = head dctors
690+ ty' <- replaceAllTypeSynonymsM syns ty
664− inst =
691+ let inst =
665 [ ValueDeclaration (Ident "wrap") Public [] $ Right $
692 [ ValueDeclaration (Ident "wrap") Public [] $ Right $
666 Constructor (Qualified (Just mn) ctorName)
693 Constructor (Qualified (Just mn) ctorName)
667 , ValueDeclaration (Ident "unwrap") Public [] $ Right $
694 , ValueDeclaration (Ident "unwrap") Public [] $ Right $
@@ -672,7 +699,7 @@ deriveNewtype mn ds tyConNm tyConArgs unwrappedTy = do
672 ]
699 ]
673 ]
700 ]
674 subst = zipWith ((,) . fst) args tyConArgs
701 subst = zipWith ((,) . fst) args tyConArgs
675− return (inst, replaceAllTypeVars subst ty)
702+ return (inst, replaceAllTypeVars subst ty')
676 go (PositionedDeclaration _ _ d) = go d
703 go (PositionedDeclaration _ _ d) = go d
677 go _ = internalError "deriveNewtype go: expected DataDeclaration"
704 go _ = internalError "deriveNewtype go: expected DataDeclaration"
678
705
@@ -719,10 +746,11 @@ deriveFunctor
719 :: forall m
746 :: forall m
720 . (MonadError MultipleErrors m, MonadSupply m)
747 . (MonadError MultipleErrors m, MonadSupply m)
721 => ModuleName
748 => ModuleName
749+ -> SynonymMap
722 -> [Declaration]
750 -> [Declaration]
723 -> ProperName 'TypeName
751 -> ProperName 'TypeName
724 -> m [Declaration]
752 -> m [Declaration]
725−deriveFunctor mn ds tyConNm = do
753+deriveFunctor mn syns ds tyConNm = do
726 tyCon <- findTypeDecl tyConNm ds
754 tyCon <- findTypeDecl tyConNm ds
727 mapFun <- mkMapFunction tyCon
755 mapFun <- mkMapFunction tyCon
728 return [ ValueDeclaration (Ident C.map) Public [] (Right mapFun) ]
756 return [ ValueDeclaration (Ident C.map) Public [] (Right mapFun) ]
@@ -740,7 +768,8 @@ deriveFunctor mn ds tyConNm = do
740 mkCtorClause :: Text -> Ident -> (ProperName 'ConstructorName, [Type]) -> m CaseAlternative
768 mkCtorClause :: Text -> Ident -> (ProperName 'ConstructorName, [Type]) -> m CaseAlternative
741 mkCtorClause iTyName f (ctorName, ctorTys) = do
769 mkCtorClause iTyName f (ctorName, ctorTys) = do
742 idents <- replicateM (length ctorTys) (freshIdent "v")
770 idents <- replicateM (length ctorTys) (freshIdent "v")
771+ ctorTys' <- mapM (replaceAllTypeSynonymsM syns) ctorTys
743− args <- zipWithM transformArg idents ctorTys
772+ args <- zipWithM transformArg idents ctorTys'
744 let ctor = Constructor (Qualified (Just mn) ctorName)
773 let ctor = Constructor (Qualified (Just mn) ctorName)
745 rebuilt = foldl App ctor args
774 rebuilt = foldl App ctor args
746 caseBinder = ConstructorBinder (Qualified (Just mn) ctorName) (VarBinder <$> idents)
775 caseBinder = ConstructorBinder (Qualified (Just mn) ctorName) (VarBinder <$> idents)
src/Language/PureScript/TypeChecker/Synonyms.hs+35−20
@@ -4,44 +4,59 @@
4-- Functions for replacing fully applied type synonyms
4-- Functions for replacing fully applied type synonyms
5--
5--
6module Language.PureScript.TypeChecker.Synonyms
6module Language.PureScript.TypeChecker.Synonyms
7+ ( SynonymMap
7− ( replaceAllTypeSynonyms
8+ , replaceAllTypeSynonyms
9+ , replaceAllTypeSynonymsM
8 ) where
10 ) where
9
11
10−import Prelude.Compat
12+import Prelude.Compat
11
13
12−import Control.Monad.Error.Class (MonadError(..))
14+import Control.Monad.Error.Class (MonadError(..))
13−import Control.Monad.State
15+import Control.Monad.State
14−
15−import Data.Maybe (fromMaybe)
16+import Data.Maybe (fromMaybe)
16import qualified Data.Map as M
17import qualified Data.Map as M
17−
18+import Data.Text (Text)
18−import Language.PureScript.Environment
19+import Language.PureScript.Environment
19−import Language.PureScript.Errors
20+import Language.PureScript.Errors
21+import Language.PureScript.Kinds
22+import Language.PureScript.Names
20−import Language.PureScript.TypeChecker.Monad
23+import Language.PureScript.TypeChecker.Monad
21−import Language.PureScript.Types
24+import Language.PureScript.Types
22−
25+
23−-- |
26+-- | Type synonym information (arguments with kinds, aliased type), indexed by name
24−-- Replace fully applied type synonyms.
27+type SynonymMap = M.Map (Qualified (ProperName 'TypeName)) ([(Text, Maybe Kind)], Type)
25−--
28+
29+replaceAllTypeSynonyms'
30+ :: SynonymMap
31+ -> Type
26−replaceAllTypeSynonyms' :: Environment -> Type -> Either MultipleErrors Type
32+ -> Either MultipleErrors Type
27−replaceAllTypeSynonyms' env = everywhereOnTypesTopDownM try
33+replaceAllTypeSynonyms' syns = everywhereOnTypesTopDownM try
28 where
34 where
29 try :: Type -> Either MultipleErrors Type
35 try :: Type -> Either MultipleErrors Type
30 try t = fromMaybe t <$> go 0 [] t
36 try t = fromMaybe t <$> go 0 [] t
31
37
32 go :: Int -> [Type] -> Type -> Either MultipleErrors (Maybe Type)
38 go :: Int -> [Type] -> Type -> Either MultipleErrors (Maybe Type)
33 go c args (TypeConstructor ctor)
39 go c args (TypeConstructor ctor)
34− | Just (synArgs, body) <- M.lookup ctor (typeSynonyms env)
40+ | Just (synArgs, body) <- M.lookup ctor syns
35 , c == length synArgs
41 , c == length synArgs
36 = let repl = replaceAllTypeVars (zip (map fst synArgs) args) body
42 = let repl = replaceAllTypeVars (zip (map fst synArgs) args) body
37 in Just <$> try repl
43 in Just <$> try repl
38− | Just (synArgs, _) <- M.lookup ctor (typeSynonyms env)
44+ | Just (synArgs, _) <- M.lookup ctor syns
39 , length synArgs > c
45 , length synArgs > c
40 = throwError . errorMessage $ PartiallyAppliedSynonym ctor
46 = throwError . errorMessage $ PartiallyAppliedSynonym ctor
41 go c args (TypeApp f arg) = go (c + 1) (arg : args) f
47 go c args (TypeApp f arg) = go (c + 1) (arg : args) f
42 go _ _ _ = return Nothing
48 go _ _ _ = return Nothing
43
49
50+-- | Replace fully applied type synonyms
44replaceAllTypeSynonyms :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m) => Type -> m Type
51replaceAllTypeSynonyms :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m) => Type -> m Type
45replaceAllTypeSynonyms d = do
52replaceAllTypeSynonyms d = do
46 env <- getEnv
53 env <- getEnv
47− either throwError return $ replaceAllTypeSynonyms' env d
54+ either throwError return $ replaceAllTypeSynonyms' (typeSynonyms env) d
55+
56+-- | Replace fully applied type synonyms by explicitly providing a 'SynonymMap'.
57+replaceAllTypeSynonymsM
58+ :: MonadError MultipleErrors m
59+ => SynonymMap
60+ -> Type
61+ -> m Type
62+replaceAllTypeSynonymsM syns = either throwError pure . replaceAllTypeSynonyms' syns