5e43eb1 · elk · git.iko.soy

src/AST/Type.hs+83−22

compare with master

unifiedsplit

@@ -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

2

8

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

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

4import Control.Arrow (second)

10import Control.Arrow (second)

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

11import Text.PrettyPrint as P

17import Text.PrettyPrint as P

12

18

13

19

20+-- DEFINITION

21+

14data Type var

22data Type var

15 = Lambda (Type var) (Type var)

23 = Lambda (Type var) (Type var)

16 | Var String

24 | Var String

17 | Type var

25 | Type var

18 | App (Type var) [Type var]

26 | App (Type var) [Type var]

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

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

20− | Aliased Var.Canonical (Type var)

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

21 deriving (Eq,Show)

29 deriving (Eq,Show)

22

30

23

31

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

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

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

53 in

61 in

54 App (Type name) types

62 App (Type name) types

55−

56

63

64+

65+-- DEALIASING

66+

57−dealias :: Type v -> Type v

67+deepDealias :: Type v -> Type v

58−dealias tipe =

68+deepDealias tipe =

69+ let go = deepDealias in

59 case tipe of

70 case tipe of

60− Lambda arg body ->

71+ Lambda a b ->

61− Lambda (dealias arg) (dealias body)

72+ Lambda (go a) (go b)

62

73

63 Var _ ->

74 Var _ ->

64 tipe

75 tipe

65

76

77+ Record fields ext ->

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

79+

80+ Aliased _name args tipe' ->

81+ dealias args tipe'

82+

66 Type _ ->

83 Type _ ->

67 tipe

84 tipe

68

85

69 App f args ->

86 App f args ->

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

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

71

88

72− Record fields ext ->

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

74

89

75− Aliased _ t ->

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

76− dealias t

91+dealias args tipe =

92+ replace (Map.fromList args) tipe

93+

77

94

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

78

121

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

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

80 pretty tipe =

123 pretty tipe =

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

127 prettyField (field, tipe) =

170 prettyField (field, tipe) =

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

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

129

172

130− Aliased name t ->

173+ Aliased name [] t ->

131 let t' = pretty t

174 let t' = pretty t

132 in

175 in

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

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

134 then t'

177 then t'

135 else pretty name

178 else pretty name

136

179

180+ Aliased name args _ ->

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

182+

137

183

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

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

139collectLambdas tipe =

185collectLambdas tipe =

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

151 where

197 where

152 needed t =

198 needed t =

153 case t of

199 case t of

154− Aliased _ t' -> needed t'

200+ Aliased _ [] _ -> False

201+

202+ Aliased _ _ _ -> True

155

203

156 Lambda _ _ -> True

204 Lambda _ _ -> True

157

205

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

180 in

228 in

181 (fields' ++ fields, ext')

229 (fields' ++ fields, ext')

182

230

183− Aliased _ tipe' ->

231+ Aliased _ _ tipe' ->

184 flattenRecord tipe'

232 flattenRecord tipe'

185

233

186 _ ->

234 _ ->

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

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

188

236

189

237

238+-- BINARY

239+

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

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

191 put tipe =

241 put tipe =

192 case tipe of

242 case tipe of

243+ Lambda t1 t2 ->

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

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

245+

246+ Var x ->

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

247+ putWord8 1 >> put x

248+

249+ Type name ->

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

250+ putWord8 2 >> put name

251+

252+ App t1 t2 ->

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

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

254+

255+ Record fs ext ->

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

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

257+

258+ Aliased var args t ->

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

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

199

260

200 get = do

261 get = do

201 n <- getWord8

262 n <- getWord8

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

205 2 -> Type <$> get

266 2 -> Type <$> get

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

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

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

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

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

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

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

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

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

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

26 Type.Record fields ext ->

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

28

29− Type.Aliased _ t ->

29+ Type.Aliased name args t ->

30− fromInternalType t

30+ fromInternalType (Type.dealias args t)

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

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

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

71 in

72 case tipe of

73− Aliased _ t ->

73+ Aliased _ args t ->

74− input name t

74+ input name (dealias args t)

75

76 App (Type signal) [t]

77 | Var.isStream signal ->

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

98 Var _ ->

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

100

101− Aliased _ t ->

101+ Aliased _ args t ->

102− toType t x

102+ toType (dealias args t) x

103

