5e43eb1 · elk · git.iko.soy

src/AST/Type.hs+83−22

@@ -1,4 +1,10 @@

1−module AST.Type where

1+module AST.Type

2+ ( Type(..), RawType, CanonicalType

3+ , fieldMap, recordOf, listOf, tupleOf

4+ , deepDealias, dealias

5+ , collectLambdas

6+ , prettyParens

7+ ) where

28

39import Control.Applicative ((<$>), (<*>))

410import Control.Arrow (second)

@@ -11,13 +17,15 @@ import qualified AST.Helpers as Help

1117import Text.PrettyPrint as P

1218

1319

20+-- DEFINITION

21+

1422data Type var

1523 = Lambda (Type var) (Type var)

1624 | Var String

1725 | Type var

1826 | App (Type var) [Type var]

1927 | Record [(String, Type var)] (Maybe (Type var))

20− | Aliased Var.Canonical (Type var)

28+ | Aliased Var.Canonical [(String, Type var)] (Type var)

2129 deriving (Eq,Show)

2230

2331

@@ -52,29 +60,64 @@ tupleOf types =

5260 let name = Var.Raw ("_Tuple" ++ show (length types))

5361 in

5462 App (Type name) types

55−

5663

57−dealias :: Type v -> Type v

58−dealias tipe =

64+

65+-- DEALIASING

66+

67+deepDealias :: Type v -> Type v

68+deepDealias tipe =

69+ let go = deepDealias in

5970 case tipe of

60− Lambda arg body ->

61− Lambda (dealias arg) (dealias body)

71+ Lambda a b ->

72+ Lambda (go a) (go b)

6273

6374 Var _ ->

6475 tipe

6576

77+ Record fields ext ->

78+ Record (map (second go) fields) (fmap go ext)

79+

80+ Aliased _name args tipe' ->

81+ dealias args tipe'

82+

6683 Type _ ->

6784 tipe

6885

6986 App f args ->

70− App (dealias f) (map dealias args)

87+ App (go f) (map go args)

7188

72− Record fields ext ->

73− Record (map (second dealias) fields) (fmap dealias ext)

7489

75− Aliased _ t ->

76− dealias t

90+dealias :: [(String, Type v)] -> Type v -> Type v

91+dealias args tipe =

92+ replace (Map.fromList args) tipe

93+

7794

95+replace :: Map.Map String (Type var) -> Type var -> Type var

96+replace typeTable t =

97+ let go = replace typeTable in

98+ case t of

99+ Lambda a b ->

100+ Lambda (go a) (go b)

101+

102+ Var x ->

103+ Map.findWithDefault t x typeTable

104+

105+ Record fields ext ->

106+ Record (map (second go) fields) (fmap go ext)

107+

108+ Aliased original args t' ->

109+ let typeTable' = foldr Map.delete typeTable (map fst args)

110+ in

111+ Aliased original (map (second go) args) (replace typeTable' t')

112+

113+ Type _ ->

114+ t

115+

116+ App f args ->

117+ App (go f) (map go args)

118+

119+

120+-- PRETTY PRINTING

78121

79122instance (Var.ToString var, Pretty var) => Pretty (Type var) where

80123 pretty tipe =

@@ -127,13 +170,16 @@ instance (Var.ToString var, Pretty var) => Pretty (Type var) where

127170 prettyField (field, tipe) =

128171 P.text field <+> P.text ":" <+> pretty tipe

129172

130− Aliased name t ->

173+ Aliased name [] t ->

131174 let t' = pretty t

132175 in

133176 if show t' `elem` ["Int", "Float", "String", "Char", "Bool"]

134177 then t'

135178 else pretty name

136179

180+ Aliased name args _ ->

181+ P.hang (pretty name) 2 (P.sep (map (prettyParens . snd) args))

182+

137183

138184collectLambdas :: Type var -> [Type var]

139185collectLambdas tipe =

@@ -151,7 +197,9 @@ prettyParens tipe =

