cd535c1 · rowtype-yoga/purescript-native

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

Derive instances when data types use type synonyms (#2516)

* Derive instances when data types use type synonyms * Handle nested synonyms

commitcd535c18945bd9bbae1194a96fb7df897f4b55bd authorPhil Freeman <paf31@cantab.net> dateSat 31 Dec 2016, 16:42 (10 years ago) parent380de16

9 files changed+173−88

compare with golang

unifiedsplit

examples/passing/DeriveNewtype.purs+3−1 examples/passing/DeriveWithNestedSynonyms.purs+29 examples/passing/Deriving.purs+3−1 examples/passing/DerivingFunctor.purs+4 examples/passing/GenericsRep.purs+3−1 examples/passing/NewtypeInstance.purs+3−1 src/Language/PureScript/Sugar.hs+1−1 src/Language/PureScript/Sugar/TypeClasses/Deriving.hs+92−63 src/Language/PureScript/TypeChecker/Synonyms.hs+35−20

examples/passing/DeriveNewtype.purs+3−1

@@ -4,7 +4,9 @@ import Control.Monad.Eff.Console (log)

55import Data.Newtype

7−newtype Test = Test String

7+type MyString = String

9+newtype Test = Test MyString

810

911derive instance newtypeTest :: Newtype Test _

1012

examples/passing/DeriveWithNestedSynonyms.pursnew file+29

@@ -0,0 +1,29 @@

1+module Main where

3+import Prelude

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

6+type L = {}

7+data X = X L

8+derive instance eqX :: Eq X

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

1010

1111derive instance ordV :: Ord V

1212

13−data X = X Int | Y String

13+type MyString = String

14+

15+data X = X Int | Y MyString

1416

1517derive instance eqX :: Eq X

1618

examples/passing/DerivingFunctor.purs+4

@@ -4,11 +4,14 @@ import Prelude

44import Control.Monad.Eff.Console (log)

55import Test.Assert

7+type MyRecord a = { myField :: a }

79data M f a

810 = M0 a (Array a)

911 | M1 Int

1012 | M2 (f a)

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

14+ | M4 (MyRecord a)

1215

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

1417

@@ -21,4 +24,5 @@ main = do

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

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

2326 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

2428 log "Done"

examples/passing/GenericsRep.purs+3−1

@@ -27,7 +27,9 @@ derive instance genericZ :: Generic Z _

2727instance eqZ :: Eq Z where

2828 eq x y = genericEq x y

2929

30−newtype W = W { x :: Int, y :: String }

30+type MyString = String

31+

32+newtype W = W { x :: Int, y :: MyString }

3133

3234derive instance genericW :: Generic W _

3335

examples/passing/NewtypeInstance.purs+3−1

@@ -4,7 +4,9 @@ import Prelude

44import Control.Monad.Eff

55import Control.Monad.Eff.Console

7−newtype X = X String

7+type MyString = String

9+newtype X = X MyString

810

911derive newtype instance showX :: Show X

1012

src/Language/PureScript/Sugar.hs+1−1

@@ -62,6 +62,6 @@ desugar externs =

6262 >=> desugarImports externs

6363 >=> rebracket externs

6464 >=> traverse checkFixityExports

65− >=> traverse deriveInstances

65+ >=> traverse (deriveInstances externs)

6666 >=> desugarTypeClasses externs

6767 >=> traverse createBindingGroupsModule

src/Language/PureScript/Sugar/TypeClasses/Deriving.hs+92−63

@@ -3,86 +3,102 @@

33--

44module Language.PureScript.Sugar.TypeClasses.Deriving (deriveInstances) where

6−import Prelude.Compat

7−

8−import Control.Arrow (second)

9−import Control.Monad (replicateM, zipWithM)

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

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

12−

13−import Data.List (foldl', find, sortBy, unzip5)

14−import Data.Maybe (fromMaybe)

15−import Data.Ord (comparing)

16−import Data.Text (Text)

17−

18−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

6+import Prelude.Compat

8+import Control.Arrow (second)

9+import Control.Monad (replicateM, zipWithM)

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

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

12+import Data.List (foldl', find, sortBy, unzip5)

13+import qualified Data.Map as M

14+import Data.Maybe (fromMaybe, mapMaybe)

15+import Data.Ord (comparing)

16+import Data.Text (Text)

17+import Language.PureScript.AST

2618import 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)

2728

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

2930deriveInstances

30− :: (MonadError MultipleErrors m, MonadSupply m)

31− => Module

31+ :: forall m

32+ . (MonadError MultipleErrors m, MonadSupply m)

33+ => [ExternsFile]

34+ -> Module

3235 -> m Module

33−deriveInstances (Module ss coms mn ds exts) = Module ss coms mn <$> mapM (deriveInstance mn ds) ds <*> pure exts

36+deriveInstances externs (Module ss coms mn ds 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

3453

3554-- | Takes a declaration, and if the declaration is a deriving TypeInstanceDeclaration,

3655-- elaborates that into an instance declaration via code generation.

3756deriveInstance

3857 :: (MonadError MultipleErrors m, MonadSupply m)

3958 => ModuleName

59+ -> SynonymMap

4060 -> [Declaration]

4161 -> Declaration

4262 -> 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)

4464 | className == Qualified (Just dataGeneric) (ProperName C.generic)

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

4666 , mn == fromMaybe mn mn'

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

48−

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

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

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

5170 , mn == fromMaybe mn mn'

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

53−

71+ = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveEq mn syns ds tyCon

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

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

5674 , mn == fromMaybe mn mn'

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

58−

75+ = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveOrd mn syns ds tyCon

5976 | className == Qualified (Just dataFunctor) (ProperName "Functor")

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

6178 , mn == fromMaybe mn mn'

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

63−

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

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

80+deriveInstance mn syns ds (TypeInstanceDeclaration nm deps className [wrappedTy, unwrappedTy] DerivedInstance)

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

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

6783 , 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

6985 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)

7187 | className == Qualified (Just dataGenericRep) (ProperName C.generic)

7288 , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor actualTy

7389 , 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

7591 return $ TypeInstanceDeclaration nm deps className [actualTy, inferredRepTy] (ExplicitInstance inst)

76−deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance)