104 Type (Var.Canonical Var.BuiltIn name)

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

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

177 [ string name, fromTypeFunction t, value ]

178 in

179 case tipe of

180− Aliased _ t ->

180+ Aliased _ args t ->

181− output name t value

181+ output name (dealias args t) value

182

183 App (Type signal) [t]

184 | Var.isStream signal ->

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

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

200fromType tipe x =

201 case tipe of

202− Aliased _ t ->

202+ Aliased _ args t ->

203− fromType t x

203+ fromType (dealias args t) x

204

205 Lambda _ _

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

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

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

204 Type.Record fs ext ->

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

206

207− Type.Aliased _ t ->

207+ Type.Aliased _ args t ->

208− edges t

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

209

210

211addTypeAliases

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

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

1{-# OPTIONS_GHC -Wall #-}

2module Transform.Canonicalize.Type (tipe) where

3

4−import Control.Arrow (second)

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

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

6import Control.Monad.Error

5import Control.Monad.Error

7−import qualified Data.Map as Map

8import Data.Traversable (traverse)

6import Data.Traversable (traverse)

9

7

10import qualified AST.Type as T

8import qualified AST.Type as T

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

19 -> T.RawType

17 -> T.RawType

20 -> Canonicalizer String T.CanonicalType

18 -> Canonicalizer String T.CanonicalType

21tipe env typ =

19tipe env typ =

22− let go = tipe env in

20+ let go = tipe env

21+ goSnd (name,t) =

22+ (,) name <$> go t

23+ in

23 case typ of

24 case typ of

24 T.Var x ->

25 T.Var x ->

25 return (T.Var x)

26 return (T.Var x)

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

33 T.Lambda a b ->

34 T.Lambda a b ->

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

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

35

36

36− T.Aliased name t ->

37+ T.Aliased name args t ->

37− T.Aliased name <$> go t

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

38

39

39 T.Record fields ext ->

40 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

43

42

44

43

45canonicalizeApp

44canonicalizeApp

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

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

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

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

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

75 tipes' <- mapM (tipe env) tipes

74 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

78 where

76 where

79 tipesLen = length tipes

77 tipesLen = length tipes

80 tvarsLen = length tvars

78 tvarsLen = length tvars

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

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

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

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

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

86 " but was given " ++ show tipesLen

84 " 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 =

130 in

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

132

133− T.Aliased _ t ->

133+ T.Aliased _ args t ->

134− freeVars t

134+ freeVars (T.dealias args t)

135

136 undeclared tvars tipes =

137 Set.difference used declared

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

194 T.Record fields _ ->

195 any (infinite . snd) fields

196

197− T.Aliased _ t ->

197+ T.Aliased _ args t ->

198− infinite t

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

199

200 indented :: D.ValidDecl -> Doc

201 indented decl =

src/Transform/Declaration.hs+6−4

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

80 _ ->

81 Left (errorMessage "output" name)

82

83− D.LoopbackDefinition name tipe ->

83+ D.LoopbackDefinition name _tipe ->

84 Left (errorMessage "loopback" name)

85

86 D.LoopbackAnnotation name tipe ->

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

115 in

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

117

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

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

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

120 where

121+ result =

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

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

122

123

124+ args =

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

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

124

126

125 var = A.none . E.localVar

127 var = A.none . E.localVar

126 vars = take (length args) arguments

128 vars = take (length args) arguments

src/Type/Environment.hs+49−28

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

7import qualified Control.Monad.State as State

8import qualified Data.Traversable as Traverse

9import qualified Data.Map as Map

10+import qualified Data.Set as Set

10import Data.List (isPrefixOf)

11import Data.List (isPrefixOf)

11import qualified Text.PrettyPrint as PP

12import qualified Text.PrettyPrint as PP

12

13

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

150 -> T.CanonicalType

151 -> T.CanonicalType

151 -> State.StateT VarDict IO Type

152 -> State.StateT VarDict IO Type

152instantiator env sourceType =

153instantiator env sourceType =

153− go sourceType

154+ instantiatorHelp env Set.empty sourceType

154− where

155+

156+

157+instantiatorHelp

158+ :: Environment

159+ -> Set.Set String

160+ -> T.CanonicalType

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

161+ -> State.StateT VarDict IO Type

156− go sourceType =

162+instantiatorHelp env aliasVars sourceType =

163+ let go = instantiatorHelp env aliasVars

164+ in

157− case sourceType of

165+ case sourceType of

158− T.Lambda t1 t2 ->

166+ T.Lambda t1 t2 ->

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

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

160

168

161− T.Var x ->

169+ T.Var x ->

162 do dict <- State.get

170 do dict <- State.get

171+ case Set.member x aliasVars of

172+ True ->

173+ return (PlaceHolder x)

174+ False ->

163− case Map.lookup x dict of

175+ case Map.lookup x dict of

176+ Just v ->

164− Just v -> return (varN v)

177+ return (varN v)

178+

165− Nothing ->

179+ Nothing ->

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

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

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

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

168− return (varN v)

182+ return (varN v)

169− where

183+ where

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

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

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

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

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

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

173− | otherwise = Flexible

187+ | otherwise = Flexible

174−

188+

175− T.Aliased name t ->

189+ T.Aliased name args aliasedType ->

176− do t' <- go t

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

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

177− case t' of

192+ case aliasedType' of

193+ PlaceHolder x ->

194+ return (PlaceHolder x)

195+

196+ VarN _ v ->

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

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

198+

199+ TermN _ t ->

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

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

180−

201+

181− T.Type name ->

202+ T.Type name ->

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

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

183 Just t -> return t

204 Just t -> return t

184 Nothing ->

205 Nothing ->

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

186 "Could not find type constructor '" ++

207 "Could not find type constructor '" ++

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

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

188

209

189− T.App t ts ->

210+ T.App t ts ->

190 do t' <- go t

211 do t' <- go t

191 ts' <- mapM go ts

212 ts' <- mapM go ts

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

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

193

214

194− T.Record fields ext ->

215+ T.Record fields ext ->

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

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

196 ext' <-

217 ext' <-

197 case ext of

218 case ext of

src/Type/ExtraChecks.hs+20−11

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

49 return env

50

51 Just typeOfMain ->

52− let tipe = ST.dealias typeOfMain

52+ let tipe = ST.deepDealias typeOfMain

53 in

54 if tipe `elem` validMainTypes

55 then return env

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

139 -> Either [P.Doc] ()

140checkWiresHelp direction name rootType tipe =

141 case tipe of

142− ST.Aliased _ t ->

142+ ST.Aliased _ args t ->

143− checkWiresHelp direction name rootType t

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

144

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

146 | Var.isStream signal ->

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

172 throw (wireError name direction rootType tipe kind)

173 in

174 case tipe of

175− ST.Aliased _ t ->

175+ ST.Aliased _ args t ->

176− valid t

176+ valid (ST.dealias args t)

177

178 ST.Type v ->

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

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

261

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

263checkLoobacksHelp name rootType tipe hasExpr =

264− case ST.dealias tipe of

264+ case ST.deepDealias tipe of

265 ST.Record

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

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

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

323 Nothing -> return []

324 Just struct ->

325 case struct of

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

326+ TT.App1 a b ->

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

328+

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

329+ TT.Fun1 a b ->

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

331+

328− TT.Var1 a -> go a

332+ TT.Var1 a ->

333+ go a

334+

329− TT.EmptyRecord1 -> return []

335+ TT.EmptyRecord1 ->

336+ return []

337+

338+ TT.Record1 fields ext ->

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

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

src/Type/State.hs+26−5

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

1{-# LANGUAGE FlexibleContexts #-}

2module Type.State where

3

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

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

5import Control.Monad.State

6+import Data.Map ((!))

6import qualified Data.Map as Map

7import qualified Data.Map as Map

7import qualified Data.Traversable as Traversable

8import qualified Data.Traversable as Traversable

8import qualified Data.UnionFind.IO as UF

9import qualified Data.UnionFind.IO as UF

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

119

120

120flatten :: Type -> StateT SolverState IO Variable

121flatten :: Type -> StateT SolverState IO Variable

121flatten term =

122flatten term =

123+ flattenHelp Map.empty term

124+

125+

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

127+flattenHelp aliasDict term =

122 case term of

128 case term of

129+ PlaceHolder name ->

130+ return (aliasDict ! name)

131+

123 VarN maybeAlias v ->

132 VarN maybeAlias v ->

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

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

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

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

125 return v

136 return v

126

137

127− TermN maybeAlias t ->

138+ TermN maybeAlias subTerm ->

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

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

128− do flatStructure <- traverseTerm flatten t

141+ flatStructure <- traverseTerm (flattenHelp localDict) subTerm

129 pool <- getPool

142 pool <- getPool

130 var <-

143 var <-

131 liftIO . UF.fresh $ Descriptor

144 liftIO . UF.fresh $ Descriptor

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

135 , name = Nothing

148 , name = Nothing

136 , copy = Nothing

149 , copy = Nothing

137 , mark = noMark

150 , mark = noMark

138− , alias = maybeAlias

151+ , alias = maybeAlias'

139 }

152 }