151197 where

152198 needed t =

153199 case t of

154− Aliased _ t' -> needed t'

200+ Aliased _ [] _ -> False

201+

202+ Aliased _ _ _ -> True

155203

156204 Lambda _ _ -> True

157205

@@ -180,22 +228,35 @@ flattenRecord tipe =

180228 in

181229 (fields' ++ fields, ext')

182230

183− Aliased _ tipe' ->

231+ Aliased _ _ tipe' ->

184232 flattenRecord tipe'

185233

186234 _ ->

187235 error "Trying to flatten ill-formed record."

188236

189237

238+-- BINARY

239+

190240instance Binary var => Binary (Type var) where

191241 put tipe =

192242 case tipe of

193− Lambda t1 t2 -> putWord8 0 >> put t1 >> put t2

194− Var x -> putWord8 1 >> put x

195− Type name -> putWord8 2 >> put name

196− App t1 t2 -> putWord8 3 >> put t1 >> put t2

197− Record fs ext -> putWord8 4 >> put fs >> put ext

198− Aliased var t -> putWord8 5 >> put var >> put t

243+ Lambda t1 t2 ->

244+ putWord8 0 >> put t1 >> put t2

245+

246+ Var x ->

247+ putWord8 1 >> put x

248+

249+ Type name ->

250+ putWord8 2 >> put name

251+

252+ App t1 t2 ->

253+ putWord8 3 >> put t1 >> put t2

254+

255+ Record fs ext ->

256+ putWord8 4 >> put fs >> put ext

257+

258+ Aliased var args t ->

259+ putWord8 5 >> put var >> put args >> put t

199260

200261 get = do

201262 n <- getWord8

@@ -205,5 +266,5 @@ instance Binary var => Binary (Type var) where

205266 2 -> Type <$> get

206267 3 -> App <$> get <*> get

207268 4 -> Record <$> get <*> get

208− 5 -> Aliased <$> get <*> get

269+ 5 -> Aliased <$> get <*> get <*> get

209270 _ -> error "Error reading a valid type from serialized string"

src/Elm/Compiler/Type/Extract.hs+2−2

@@ -26,5 +26,5 @@ fromInternalType astType =

2626 Type.Record fields ext ->

2727 T.Record (map (second fromInternalType) fields) (fmap fromInternalType ext)

2828

29− Type.Aliased _ t ->

30− fromInternalType t

29+ Type.Aliased name args t ->

30+ fromInternalType (Type.dealias args t)

src/Generate/JavaScript/Foreign.hs+8−8

@@ -70,8 +70,8 @@ input name tipe =

7070 [ string name, string (show (pretty t)), toTypeFunction t ]

7171 in

7272 case tipe of

73− Aliased _ t ->

74− input name t

73+ Aliased _ args t ->

74+ input name (dealias args t)

7575

7676 App (Type signal) [t]

7777 | Var.isStream signal ->

@@ -98,8 +98,8 @@ toType tipe x =

9898 Var _ ->

9999 error "type variables should not be allowed through input ports"

100100

101− Aliased _ t ->

102− toType t x

101+ Aliased _ args t ->

102+ toType (dealias args t) x

103103

104104 Type (Var.Canonical Var.BuiltIn name)

105105 | name == "Int" -> from JSNumber

@@ -177,8 +177,8 @@ output name tipe value =

177177 [ string name, fromTypeFunction t, value ]

178178 in

179179 case tipe of

180− Aliased _ t ->

181− output name t value

180+ Aliased _ args t ->

181+ output name (dealias args t) value

182182

183183 App (Type signal) [t]

184184 | Var.isStream signal ->

@@ -199,8 +199,8 @@ fromTypeFunction tipe =

199199fromType :: CanonicalType -> Expression () -> Expression ()

200200fromType tipe x =

201201 case tipe of

202− Aliased _ t ->

203− fromType t x

202+ Aliased _ args t ->