92+deriveInstance _ _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance)

7793 = 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)

7995 | Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor (last tys)

8096 , mn == fromMaybe mn mn'

81− = TypeInstanceDeclaration nm deps className tys . NewtypeInstanceWithDictionary <$> deriveNewtypeInstance className ds tys tyCon args

82−deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys NewtypeInstance)

97+ = TypeInstanceDeclaration nm deps className tys . NewtypeInstanceWithDictionary <$> deriveNewtypeInstance syns className ds tys tyCon args

98+deriveInstance _ _ _ (TypeInstanceDeclaration _ _ className tys NewtypeInstance)

8399 = throwError . errorMessage $ InvalidNewtypeInstance className tys

84−deriveInstance mn ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn ds d

85−deriveInstance _ _ e = return e

100+deriveInstance mn syns ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn syns ds d

101+deriveInstance _ _ _ e = return e

86102

87103unwrapTypeConstructor :: Type -> Maybe (Qualified (ProperName 'TypeName), [Type])

88104unwrapTypeConstructor = fmap (second reverse) . go

@@ -96,13 +112,14 @@ unwrapTypeConstructor = fmap (second reverse) . go

96112deriveNewtypeInstance

97113 :: forall m

98114 . MonadError MultipleErrors m

99− => Qualified (ProperName 'ClassName)

115+ => SynonymMap

116+ -> Qualified (ProperName 'ClassName)

100117 -> [Declaration]

101118 -> [Type]

102119 -> ProperName 'TypeName

103120 -> [Type]

104121 -> m Expr

105−deriveNewtypeInstance className ds tys tyConNm dargs = do

122+deriveNewtypeInstance syns className ds tys tyConNm dargs = do

106123 tyCon <- findTypeDecl tyConNm ds

107124 go tyCon

108125 where

@@ -118,7 +135,8 @@ deriveNewtypeInstance className ds tys tyConNm dargs = do

118135 -- type argument

119136 | Just wrapped' <- stripRight (takeReverse (length tyArgNames - length dargs) tyArgNames) wrapped =

120137 do let subst = zipWith (\(name, _) t -> (name, t)) tyArgNames dargs

121− return (DeferredDictionary className (init tys ++ [replaceAllTypeVars subst wrapped']))

138+ wrapped'' <- replaceAllTypeSynonymsM syns wrapped'

139+ return (DeferredDictionary className (init tys ++ [replaceAllTypeVars subst wrapped'']))

122140 go (PositionedDeclaration _ _ d) = go d

123141 go _ = throwError . errorMessage $ InvalidNewtypeInstance className tys

124142

@@ -158,11 +176,12 @@ dataFunctor = ModuleName [ ProperName "Data", ProperName "Functor" ]

158176deriveGeneric

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

160178 => ModuleName

179+ -> SynonymMap

161180 -> [Declaration]

162181 -> ProperName 'TypeName

163182 -> [Type]

164183 -> m [Declaration]

165−deriveGeneric mn ds tyConNm dargs = do

184+deriveGeneric mn syns ds tyConNm dargs = do

166185 tyCon <- findTypeDecl tyConNm ds

167186 toSpine <- mkSpineFunction tyCon

168187 fromSpine <- mkFromSpineFunction tyCon

@@ -186,12 +205,12 @@ deriveGeneric mn ds tyConNm dargs = do

186205 mkCtorClause :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative

187206 mkCtorClause (ctorName, tys) = do

188207 idents <- replicateM (length tys) freshIdent'

189− return $ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)] (Right (caseResult idents))

190− where

191− caseResult idents =

192− App (prodConstructor (Literal . StringLiteral . showQualified runProperName $ Qualified (Just mn) ctorName))

193− . Literal . ArrayLiteral

194− $ zipWith toSpineFun (map (Var . Qualified Nothing) idents) tys

208+ tys' <- mapM (replaceAllTypeSynonymsM syns) tys

209+ let caseResult =

210+ App (prodConstructor (Literal . StringLiteral . showQualified runProperName $ Qualified (Just mn) ctorName))

211+ . Literal . ArrayLiteral

212+ $ zipWith toSpineFun (map (Var . Qualified Nothing) idents) tys'

213+ return $ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)] (Right caseResult)

195214

196215 toSpineFun :: Expr -> Type -> Expr

197216 toSpineFun i r | Just rec <- objectType r =

@@ -326,12 +345,13 @@ deriveGenericRep

326345 :: forall m

327346 . (MonadError MultipleErrors m, MonadSupply m)

328347 => ModuleName

348+ -> SynonymMap

329349 -> [Declaration]

330350 -> ProperName 'TypeName

331351 -> [Type]

332352 -> Type

333353 -> m ([Declaration], Type)

334−deriveGenericRep mn ds tyConNm tyConArgs repTy = do

354+deriveGenericRep mn syns ds tyConNm tyConArgs repTy = do

335355 checkIsWildcard tyConNm repTy

336356 go =<< findTypeDecl tyConNm ds

337357 where

@@ -382,7 +402,8 @@ deriveGenericRep mn ds tyConNm tyConArgs repTy = do

382402 :: (ProperName 'ConstructorName, [Type])

383403 -> m (Type, CaseAlternative, CaseAlternative)

384404 makeInst (ctorName, args) = do

385− (ctorTy, matchProduct, ctorArgs, matchCtor, mkProduct) <- makeProduct args

405+ args' <- mapM (replaceAllTypeSynonymsM syns) args

406+ (ctorTy, matchProduct, ctorArgs, matchCtor, mkProduct) <- makeProduct args'

386407 return ( TypeApp (TypeApp (TypeConstructor constructor)

387408 (TypeLevelString (runProperName ctorName)))

388409 ctorTy

@@ -506,10 +527,11 @@ checkIsWildcard tyConNm _ =

506527deriveEq ::

507528 forall m. (MonadError MultipleErrors m, MonadSupply m)

508529 => ModuleName

530+ -> SynonymMap

509531 -> [Declaration]

510532 -> ProperName 'TypeName

511533 -> m [Declaration]

512−deriveEq mn ds tyConNm = do

534+deriveEq mn syns ds tyConNm = do

513535 tyCon <- findTypeDecl tyConNm ds

514536 eqFun <- mkEqFunction tyCon

515537 return [ ValueDeclaration (Ident C.eq) Public [] (Right eqFun) ]

@@ -539,7 +561,8 @@ deriveEq mn ds tyConNm = do

539561 mkCtorClause (ctorName, tys) = do

540562 identsL <- replicateM (length tys) (freshIdent "l")

541563 identsR <- replicateM (length tys) (freshIdent "r")

542− let tests = zipWith3 toEqTest (map (Var . Qualified Nothing) identsL) (map (Var . Qualified Nothing) identsR) tys

564+ tys' <- mapM (replaceAllTypeSynonymsM syns) tys

565+ let tests = zipWith3 toEqTest (map (Var . Qualified Nothing) identsL) (map (Var . Qualified Nothing) identsR) tys'

543566 return $ CaseAlternative [caseBinder identsL, caseBinder identsR] (Right (conjAll tests))

544567 where

545568 caseBinder idents = ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)

@@ -558,10 +581,11 @@ deriveEq mn ds tyConNm = do

558581deriveOrd ::

559582 forall m. (MonadError MultipleErrors m, MonadSupply m)

560583 => ModuleName

584+ -> SynonymMap

561585 -> [Declaration]

562586 -> ProperName 'TypeName

563587 -> m [Declaration]

564−deriveOrd mn ds tyConNm = do

588+deriveOrd mn syns ds tyConNm = do

565589 tyCon <- findTypeDecl tyConNm ds

566590 compareFun <- mkCompareFunction tyCon

567591 return [ ValueDeclaration (Ident C.compare) Public [] (Right compareFun) ]

@@ -602,7 +626,8 @@ deriveOrd mn ds tyConNm = do

602626 mkCtorClauses ((ctorName, tys), isLast) = do

603627 identsL <- replicateM (length tys) (freshIdent "l")

604628 identsR <- replicateM (length tys) (freshIdent "r")

605− let tests = zipWith3 toOrdering (map (Var . Qualified Nothing) identsL) (map (Var . Qualified Nothing) identsR) tys

629+ tys' <- mapM (replaceAllTypeSynonymsM syns) tys

630+ let tests = zipWith3 toOrdering (map (Var . Qualified Nothing) identsL) (map (Var . Qualified Nothing) identsR) tys'

606631 extras | not isLast = [ CaseAlternative [ ConstructorBinder (Qualified (Just mn) ctorName) (replicate (length tys) NullBinder)

607632 , NullBinder

608633 ]

@@ -644,12 +669,13 @@ deriveNewtype

644669 :: forall m

645670 . (MonadError MultipleErrors m, MonadSupply m)

646671 => ModuleName

672+ -> SynonymMap

647673 -> [Declaration]

648674 -> ProperName 'TypeName

649675 -> [Type]

650676 -> Type

651677 -> m ([Declaration], Type)

652−deriveNewtype mn ds tyConNm tyConArgs unwrappedTy = do

678+deriveNewtype mn syns ds tyConNm tyConArgs unwrappedTy = do

653679 checkIsWildcard tyConNm unwrappedTy

654680 go =<< findTypeDecl tyConNm ds

655681 where

@@ -661,7 +687,8 @@ deriveNewtype mn ds tyConNm tyConArgs unwrappedTy = do

661687 wrappedIdent <- freshIdent "n"

662688 unwrappedIdent <- freshIdent "a"

663689 let (ctorName, [ty]) = head dctors

664− inst =

690+ ty' <- replaceAllTypeSynonymsM syns ty

691+ let inst =

665692 [ ValueDeclaration (Ident "wrap") Public [] $ Right $

666693 Constructor (Qualified (Just mn) ctorName)

667694 , ValueDeclaration (Ident "unwrap") Public [] $ Right $

@@ -672,7 +699,7 @@ deriveNewtype mn ds tyConNm tyConArgs unwrappedTy = do

672699 ]

673700 ]

674701 subst = zipWith ((,) . fst) args tyConArgs

675− return (inst, replaceAllTypeVars subst ty)

702+ return (inst, replaceAllTypeVars subst ty')

676703 go (PositionedDeclaration _ _ d) = go d

677704 go _ = internalError "deriveNewtype go: expected DataDeclaration"

678705

@@ -719,10 +746,11 @@ deriveFunctor

719746 :: forall m

720747 . (MonadError MultipleErrors m, MonadSupply m)

721748 => ModuleName

749+ -> SynonymMap

722750 -> [Declaration]

723751 -> ProperName 'TypeName

724752 -> m [Declaration]

725−deriveFunctor mn ds tyConNm = do

753+deriveFunctor mn syns ds tyConNm = do

726754 tyCon <- findTypeDecl tyConNm ds

727755 mapFun <- mkMapFunction tyCon

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

@@ -740,7 +768,8 @@ deriveFunctor mn ds tyConNm = do

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

741769 mkCtorClause iTyName f (ctorName, ctorTys) = do

742770 idents <- replicateM (length ctorTys) (freshIdent "v")

743− args <- zipWithM transformArg idents ctorTys

771+ ctorTys' <- mapM (replaceAllTypeSynonymsM syns) ctorTys

772+ args <- zipWithM transformArg idents ctorTys'

744773 let ctor = Constructor (Qualified (Just mn) ctorName)

745774 rebuilt = foldl App ctor args

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

src/Language/PureScript/TypeChecker/Synonyms.hs+35−20

@@ -4,44 +4,59 @@

44-- Functions for replacing fully applied type synonyms

55--

66module Language.PureScript.TypeChecker.Synonyms

7− ( replaceAllTypeSynonyms

7+ ( SynonymMap

8+ , replaceAllTypeSynonyms

9+ , replaceAllTypeSynonymsM

810 ) where

911

10−import Prelude.Compat

12+import Prelude.Compat

1113

12−import Control.Monad.Error.Class (MonadError(..))

13−import Control.Monad.State

14−

15−import Data.Maybe (fromMaybe)

14+import Control.Monad.Error.Class (MonadError(..))

15+import Control.Monad.State

16+import Data.Maybe (fromMaybe)

1617import qualified Data.Map as M

17−

18−import Language.PureScript.Environment

19−import Language.PureScript.Errors

20−import Language.PureScript.TypeChecker.Monad

21−import Language.PureScript.Types

22−

23−-- |

24−-- Replace fully applied type synonyms.

25−--

26−replaceAllTypeSynonyms' :: Environment -> Type -> Either MultipleErrors Type

27−replaceAllTypeSynonyms' env = everywhereOnTypesTopDownM try

18+import Data.Text (Text)

19+import Language.PureScript.Environment

20+import Language.PureScript.Errors

21+import Language.PureScript.Kinds

22+import Language.PureScript.Names

23+import Language.PureScript.TypeChecker.Monad

24+import Language.PureScript.Types

25+

26+-- | Type synonym information (arguments with kinds, aliased type), indexed by name

27+type SynonymMap = M.Map (Qualified (ProperName 'TypeName)) ([(Text, Maybe Kind)], Type)

28+

29+replaceAllTypeSynonyms'

30+ :: SynonymMap

31+ -> Type

32+ -> Either MultipleErrors Type

33+replaceAllTypeSynonyms' syns = everywhereOnTypesTopDownM try

2834 where

2935 try :: Type -> Either MultipleErrors Type

3036 try t = fromMaybe t <$> go 0 [] t

3137

3238 go :: Int -> [Type] -> Type -> Either MultipleErrors (Maybe Type)

3339 go c args (TypeConstructor ctor)

34− | Just (synArgs, body) <- M.lookup ctor (typeSynonyms env)

40+ | Just (synArgs, body) <- M.lookup ctor syns

3541 , c == length synArgs

3642 = let repl = replaceAllTypeVars (zip (map fst synArgs) args) body

3743 in Just <$> try repl

38− | Just (synArgs, _) <- M.lookup ctor (typeSynonyms env)

44+ | Just (synArgs, _) <- M.lookup ctor syns

3945 , length synArgs > c

4046 = throwError . errorMessage $ PartiallyAppliedSynonym ctor

4147 go c args (TypeApp f arg) = go (c + 1) (arg : args) f

4248 go _ _ _ = return Nothing

4349

50+-- | Replace fully applied type synonyms

4451replaceAllTypeSynonyms :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m) => Type -> m Type

4552replaceAllTypeSynonyms d = do

4653 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