140 register var

153 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+

141

162

142

163

143makeInstance :: Variable -> StateT SolverState IO Variable

164makeInstance :: Variable -> StateT SolverState IO Variable

src/Type/Type.hs+31−11

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

27

28type TypeScheme = Scheme Type Variable

29

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

31+

30

32

31-- TYPE PRIMITIVES

33-- TYPE PRIMITIVES

32

34

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

39

41

40

42

41data TermN a

43data TermN a

42− = VarN (Maybe Var.Canonical) a

44+ = PlaceHolder String

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

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

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

44

47

45

48

46varN :: a -> TermN a

49varN :: a -> TermN a

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

67 , name :: Maybe TypeName

70 , name :: Maybe TypeName

68 , copy :: Maybe Variable

71 , copy :: Maybe Variable

69 , mark :: Int

72 , mark :: Int

70− , alias :: Maybe Var.Canonical

73+ , alias :: Alias Variable

71 }

74 }

72

75

73noRank :: Int

76noRank :: Int

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

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

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

263 pretty when term =

266 pretty when term =

264 case term of

267 case term of

268+ PlaceHolder _ ->

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

270+

265 VarN alias x ->

271 VarN alias x ->

266 either alias (pretty when x)

272 either alias (pretty when x)

267

273

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

270 where