203+ fromType (dealias args t) x

204204

205205 Lambda _ _

206206 | numArgs > 1 && numArgs < 10 ->

src/Transform/Canonicalize/Setup.hs+2−2

@@ -204,8 +204,8 @@ node name tvars alias =

204204 Type.Record fs ext ->

205205 maybe [] edges ext ++ concatMap (edges . snd) fs

206206

207− Type.Aliased _ t ->

208− edges t

207+ Type.Aliased _ args t ->

208+ edges t ++ concatMap (edges . snd) args

209209

210210

211211addTypeAliases

src/Transform/Canonicalize/Type.hs+8−32

@@ -1,10 +1,8 @@

11{-# OPTIONS_GHC -Wall #-}

22module Transform.Canonicalize.Type (tipe) where

33

4−import Control.Arrow (second)

54import Control.Applicative ((<$>),(<*>))

65import Control.Monad.Error

7−import qualified Data.Map as Map

86import Data.Traversable (traverse)

97

108import qualified AST.Type as T

@@ -19,7 +17,10 @@ tipe

1917 -> T.RawType

2018 -> Canonicalizer String T.CanonicalType

2119tipe env typ =

22− let go = tipe env in

20+ let go = tipe env

21+ goSnd (name,t) =

22+ (,) name <$> go t

23+ in

2324 case typ of

2425 T.Var x ->

2526 return (T.Var x)

@@ -33,13 +34,11 @@ tipe env typ =

3334 T.Lambda a b ->

3435 T.Lambda <$> go a <*> go b

3536

36− T.Aliased name t ->

37− T.Aliased name <$> go t

37+ T.Aliased name args t ->

38+ T.Aliased name <$> mapM goSnd args <*> go t

3839

3940 T.Record fields ext ->

40− let go' (f,t) = (,) f <$> go t

41− in

42− T.Record <$> mapM go' fields <*> traverse go ext

41+ T.Record <$> mapM goSnd fields <*> traverse go ext

4342

4443

4544canonicalizeApp

@@ -73,8 +72,7 @@ canonicalizeAlias

7372canonicalizeAlias env (name, tvars, dealiasedTipe) tipes =

7473 do when (tipesLen /= tvarsLen) (throwError msg)

7574 tipes' <- mapM (tipe env) tipes

76− let tipe' = replace (Map.fromList (zip tvars tipes')) dealiasedTipe

77− return $ T.Aliased name tipe'