276 where

271 either maybeAlias doc =

277 either maybeAlias doc =

272 case maybeAlias of

278 case maybeAlias of

273− Just alias -> PP.pretty alias

274 Nothing -> doc

279 Nothing -> doc

280+ Just (name, args) ->

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

275

282

276

283

277instance PrettyType Descriptor where

284instance PrettyType Descriptor where

278 pretty when desc =

285 pretty when desc =

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

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

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

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

281− PP.pretty name

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

282

289

283 (_, Just term, _) ->

290 (_, Just term, _) ->

284 pretty when term

291 pretty when term

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

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

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

439 crawl nextState tipe =

446 crawl nextState tipe =

440 case tipe of

447 case tipe of

448+ PlaceHolder name ->

449+ return (PlaceHolder name)

450+

441 VarN a x ->

451 VarN a x ->

442 VarN a <$> crawl nextState x

452 VarN a <$> crawl nextState x

443

453

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

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

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

485

495

486

496

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

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

487toSrcType :: Variable -> IO T.CanonicalType

499toSrcType :: Variable -> IO T.CanonicalType

488toSrcType var =

500toSrcType var =

489 go =<< addNames var

501 go =<< addNames var

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

491 go v =

503 go v =

492 do desc <- UF.descriptor v

504 do desc <- UF.descriptor v

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

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

495

513

496 backupSrcType :: Descriptor -> IO T.CanonicalType

514 backupSrcType :: Descriptor -> IO T.CanonicalType

497 backupSrcType desc =

515 backupSrcType desc =

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

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

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

543

561

544 dealias :: T.CanonicalType -> T.CanonicalType

562 dealias :: T.CanonicalType -> T.CanonicalType

545− dealias t =

563+ dealias tipe =

546− case t of

564+ case tipe of

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

565+ T.Aliased _ args tipe' ->

566+ T.dealias args tipe'

548− _ -> t

567+ _ ->

568+ tipe

549

569

550

570

551data AppStructure

571data AppStructure

src/Type/Unify.hs+2−2

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

361combinedDescriptors

362 :: Descriptor

363 -> Descriptor

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

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

365combinedDescriptors desc1 desc2 =

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

367 where

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

369 rank' =

370 min (rank desc1) (rank desc2)

371

372− alias' :: Maybe Var.Canonical

372+ alias' :: Alias Variable

373 alias' =

374 alias desc1 <|> alias desc2

375