75+ return $ T.Aliased name (zip tvars tipes') dealiasedTipe

7876 where

7977 tipesLen = length tipes

8078 tvarsLen = length tvars

@@ -84,25 +82,3 @@ canonicalizeAlias env (name, tvars, dealiasedTipe) tipes =

8482 "Type alias '" ++ Var.toString name ++ "' expects " ++ show tvarsLen ++

8583 " type argument" ++ (if tvarsLen == 1 then "" else "s") ++

8684 " but was given " ++ show tipesLen

87−

88− replace :: Map.Map String T.CanonicalType -> T.CanonicalType -> T.CanonicalType

89− replace typeTable t =

90− let go = replace typeTable in

91− case t of

92− T.Lambda a b ->

93− T.Lambda (go a) (go b)

94−

95− T.Var x ->

96− Map.findWithDefault t x typeTable

97−

98− T.Record fields ext ->

99− T.Record (map (second go) fields) (fmap go ext)

100−

101− T.Aliased original t' ->

102− T.Aliased original (go t')

103−

104− T.Type _ ->

105− t

106−

107− T.App f args ->

108− T.App (go f) (map go args)

src/Transform/Check.hs+4−4

@@ -130,8 +130,8 @@ illFormedTypeDecls decls =

130130 in

131131 Set.unions (ext' : map (freeVars . snd) fields)

132132

133− T.Aliased _ t ->

134− freeVars t

133+ T.Aliased _ args t ->

134+ freeVars (T.dealias args t)

135135

136136 undeclared tvars tipes =

137137 Set.difference used declared

@@ -194,8 +194,8 @@ infiniteTypeAliases decls =

194194 T.Record fields _ ->

195195 any (infinite . snd) fields

196196

197− T.Aliased _ t ->

198− infinite t

197+ T.Aliased _ args t ->

198+ infinite t || any (infinite . snd) args

199199

200200 indented :: D.ValidDecl -> Doc

201201 indented decl =

src/Transform/Declaration.hs+6−4

@@ -80,7 +80,7 @@ combineAnnotations =

8080 _ ->

8181 Left (errorMessage "output" name)

8282

83− D.LoopbackDefinition name tipe ->

83+ D.LoopbackDefinition name _tipe ->

8484 Left (errorMessage "loopback" name)

8585

8686 D.LoopbackAnnotation name tipe ->

@@ -115,12 +115,14 @@ toDefs moduleName decl =

115115 in

116116 [ definition ctor (buildFunction body vars) (foldr T.Lambda tbody tipes) ]

117117

118− D.TypeAlias name _ tipe@(T.Record fields ext) ->

118+ D.TypeAlias name tvars tipe@(T.Record fields ext) ->

119119 [ definition name (buildFunction record vars) (foldr T.Lambda result args) ]

120120 where

121− result = T.Aliased (typeVar name) tipe

121+ result =

122+ T.Aliased (typeVar name) (zip tvars (map T.Var tvars)) tipe

122123

123− args = map snd fields ++ maybe [] (:[]) ext

124+ args =

125+ map snd fields ++ maybe [] (:[]) ext

124126

125127 var = A.none . E.localVar

126128 vars = take (length args) arguments

src/Type/Environment.hs+49−28

@@ -7,6 +7,7 @@ import Control.Monad.Error (ErrorT, throwError, liftIO)

77import qualified Control.Monad.State as State

88import qualified Data.Traversable as Traverse

99import qualified Data.Map as Map

10+import qualified Data.Set as Set

1011import Data.List (isPrefixOf)

1112import qualified Text.PrettyPrint as PP

1213

@@ -150,35 +151,55 @@ instantiator

150151 -> T.CanonicalType

151152 -> State.StateT VarDict IO Type

152153instantiator env sourceType =

153− go sourceType

154− where

155− go :: T.CanonicalType -> State.StateT VarDict IO Type

156− go sourceType =

157− case sourceType of

158− T.Lambda t1 t2 ->

154+ instantiatorHelp env Set.empty sourceType

155+

156+

157+instantiatorHelp

158+ :: Environment

159+ -> Set.Set String

160+ -> T.CanonicalType

161+ -> State.StateT VarDict IO Type

162+instantiatorHelp env aliasVars sourceType =

163+ let go = instantiatorHelp env aliasVars

164+ in

165+ case sourceType of

166+ T.Lambda t1 t2 ->

159167 (==>) <$> go t1 <*> go t2

160168

161− T.Var x ->

169+ T.Var x ->

162170 do dict <- State.get

163− case Map.lookup x dict of

164− Just v -> return (varN v)

165− Nothing ->

166− do v <- State.liftIO $ namedVar flex (V.local x)

167− State.put (Map.insert x v dict)

168− return (varN v)

169− where

170− flex | "number" `isPrefixOf` x = Is Number

171− | "comparable" `isPrefixOf` x = Is Comparable

172− | "appendable" `isPrefixOf` x = Is Appendable

173− | otherwise = Flexible

174−

175− T.Aliased name t ->

176− do t' <- go t

177− case t' of

178− VarN _ v -> return (VarN (Just name) v)

179− TermN _ term -> return (TermN (Just name) term)

180−

181− T.Type name ->

171+ case Set.member x aliasVars of

172+ True ->

173+ return (PlaceHolder x)

174+ False ->

175+ case Map.lookup x dict of

176+ Just v ->

177+ return (varN v)

178+

179+ Nothing ->

180+ do v <- State.liftIO $ namedVar flex (V.local x)

181+ State.put (Map.insert x v dict)

182+ return (varN v)

183+ where

184+ flex | "number" `isPrefixOf` x = Is Number

185+ | "comparable" `isPrefixOf` x = Is Comparable

186+ | "appendable" `isPrefixOf` x = Is Appendable

187+ | otherwise = Flexible

188+

189+ T.Aliased name args aliasedType ->

190+ do args' <- mapM (\(arg,tipe) -> (,) arg <$> go tipe) args

191+ aliasedType' <- instantiatorHelp env (Set.fromList (map fst args)) aliasedType

192+ case aliasedType' of

193+ PlaceHolder x ->

194+ return (PlaceHolder x)

195+

196+ VarN _ v ->

197+ return (VarN (Just (name,args')) v)

198+

199+ TermN _ t ->

200+ return (TermN (Just (name, args')) t)

201+

202+ T.Type name ->

182203 case Map.lookup (V.toString name) (types env) of

183204 Just t -> return t

184205 Nothing ->

@@ -186,12 +207,12 @@ instantiator env sourceType =

186207 "Could not find type constructor '" ++

187208 V.toString name ++ "' while checking types."

188209

189− T.App t ts ->

210+ T.App t ts ->

190211 do t' <- go t

191212 ts' <- mapM go ts

192213 return $ foldl (<|) t' ts'

193214

194− T.Record fields ext ->

215+ T.Record fields ext ->

195216 do fields' <- Traverse.traverse (mapM go) (T.fieldMap fields)

196217 ext' <-

197218 case ext of

src/Type/ExtraChecks.hs+20−11

@@ -49,7 +49,7 @@ mainCheck env =

4949 return env

5050

5151 Just typeOfMain ->

52− let tipe = ST.dealias typeOfMain

52+ let tipe = ST.deepDealias typeOfMain

5353 in

5454 if tipe `elem` validMainTypes

5555 then return env

@@ -139,8 +139,8 @@ checkWiresHelp

139139 -> Either [P.Doc] ()

140140checkWiresHelp direction name rootType tipe =

141141 case tipe of

142− ST.Aliased _ t ->

143− checkWiresHelp direction name rootType t

142+ ST.Aliased _ args t ->

143+ checkWiresHelp direction name rootType (ST.dealias args t)

144144

145145 ST.App (ST.Type signal) [t]

146146 | Var.isStream signal ->

@@ -172,8 +172,8 @@ validWireType seenFunc seenSignal direction name rootType tipe =

172172 throw (wireError name direction rootType tipe kind)

173173 in

174174 case tipe of

175− ST.Aliased _ t ->

176− valid t

175+ ST.Aliased _ args t ->

176+ valid (ST.dealias args t)

177177

178178 ST.Type v ->

179179 case any ($ v) [ Var.isJson, Var.isPrimitive, Var.isTuple ] of

@@ -261,7 +261,7 @@ checkLoobacks name tipe hasExpr =

261261

262262checkLoobacksHelp :: String -> ST.CanonicalType -> ST.CanonicalType -> Bool -> Either [P.Doc] ()

263263checkLoobacksHelp name rootType tipe hasExpr =

264− case ST.dealias tipe of

264+ case ST.deepDealias tipe of

265265 ST.Record

266266 [ ("mailbox", ST.App (ST.Type mailbox) [a])

267267 , ("stream", ST.App (ST.Type stream) [b])

@@ -323,8 +323,17 @@ occurs (name, variable) =

323323 Nothing -> return []

324324 Just struct ->

325325 case struct of

326− TT.App1 a b -> (++) <$> go a <*> go b

327− TT.Fun1 a b -> (++) <$> go a <*> go b

328− TT.Var1 a -> go a

329− TT.EmptyRecord1 -> return []

330− TT.Record1 fields ext -> concat <$> mapM go (ext : concat (Map.elems fields))

326+ TT.App1 a b ->

327+ (++) <$> go a <*> go b

328+

329+ TT.Fun1 a b ->

330+ (++) <$> go a <*> go b

331+

332+ TT.Var1 a ->

333+ go a

334+

335+ TT.EmptyRecord1 ->

336+ return []

337+

338+ TT.Record1 fields ext ->

339+ concat <$> mapM go (ext : concat (Map.elems fields))

src/Type/State.hs+26−5

@@ -1,8 +1,9 @@

11{-# LANGUAGE FlexibleContexts #-}

22module Type.State where

33

4−import Control.Applicative ( (<$>), (<*>), Applicative, (<|>) )

4+import Control.Applicative ( Applicative, (<$>), (<*>), (<|>) )

55import Control.Monad.State

6+import Data.Map ((!))

67import qualified Data.Map as Map

78import qualified Data.Traversable as Traversable

89import qualified Data.UnionFind.IO as UF

@@ -119,13 +120,25 @@ introduce variable =

119120

120121flatten :: Type -> StateT SolverState IO Variable

121122flatten term =

123+ flattenHelp Map.empty term

124+

125+

126+flattenHelp :: Map.Map String Variable -> Type -> StateT SolverState IO Variable

127+flattenHelp aliasDict term =

122128 case term of

129+ PlaceHolder name ->

130+ return (aliasDict ! name)

131+

123132 VarN maybeAlias v ->

124− do liftIO $ UF.modifyDescriptor v $ \desc -> desc { alias = maybeAlias <|> alias desc }

133+ do maybeAlias' <- Traversable.traverse flattenAlias maybeAlias

134+ liftIO $ UF.modifyDescriptor v $ \desc ->

135+ desc { alias = maybeAlias' <|> alias desc }

125136 return v

126137

127− TermN maybeAlias t ->

128− do flatStructure <- traverseTerm flatten t

138+ TermN maybeAlias subTerm ->

139+ do maybeAlias' <- Traversable.traverse flattenAlias maybeAlias

140+ let localDict = maybe aliasDict (Map.fromList . snd) maybeAlias'

141+ flatStructure <- traverseTerm (flattenHelp localDict) subTerm

129142 pool <- getPool

130143 var <-

131144 liftIO . UF.fresh $ Descriptor

@@ -135,9 +148,17 @@ flatten term =

135148 , name = Nothing

136149 , copy = Nothing

137150 , mark = noMark

138− , alias = maybeAlias

151+ , alias = maybeAlias'

139152 }

140153 register var

154+ where

155+ flattenAlias (name, args) =

156+ let flattenPair (arg, subTerm) =

157+ (,) arg <$> flattenHelp aliasDict subTerm

158+ in

159+ (,) name <$> mapM flattenPair args

160+

161+

141162

142163

143164makeInstance :: Variable -> StateT SolverState IO Variable

src/Type/Type.hs+31−11

@@ -27,6 +27,8 @@ type TypeConstraint = Constraint Type Variable

2727

2828type TypeScheme = Scheme Type Variable

2929

30+type Alias a = Maybe (Var.Canonical, [(String,a)])

31+

3032

3133-- TYPE PRIMITIVES

3234

@@ -39,8 +41,9 @@ data Term1 a

3941

4042

4143data TermN a

42− = VarN (Maybe Var.Canonical) a

43− | TermN (Maybe Var.Canonical) (Term1 (TermN a))

44+ = PlaceHolder String

45+ | VarN (Alias (TermN a)) a

46+ | TermN (Alias (TermN a)) (Term1 (TermN a))

4447

4548

4649varN :: a -> TermN a

@@ -67,7 +70,7 @@ data Descriptor = Descriptor

6770 , name :: Maybe TypeName

6871 , copy :: Maybe Variable

6972 , mark :: Int

70− , alias :: Maybe Var.Canonical

73+ , alias :: Alias Variable

7174 }

7275

7376noRank :: Int

@@ -262,6 +265,9 @@ instance PrettyType a => PrettyType (Term1 a) where

262265instance PrettyType a => PrettyType (TermN a) where

263266 pretty when term =

264267 case term of

268+ PlaceHolder _ ->

269+ error "problem prettifying type, probably indicates a bigger problem"

270+

265271 VarN alias x ->

266272 either alias (pretty when x)

267273

@@ -270,15 +276,16 @@ instance PrettyType a => PrettyType (TermN a) where

270276 where

271277 either maybeAlias doc =

272278 case maybeAlias of

273− Just alias -> PP.pretty alias

274279 Nothing -> doc

280+ Just (name, args) ->

281+ P.hang (PP.pretty name) 2 (P.sep (map (pretty App . snd) args))

275282

276283

277284instance PrettyType Descriptor where

278285 pretty when desc =

279286 case (alias desc, structure desc, name desc) of

280− (Just name, _, _) ->

281− PP.pretty name

287+ (Just (name, args), _, _) ->

288+ P.hang (PP.pretty name) 4 (P.sep (map (pretty App . snd) args))

282289

283290 (_, Just term, _) ->

284291 pretty when term

@@ -438,6 +445,9 @@ instance (Crawl t, Crawl v) => Crawl (Scheme t v) where

438445instance Crawl t => Crawl (TermN t) where

439446 crawl nextState tipe =

440447 case tipe of

448+ PlaceHolder name ->

449+ return (PlaceHolder name)

450+

441451 VarN a x ->

442452 VarN a <$> crawl nextState x

443453

@@ -484,6 +494,8 @@ instance Crawl Descriptor where

484494 return $ desc { name = name', structure = structure' }

485495

486496

497+-- TODO: Attach resulting type to the descriptor so that you

498+-- never have to do extra work, particularly nice for aliased types

487499toSrcType :: Variable -> IO T.CanonicalType

488500toSrcType var =

489501 go =<< addNames var

@@ -491,7 +503,13 @@ toSrcType var =

491503 go v =

492504 do desc <- UF.descriptor v

493505 srcType <- maybe (backupSrcType desc) termToSrcType (structure desc)

494− return $ maybe srcType (\name -> T.Aliased name srcType) (alias desc)

506+ case alias desc of

507+ Nothing ->

508+ return srcType

509+

510+ Just (name, args) ->

511+ do args' <- mapM (\(arg,tvar) -> (,) arg <$> go tvar) args

512+ return (T.Aliased name args' srcType)

495513

496514 backupSrcType :: Descriptor -> IO T.CanonicalType

497515 backupSrcType desc =

@@ -542,10 +560,12 @@ toSrcType var =

542560 _ -> error "Used toSrcType on a type that is not well-formed"

543561

544562 dealias :: T.CanonicalType -> T.CanonicalType

545− dealias t =

546− case t of

547− T.Aliased _ t' -> t'

548− _ -> t

563+ dealias tipe =

564+ case tipe of

565+ T.Aliased _ args tipe' ->

566+ T.dealias args tipe'

567+ _ ->

568+ tipe

549569

550570

551571data AppStructure

src/Type/Unify.hs+2−2

@@ -361,7 +361,7 @@ fieldMismatchError missingFields =

361361combinedDescriptors

362362 :: Descriptor

363363 -> Descriptor

364− -> (Maybe Var.Canonical, Flex, Int, Maybe Var.Canonical)

364+ -> (Maybe Var.Canonical, Flex, Int, Alias Variable)

365365combinedDescriptors desc1 desc2 =

366366 (name', flex', rank', alias')

367367 where

@@ -369,7 +369,7 @@ combinedDescriptors desc1 desc2 =

369369 rank' =

370370 min (rank desc1) (rank desc2)

371371

372− alias' :: Maybe Var.Canonical

372+ alias' :: Alias Variable

373373 alias' =

374374 alias desc1 <|> alias desc2

375375