a28acb2 · elk · git.iko.soy

git.iko.soy/elk

on master help sign in

Better model of types in Type.Type

a28acb2Evan Czaplicki11 years ago

elm-compiler.cabal−1

compare with master

unifiedsplit

@@ -119,7 +119,6 @@ Library

119 Type.Environment,

120 Type.Fragment,

121 Type.Inference,

122− Type.PrettyPrint,

123 Type.Solve,

122 Type.Solve,

124 Type.State,

123 Type.State,

125 Type.Type,

124 Type.Type,

src/AST/Type.hs−19

@@ -4,7 +4,6 @@ module AST.Type

4 , Port(..), getPortType

5 , deepDealias, iteratedDealias, dealias

6 , collectLambdas

7− , fieldMap

8 , tuple

7 , tuple

9 ) where

8 ) where

@@ -65,24 +64,6 @@ getPortType portType =

65 Signal tipe _ -> tipe

64 Signal tipe _ -> tipe

68−fieldMap :: [(String,a)] -> Map.Map String [a]

69−fieldMap fields =

70− let add r (field,tipe) =

71− Map.insertWith (++) field [tipe] r

72− in

73− foldl add Map.empty fields

74−

75−{--

76−recordOf :: [(String, Type var)] -> Type var

77−recordOf fields =

78− Record fields Nothing

79−

80−

81−listOf :: RawType -> RawType

82−listOf tipe =

83− App (Type (Var.Raw "List")) [tipe]

84−--}

85−

86tuple :: R.Region -> [Raw] -> Raw

67tuple :: R.Region -> [Raw] -> Raw

87tuple region types =

68tuple region types =

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

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

src/Reporting/Error/Type.hs+25−11

@@ -15,23 +15,31 @@ import qualified Reporting.Report as Report

16data Error

17 = Mismatch Mismatch

18− | InfiniteType InfiniteType

19 | BadMain Type.Canonical

18 | BadMain Type.Canonical

19+ | InfiniteType

20+ { _name :: String

21+ , _overallType :: Type.Canonical

22+ , _infiniteType :: Type.Canonical

23+ }

22data Mismatch = MismatchInfo

26data Mismatch = MismatchInfo

23 { _hint :: Hint

27 { _hint :: Hint

28+ , _rootType :: Type.Canonical

24 , _leftType :: Type.Canonical

29 , _leftType :: Type.Canonical

25 , _rightType :: Type.Canonical

30 , _rightType :: Type.Canonical

26− , _note :: Maybe String

31+ , _reason :: Maybe Reason

27 }

32 }

30−data InfiniteType = InfiniteTypeInfo

35+data Reason

36+ = MessyFields [String] [String]

37+ | ExpectedFields [String]

31− { _name :: String

38+ | ActualFields [String]

32− , _var :: Type.Canonical

39+ | NotRecord

33− , _type :: Type.Canonical

40+ | TooLongComparableTuple Int

34− }

41+ | Rigid (Maybe String)

42+ deriving (Show)

37data Hint

45data Hint

@@ -66,18 +74,21 @@ data Pattern

66 | PRecord

74 | PRecord

77+

69-- TO REPORT

78-- TO REPORT

80+

71toReport :: P.Dealiaser -> Error -> Report.Report

81toReport :: P.Dealiaser -> Error -> Report.Report

72toReport dealiaser err =

82toReport dealiaser err =

73 case err of

83 case err of

74− Mismatch (MismatchInfo hint leftType rightType note) ->

84+ Mismatch (MismatchInfo hint rootType leftType rightType maybeReason) ->

75 let

85 let

76 (subRegion, preHint, maybePostHint) = hintToString hint

86 (subRegion, preHint, maybePostHint) = hintToString hint

78 postHint =

88 postHint =

79− maybe "" (++"\n\n") note

89+ "TODO explain what went wrong!\n\n" ++ show maybeReason ++ "\n\n"

80 ++ maybe "" (++"\n\n") maybePostHint

90 ++ maybe "" (++"\n\n") maybePostHint

91+ ++ P.render (P.nest 4 (P.pretty dealiaser False rootType)) ++ "\n\n"

81 ++ "As I infer the types of values flowing through your program, I see a conflict\n"

92 ++ "As I infer the types of values flowing through your program, I see a conflict\n"

82 ++ "between these two types:\n\n"

93 ++ "between these two types:\n\n"

83 ++ P.render (P.nest 4 (P.pretty dealiaser False leftType))

94 ++ P.render (P.nest 4 (P.pretty dealiaser False leftType))

@@ -86,7 +97,7 @@ toReport dealiaser err =

86 in

97 in

87 Report.Report "TYPE MISMATCH" subRegion preHint postHint

98 Report.Report "TYPE MISMATCH" subRegion preHint postHint

89− InfiniteType (InfiniteTypeInfo name var tipe) ->

100+ InfiniteType name var tipe ->

90 let

101 let

91 prettyVar =

102 prettyVar =

92 P.pretty dealiaser False var

103 P.pretty dealiaser False var

@@ -97,7 +108,8 @@ toReport dealiaser err =

97 Report.simple "INFINITE TYPE"

108 Report.simple "INFINITE TYPE"

98 ( "I am inferring weird self-referential type for `" ++ name ++ "`"

109 ( "I am inferring weird self-referential type for `" ++ name ++ "`"

99 )

110 )

111+ ( "TODO - do a better job\n\n"

100− ( "The bit of the type that is self-referential looks like this:\n\n"

112+ ++ "The bit of the type that is self-referential looks like this:\n\n"

101 ++ P.render (P.nest 4 (prettyVar <+> P.equals <+> prettyType))

113 ++ P.render (P.nest 4 (prettyVar <+> P.equals <+> prettyType))

102 ++ "\n\nThe cause is often that the usage of `" ++ name ++ "` is flipped around.\n\n"

114 ++ "\n\nThe cause is often that the usage of `" ++ name ++ "` is flipped around.\n\n"

103 ++ "Maybe you are inserting a data structure into an element? Maybe you are giving\n"

115 ++ "Maybe you are inserting a data structure into an element? Maybe you are giving\n"

@@ -308,3 +320,5 @@ ordinalize number =

308 | otherwise = "th"

320 | otherwise = "th"

309 in

321 in

310 show number ++ ending

322 show number ++ ending

323+

324+

src/Type/Constrain/Expression.hs+78−82

@@ -3,7 +3,6 @@ module Type.Constrain.Expression where

4import Control.Arrow (second)

5import qualified Control.Monad as Monad

6−import qualified Data.List as List

7import qualified Data.Map as Map

6import qualified Data.Map as Map

9import qualified AST.Expression.General as E

8import qualified AST.Expression.General as E

@@ -28,7 +27,7 @@ constrain

28 -> Type

27 -> Type

29 -> IO TypeConstraint

28 -> IO TypeConstraint

30constrain env annotatedExpr@(A.A region expression) tipe =

29constrain env annotatedExpr@(A.A region expression) tipe =

31− let list t = Env.get env Env.types "List" <| t

30+ let list t = Env.getType env "List" <| t

32 (<?) = CInstance region

31 (<?) = CInstance region

33 in

32 in

34 case expression of

33 case expression of

@@ -40,21 +39,22 @@ constrain env annotatedExpr@(A.A region expression) tipe =

40 exists $ \unif ->

39 exists $ \unif ->

41 let

40 let

42 shaderTipe a u v =

41 shaderTipe a u v =

43− Env.get env Env.types "WebGL.Shader" <| a <| u <| v

42+ Env.getType env "WebGL.Shader" <| a <| u <| v

45− glTipe =

44+ glToType glTipe =

46− Env.get env Env.types . Lit.glTipeName

45+ Env.getType env (Lit.glTipeName glTipe)

48 makeRec accessor baseRec =

47 makeRec accessor baseRec =

49 let decls = accessor gltipe

48 let decls = accessor gltipe

50 in

49 in

51− if Map.size decls == 0

50+ if Map.size decls == 0 then

52− then baseRec

51+ baseRec

52+ else

53− else record (Map.map (\t -> [glTipe t]) decls) baseRec

53+ record (Map.map glToType decls) baseRec

55 attribute = makeRec Lit.attribute attr

56 uniform = makeRec Lit.uniform unif

57− varying = makeRec Lit.varying (termN EmptyRecord1)

57+ varying = makeRec Lit.varying (TermN EmptyRecord1)

58 in

59 return (CEqual Error.Shader region tipe (shaderTipe attribute uniform varying))

@@ -104,8 +104,8 @@ constrain env annotatedExpr@(A.A region expression) tipe =

104 constrainCase env region expr branches tipe

105

106 E.Data name exprs ->

107− do vars <- Monad.forM exprs $ \_ -> variable Flexible

107+ do vars <- Monad.forM exprs $ \_ -> mkVar Nothing

108− let pairs = zip exprs (map varN vars)

108+ let pairs = zip exprs (map VarN vars)

109 (ctipe, cs) <- Monad.foldM step (tipe, CTrue) (reverse pairs)

110 return $ ex vars (cs /\ name <? ctipe)

111 where

@@ -115,31 +115,31 @@ constrain env annotatedExpr@(A.A region expression) tipe =

115

116 E.Access expr label ->

117 exists $ \t ->

118− constrain env expr (record (Map.singleton label [tipe]) t)

118+ constrain env expr (record (Map.singleton label tipe) t)

119

120 E.Update expr fields ->

121 exists $ \t ->

122− do oldVars <- Monad.forM fields $ \_ -> variable Flexible

122+ do oldVars <- mapM (\_ -> mkVar Nothing) fields

123− let oldFields = ST.fieldMap (zip (map fst fields) (map varN oldVars))

123+ let oldFields = Map.fromList (zip (map fst fields) (map VarN oldVars))

124 cOld <- ex oldVars <$> constrain env expr (record oldFields t)

125

126− newVars <- Monad.forM fields $ \_ -> variable Flexible

126+ newVars <- mapM (\_ -> mkVar Nothing) fields

127− let newFields = ST.fieldMap (zip (map fst fields) (map varN newVars))

127+ let newFields = Map.fromList (zip (map fst fields) (map VarN newVars))

128 let cNew = CEqual Error.Record region tipe (record newFields t)

129

130− cs <- Monad.zipWithM (constrain env) (map snd fields) (map varN newVars)

130+ cs <- Monad.zipWithM (constrain env) (map snd fields) (map VarN newVars)

131

132 return $ cOld /\ ex newVars (CAnd (cNew : cs))

133

134 E.Record fields ->

135− do vars <- Monad.forM fields (\_ -> variable Flexible)

135+ do vars <- Monad.forM fields (\_ -> mkVar Nothing)

136 fieldCons <-

137 Monad.zipWithM

138 (constrain env)

139 (map snd fields)

140− (map varN vars)

140+ (map VarN vars)

141− let fields' = ST.fieldMap (zip (map fst fields) (map varN vars))

141+ let fields' = Map.fromList (zip (map fst fields) (map VarN vars))

142− let recordType = record fields' (termN EmptyRecord1)

142+ let recordType = record fields' (TermN EmptyRecord1)

143 return (ex vars (CAnd (fieldCons ++ [CEqual Error.Record region tipe recordType])))

144

145 E.Let defs body ->

@@ -178,14 +178,14 @@ constrainApp

178 -> Type

179 -> IO TypeConstraint

180constrainApp env region f args tipe =

181− do funcVar <- variable Flexible

181+ do funcVar <- mkVar Nothing

182− funcCon <- constrain env f (varN funcVar)

182+ funcCon <- constrain env f (VarN funcVar)

183

184 (vars, argCons, numberOfArgsCons, argMatchCons, _, returnVar) <-

185 argConstraints env maybeName region (length args) funcVar 1 args

186

187 let returnCon =

188− CEqual (Error.Function maybeName) region (varN returnVar) tipe

188+ CEqual (Error.Function maybeName) region (VarN returnVar) tipe

189

190 return $ ex (funcVar : vars) $

191 CAnd (funcCon : argCons ++ numberOfArgsCons ++ argMatchCons ++ [returnCon])

@@ -214,10 +214,10 @@ argConstraints env name region totalArgs overallVar index args =

214 return ([], [], [], [], Nothing, overallVar)

215

216 expr@(A.A subregion _) : rest ->

217− do argVar <- variable Flexible

217+ do argVar <- mkVar Nothing

218− argCon <- constrain env expr (varN argVar)

218+ argCon <- constrain env expr (VarN argVar)

219− argIndexVar <- variable Flexible

219+ argIndexVar <- mkVar Nothing

220− localReturnVar <- variable Flexible

220+ localReturnVar <- mkVar Nothing

221

222 (vars, argConRest, numberOfArgsRest, argMatchRest, restRegion, returnVar) <-

223 argConstraints env name region totalArgs localReturnVar (index + 1) rest

@@ -229,15 +229,15 @@ argConstraints env name region totalArgs overallVar index args =

229 CEqual

230 (Error.FunctionArity name (index - 1) totalArgs arityRegion)

231 region

232− (varN argIndexVar ==> varN localReturnVar)

232+ (VarN argIndexVar ==> VarN localReturnVar)

233− (varN overallVar)

233+ (VarN overallVar)

234

235 let argMatchCon =

236 CEqual

237 (Error.UnexpectedArg name index subregion)

238 region

239− (varN argIndexVar)

239+ (VarN argIndexVar)

240− (varN argVar)

240+ (VarN argVar)

241

242 return

243 ( argVar : argIndexVar : localReturnVar : vars

@@ -262,26 +262,26 @@ constrainBinop

262 -> Type

263 -> IO TypeConstraint

264constrainBinop env region op leftExpr@(A.A leftRegion _) rightExpr@(A.A rightRegion _) tipe =

265− do leftVar <- variable Flexible

265+ do leftVar <- mkVar Nothing

266− rightVar <- variable Flexible

266+ rightVar <- mkVar Nothing

267

268− leftCon <- constrain env leftExpr (varN leftVar)

268+ leftCon <- constrain env leftExpr (VarN leftVar)

269− rightCon <- constrain env rightExpr (varN rightVar)

269+ rightCon <- constrain env rightExpr (VarN rightVar)

270

271− leftVar' <- variable Flexible

271+ leftVar' <- mkVar Nothing

272− rightVar' <- variable Flexible

272+ rightVar' <- mkVar Nothing

273− answerVar <- variable Flexible

273+ answerVar <- mkVar Nothing

274

275− let opType = varN leftVar' ==> varN rightVar' ==> varN answerVar

275+ let opType = VarN leftVar' ==> VarN rightVar' ==> VarN answerVar

276

277 return $

278 ex [leftVar,rightVar,leftVar',rightVar',answerVar] $ CAnd $

279 [ leftCon

280 , rightCon

281 , CInstance region (V.toString op) opType

282− , CEqual (Error.BinopLeft op leftRegion) region (varN leftVar') (varN leftVar)

282+ , CEqual (Error.BinopLeft op leftRegion) region (VarN leftVar') (VarN leftVar)

283− , CEqual (Error.BinopRight op rightRegion) region (varN rightVar') (varN rightVar)

283+ , CEqual (Error.BinopRight op rightRegion) region (VarN rightVar') (VarN rightVar)

284− , CEqual (Error.Binop op) region tipe (varN answerVar)

284+ , CEqual (Error.Binop op) region tipe (VarN answerVar)

285 ]

286

287

@@ -302,12 +302,12 @@ constrainList env region exprs tipe =

302 return $ ex vars (CAnd (exprCons ++ cons))

303 where

304 elementConstraint expr@(A.A region' _) =

305− do var <- variable Flexible

305+ do var <- mkVar Nothing

306− con <- constrain env expr (varN var)

306+ con <- constrain env expr (VarN var)

307 return ( (var, region'), con )

308

309 varToCon var =

310− CEqual Error.List region tipe (Env.get env Env.types "List" <| varN var)

310+ CEqual Error.List region tipe (Env.getType env "List" <| VarN var)

311

312

313-- CONSTRAIN IF EXPRESSIONS

@@ -334,17 +334,17 @@ constrainIf env region branches finally tipe =

334 return $ ex (condVars ++ vars) (CAnd (condCons ++ branchExprCons ++ cons))

335 where

336 bool =

337− Env.get env Env.types "Bool"

337+ Env.getType env "Bool"

338

339 constrainCondition condition@(A.A condRegion _) =

340− do condVar <- variable Flexible

340+ do condVar <- mkVar Nothing

341− condCon <- constrain env condition (varN condVar)

341+ condCon <- constrain env condition (VarN condVar)

342− let boolCon = CEqual Error.IfCondition condRegion (varN condVar) bool

342+ let boolCon = CEqual Error.IfCondition condRegion (VarN condVar) bool

343 return (condVar, CAnd [ condCon, boolCon ])

344

345 constrainBranch expr@(A.A branchRegion _) =

346− do branchVar <- variable Flexible

346+ do branchVar <- mkVar Nothing

347− exprCon <- constrain env expr (varN branchVar)

347+ exprCon <- constrain env expr (VarN branchVar)

348 return

349 ( (branchVar, branchRegion)

350 , exprCon

@@ -355,7 +355,7 @@ constrainIf env region branches finally tipe =

355 [(thenVar, _), (elseVar, _)] ->

356 return

357 ( [thenVar,elseVar]

358− , [ CEqual Error.IfBranches region (varN thenVar) (varN elseVar)

358+ , [ CEqual Error.IfBranches region (VarN thenVar) (VarN elseVar)

359 , varToCon thenVar

360 ]

361 )

@@ -364,7 +364,7 @@ constrainIf env region branches finally tipe =

364 pairCons region Error.MultiIfBranch varToCon branchInfo

365

366 varToCon var =

367− CEqual Error.If region (varN var) tipe

367+ CEqual Error.If region (VarN var) tipe

368

369

370-- CONSTRAIN CASE EXPRESSIONS

@@ -377,27 +377,27 @@ constrainCase

377 -> Type

378 -> IO TypeConstraint

379constrainCase env region expr branches tipe =

380− do exprVar <- variable Flexible

380+ do exprVar <- mkVar Nothing

381− exprCon <- constrain env expr (varN exprVar)

381+ exprCon <- constrain env expr (VarN exprVar)

382

383 (branchInfo, branchExprCons) <-

384− unzip <$> mapM (branch (varN exprVar)) branches

384+ unzip <$> mapM (branch (VarN exprVar)) branches

385

386 (vars, cons) <- pairCons region Error.CaseBranch varToCon branchInfo

387

388 return $ ex (exprVar : vars) (CAnd (exprCon : branchExprCons ++ cons))

389 where

390 branch patternType (pattern, branchExpr@(A.A branchRegion _)) =

391− do branchVar <- variable Flexible

391+ do branchVar <- mkVar Nothing

392 fragment <- Pattern.constrain env pattern patternType

393− branchCon <- constrain env branchExpr (varN branchVar)

393+ branchCon <- constrain env branchExpr (VarN branchVar)

394 return

395 ( (branchVar, branchRegion)

396 , CLet [Fragment.toScheme fragment] branchCon

397 )

398

399 varToCon var =

400− CEqual Error.Case region tipe (varN var)

400+ CEqual Error.Case region tipe (VarN var)

401

402

403-- COLLECT PAIRS

@@ -419,11 +419,11 @@ pairCons

419pairCons region pairHint varToCon items =

420 let

421 pairToCon (Pair index var1 var2 subregion) =

422− CEqual (pairHint index subregion) region (varN var1) (varN var2)

422+ CEqual (pairHint index subregion) region (VarN var1) (VarN var2)

423 in

424 case collectPairs 2 items of

425 Nothing ->

426− do var <- variable Flexible

426+ do var <- mkVar Nothing

427 return ([var], [varToCon var])

428

429 Just (pairs, var) ->

@@ -514,28 +514,26 @@ constrainAnnotatedDef

514 -> IO Info

515constrainAnnotatedDef env info qs patternRegion typeRegion name expr tipe =

516 do -- Some mistake may be happening here. Currently, qs is always [].

517− rigidVars <- Monad.forM qs (\_ -> variable Rigid)

517+ rigidVars <- mapM mkRigid qs

518

519− flexiVars <- Monad.forM qs (\_ -> variable Flexible)

519+ flexiVars <- mapM mkNamedVar qs

520

521− let inserts = zipWith (\arg typ -> Map.insert arg (varN typ)) qs flexiVars

521+ let env' = Env.addValues env (zip qs flexiVars)

522−

523− let env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }

524

522

525 (vars, typ) <- Env.instantiateType env tipe Map.empty

523 (vars, typ) <- Env.instantiateType env tipe Map.empty

526

524

527 let scheme =

525 let scheme =

528 Scheme

526 Scheme

529− { rigidQuantifiers = []

527+ { _rigidQuantifiers = []

530− , flexibleQuantifiers = flexiVars ++ vars

528+ , _flexibleQuantifiers = flexiVars ++ vars

531− , constraint = CTrue

529+ , _constraint = CTrue

532− , header = Map.singleton name (A.A patternRegion typ)

530+ , _header = Map.singleton name (A.A patternRegion typ)

533− }

531+ }

534−

532+

535− var <- variable Flexible

533+ var <- mkVar Nothing

536− defCon <- constrain env' expr (varN var)

534+ defCon <- constrain env' expr (VarN var)

537 let annCon =

535 let annCon =

538− CEqual (Error.BadTypeAnnotation name) typeRegion typ (varN var)

536+ CEqual (Error.BadTypeAnnotation name) typeRegion typ (VarN var)

539

537

540 return $ info

538 return $ info

541 { iSchemes = scheme : iSchemes info

539 { iSchemes = scheme : iSchemes info

@@ -553,15 +551,13 @@ constrainUnannotatedDef

553 -> IO Info

551 -> IO Info

554constrainUnannotatedDef env info qs patternRegion name expr =

552constrainUnannotatedDef env info qs patternRegion name expr =

555 do -- Some mistake may be happening here. Currently, qs is always [].

553 do -- Some mistake may be happening here. Currently, qs is always [].

556− rigidVars <- Monad.forM qs (\_ -> variable Rigid)

554+ rigidVars <- mapM mkRigid qs

557−

558− v <- variable Flexible

559

555

560− let tipe = varN v

556+ v <- mkVar Nothing

561

557

562− let inserts = zipWith (\arg typ -> Map.insert arg (varN typ)) qs rigidVars

558+ let tipe = VarN v

563

559

564− let env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }

560+ let env' = Env.addValues env (zip qs rigidVars)

565

561

566 con <- constrain env' expr tipe

562 con <- constrain env' expr tipe

567

563

src/Type/Constrain/Literal.hs+25−14

@@ -18,20 +18,31 @@ constrain env region literal tipe =

18 return (T.CEqual (Error.Literal name) region tipe tipe')

19 where

20 prim name =

21− return (Env.get env Env.types name)

21+ return (Env.getType env name)

23− litType =

23+ (name, litType) =

24 case literal of

25− L.IntNum _ -> T.varN `fmap` T.variable (T.Is T.Number)

25+ L.IntNum _ ->

26− L.FloatNum _ -> prim "Float"

26+ ( "number"

27− L.Chr _ -> prim "Char"

27+ , T.VarN <$> T.mkVar (Just T.Number)

28− L.Str _ -> prim "String"

28+ )

29− L.Boolean _ -> prim "Bool"

31− name =

32− case literal of

33− L.IntNum _ -> "number"

34− L.FloatNum _ -> "float"

30+ L.FloatNum _ ->

31+ ( "float"

32+ , prim "Float"

33+ )

34+

35+ L.Chr _ ->

35− L.Chr _ -> "character"

36+ ( "character"

37+ , prim "Char"

38+ )

39+

40+ L.Str _ ->

36− L.Str _ -> "string"

41+ ( "string"

42+ , prim "String"

43+ )

44+

37− L.Boolean _ -> "boolean"

45+ L.Boolean _ ->

46+ ( "boolean"

47+ , prim "Bool"

48+ )

src/Type/Constrain/Pattern.hs+11−12

@@ -1,4 +1,3 @@

1−{-# LANGUAGE FlexibleInstances #-}

2module Type.Constrain.Pattern where

1module Type.Constrain.Pattern where

4import Control.Arrow (second)

3import Control.Arrow (second)

@@ -26,7 +25,7 @@ constrain env (A.A region pattern) tipe =

26 CEqual (Error.Pattern patternError) region leftType rightType

25 CEqual (Error.Pattern patternError) region leftType rightType

28 rvar v =

27 rvar v =

29− A.A region (varN v)

28+ A.A region (VarN v)

30 in

29 in

31 case pattern of

30 case pattern of

32 P.Anything ->

31 P.Anything ->

@@ -37,22 +36,22 @@ constrain env (A.A region pattern) tipe =

37 return $ emptyFragment { typeConstraint = c }

36 return $ emptyFragment { typeConstraint = c }

39 P.Var name ->

38 P.Var name ->

40− do v <- variable Flexible

39+ do variable <- mkVar Nothing

41 return $ Fragment

40 return $ Fragment

42− { typeEnv = Map.singleton name (rvar v)

41+ { typeEnv = Map.singleton name (rvar variable)

43− , vars = [v]

42+ , vars = [variable]

44 , typeConstraint =

43 , typeConstraint =

45− equal (Error.PVar name) (varN v) tipe

44+ equal (Error.PVar name) (VarN variable) tipe

46 }

45 }

48 P.Alias name p ->

47 P.Alias name p ->

49− do v <- variable Flexible

48+ do variable <- mkVar Nothing

50 fragment <- constrain env p tipe

49 fragment <- constrain env p tipe

51 return $ fragment

50 return $ fragment

52− { typeEnv = Map.insert name (rvar v) (typeEnv fragment)

51+ { typeEnv = Map.insert name (rvar variable) (typeEnv fragment)

53− , vars = v : vars fragment

52+ , vars = variable : vars fragment

54 , typeConstraint =

53 , typeConstraint =

55− equal (Error.PAlias name) (varN v) tipe

54+ equal (Error.PAlias name) (VarN variable) tipe

56 /\ typeConstraint fragment

55 /\ typeConstraint fragment

57 }

56 }

@@ -73,13 +72,13 @@ constrain env (A.A region pattern) tipe =

74 P.Record fields ->

73 P.Record fields ->

75 do pairs <-

74 do pairs <-

76− mapM (\name -> (,) name <$> variable Flexible) fields

75+ mapM (\name -> (,) name <$> mkVar Nothing) fields

78 let tenv =

77 let tenv =

79 Map.fromList (map (second rvar) pairs)

78 Map.fromList (map (second rvar) pairs)

81 let unannotatedTenv =

80 let unannotatedTenv =

82− Map.map (\v -> [A.drop v]) tenv

81+ Map.map A.drop tenv

84 con <- exists $ \t ->

83 con <- exists $ \t ->

85 return (equal Error.PRecord tipe (record unannotatedTenv t))

84 return (equal Error.PRecord tipe (record unannotatedTenv t))

src/Type/Environment.hs+104−93

@@ -1,11 +1,18 @@

1+{-# OPTIONS_GHC -Wall #-}

1−module Type.Environment where

2+module Type.Environment

3+ ( Environment

4+ , initialize

5+ , getType, freshDataScheme, ctorNames

6+ , addValues

7+ , instantiateType

8+ )

9+ where

3−import Control.Monad (forM)

4import qualified Control.Monad.State as State

11import qualified Control.Monad.State as State

5−import qualified Data.Traversable as Traverse

12+import qualified Data.List as List

13+import Data.Map ((!))

6import qualified Data.Map as Map

14import qualified Data.Map as Map

7import qualified Data.Set as Set

15import qualified Data.Set as Set

8−import Data.List (isPrefixOf)

10import qualified AST.Type as T

17import qualified AST.Type as T

11import qualified AST.Variable as V

18import qualified AST.Variable as V

@@ -18,22 +25,22 @@ type VarDict = Map.Map String Variable

20data Environment = Environment

27data Environment = Environment

21− { constructor :: Map.Map String (IO (Int, [Variable], [Type], Type))

28+ { _constructor :: Map.Map String (IO (Int, [Variable], [Type], Type))

22− , types :: TypeDict

29+ , _types :: TypeDict

23− , value :: TypeDict

30+ , _value :: TypeDict

24 }

31 }

27−initialEnvironment :: [Module.CanonicalAdt] -> IO Environment

34+initialize :: [Module.CanonicalAdt] -> IO Environment

28−initialEnvironment datatypes =

35+initialize datatypes =

29 do types <- makeTypes datatypes

36 do types <- makeTypes datatypes

30 let env =

37 let env =

31 Environment

38 Environment

32− { constructor = Map.empty

39+ { _constructor = Map.empty

33− , value = Map.empty

40+ , _value = Map.empty

34− , types = types

41+ , _types = types

35 }

42 }

36− return $ env { constructor = makeConstructors env datatypes }

43+ return $ env { _constructor = makeConstructors env datatypes }

39makeTypes :: [Module.CanonicalAdt] -> IO TypeDict

46makeTypes :: [Module.CanonicalAdt] -> IO TypeDict

@@ -43,14 +50,14 @@ makeTypes datatypes =

43 return (Map.fromList (adts ++ bs))

50 return (Map.fromList (adts ++ bs))

44 where

51 where

45 makeImported :: (V.Canonical, Module.AdtInfo V.Canonical) -> IO (String, Type)

52 makeImported :: (V.Canonical, Module.AdtInfo V.Canonical) -> IO (String, Type)

46− makeImported (var, _) =

53+ makeImported (name, _) =

47− do tvar <- namedVar Constant var

54+ do tvar <- mkAtom name

48− return (V.toString var, varN tvar)

55+ return (V.toString name, VarN tvar)

50 makeBuiltin :: (String, Int) -> IO (String, Type)

57 makeBuiltin :: (String, Int) -> IO (String, Type)

51 makeBuiltin (name, _) =

58 makeBuiltin (name, _) =

52− do name' <- namedVar Constant (V.builtin name)

59+ do name' <- mkAtom (V.builtin name)

53− return (name, varN name')

60+ return (name, VarN name')

55 builtins :: [(String, Int)]

62 builtins :: [(String, Int)]

56 builtins =

63 builtins =

@@ -72,17 +79,17 @@ makeConstructors env datatypes =

72 Map.fromList builtins

79 Map.fromList builtins

73 where

80 where

74 list t =

81 list t =

75− (types env Map.! "List") <| t

82+ (_types env ! "List") <| t

77 inst :: Int -> ([Type] -> ([Type], Type)) -> IO (Int, [Variable], [Type], Type)

84 inst :: Int -> ([Type] -> ([Type], Type)) -> IO (Int, [Variable], [Type], Type)

78 inst numTVars tipe =

85 inst numTVars tipe =

79− do vars <- forM [1..numTVars] $ \_ -> variable Flexible

86+ do vars <- mapM (\_ -> mkVar Nothing) [1..numTVars]

80− let (args, result) = tipe (map (varN) vars)

87+ let (args, result) = tipe (map (VarN) vars)

81 return (length args, vars, args, result)

88 return (length args, vars, args, result)

83 tupleCtor n =

90 tupleCtor n =

84 let name = "_Tuple" ++ show n

91 let name = "_Tuple" ++ show n

85− in (name, inst n $ \vs -> (vs, foldl (<|) (types env Map.! name) vs))

92+ in (name, inst n $ \vs -> (vs, foldl (<|) (_types env ! name) vs))

87 builtins :: [ (String, IO (Int, [Variable], [Type], Type)) ]

94 builtins :: [ (String, IO (Int, [Variable], [Type], Type)) ]

88 builtins =

95 builtins =

@@ -112,44 +119,62 @@ ctorToType env (name, (tvars, ctors)) =

112 return (types, returnType)

119 return (types, returnType)

113

120

114

121

122+

123+-- ACCESS TYPES

124+

125+

115−get :: Environment -> (Environment -> Map.Map String a) -> String -> a

126+get :: (Environment -> Map.Map String a) -> Environment -> String -> a

116−get env subDict key =

127+get subDict env key =

117 Map.findWithDefault (error msg) key (subDict env)

128 Map.findWithDefault (error msg) key (subDict env)

118 where

129 where

119 msg = "Could not find type constructor `" ++ key ++ "` while checking types."

130 msg = "Could not find type constructor `" ++ key ++ "` while checking types."

120

131

121

132

122−freshDataScheme

123− :: Environment

133+getType :: Environment -> String -> Type

124− -> String

134+getType =

125− -> IO (Int, [Variable], [Type], Type)

135+ get _types

126−freshDataScheme env name =

127− get env constructor name

128

136

129

137

138+freshDataScheme :: Environment -> String -> IO (Int, [Variable], [Type], Type)

139+freshDataScheme =

140+ get _constructor

141+

142+

143+ctorNames :: Environment -> [String]

144+ctorNames env =

145+ Map.keys (_constructor env)

146+

147+

148+-- UPDATE ENVIRONMENT

149+

150+

151+addValues :: Environment -> [(String, Variable)] -> Environment

152+addValues env newValues =

153+ env

154+ { _value =

155+ List.foldl'

156+ (\dict (name, var) -> Map.insert name (VarN var) dict)

157+ (_value env)

158+ newValues

159+ }

160+

161+

162+

163+-- INSTANTIATE TYPES

164+

165+

130−instantiateType

166+instantiateType :: Environment -> T.Canonical -> VarDict -> IO ([Variable], Type)

131− :: Environment

132− -> T.Canonical

133− -> VarDict

134− -> IO ([Variable], Type)

135instantiateType env sourceType dict =

167instantiateType env sourceType dict =

136 do (tipe, dict') <- State.runStateT (instantiator env sourceType) dict

168 do (tipe, dict') <- State.runStateT (instantiator env sourceType) dict

137 return (Map.elems dict', tipe)

169 return (Map.elems dict', tipe)

138

170

139

171

140−instantiator

141− :: Environment

142− -> T.Canonical

143− -> State.StateT VarDict IO Type

172+instantiator :: Environment -> T.Canonical -> State.StateT VarDict IO Type

144instantiator env sourceType =

173instantiator env sourceType =

145 instantiatorHelp env Set.empty sourceType

174 instantiatorHelp env Set.empty sourceType

146

175

147

176

148−instantiatorHelp

149− :: Environment

150− -> Set.Set String

151− -> T.Canonical

152− -> State.StateT VarDict IO Type

177+instantiatorHelp :: Environment -> Set.Set String -> T.Canonical -> State.StateT VarDict IO Type

153instantiatorHelp env aliasVars sourceType =

178instantiatorHelp env aliasVars sourceType =

154 let go = instantiatorHelp env aliasVars

179 let go = instantiatorHelp env aliasVars

155 in

180 in

@@ -157,70 +182,56 @@ instantiatorHelp env aliasVars sourceType =

157 T.Lambda t1 t2 ->

182 T.Lambda t1 t2 ->

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

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

159

184

160− T.Var x ->

185+ T.Var name ->

161− do dict <- State.get

162− case Set.member x aliasVars of

186+ if Set.member name aliasVars then

163− True ->

164− return (PlaceHolder x)

187+ return (PlaceHolder name)

165− False ->

188+

189+ else

190+ do dict <- State.get

166− case Map.lookup x dict of

191+ case Map.lookup name dict of

167− Just v ->

192+ Just variable ->

168− return (varN v)

193+ return (VarN variable)

169−

194+

170− Nothing ->

195+ Nothing ->

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

196+ do variable <- State.liftIO (mkNamedVar name)

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

197+ State.put (Map.insert name variable dict)

173− return (varN v)

198+ return (VarN variable)

174− where

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

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

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

178− | otherwise = Flexible

179

199

180 T.Aliased name args aliasType ->

200 T.Aliased name args aliasType ->

181− do args' <- mapM (\(arg,tipe) -> (,) arg <$> go tipe) args

201+ do targs <- mapM (\(arg,tipe) -> (,) arg <$> go tipe) args

182− aliasedType' <-

202+ realType <-

183 case aliasType of

203 case aliasType of

184 T.Filled tipe ->

204 T.Filled tipe ->

185 instantiatorHelp env Set.empty tipe

205 instantiatorHelp env Set.empty tipe

206+

186 T.Holey tipe ->

207 T.Holey tipe ->

187 instantiatorHelp env (Set.fromList (map fst args)) tipe

208 instantiatorHelp env (Set.fromList (map fst args)) tipe

188

209

189− case aliasedType' of

210+ return (AliasN name targs realType)

190− PlaceHolder _ ->

191− error "problem instantiating type"

192−

193− VarN maybeSubAlias v ->

194− case maybeSubAlias of

195− Nothing ->

196− return (VarN (Just (name,args')) v)

197− Just _subAlias ->

198− return (TermN (Just (name,args')) (Var1 aliasedType'))

199−

200− TermN maybeSubAlias t ->

201− case maybeSubAlias of

202− Nothing ->

203− return (TermN (Just (name, args')) t)

204− Just _subAlias ->

205− return (TermN (Just (name,args')) (Var1 aliasedType'))

206

211

207 T.Type name ->

212 T.Type name ->

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

213+ case Map.lookup (V.toString name) (_types env) of

214+ Just tipe ->

209− Just t -> return t

215+ return tipe

216+

210 Nothing ->

217 Nothing ->

211 error $

218 error $

212 "Could not find type constructor `" ++

219 "Could not find type constructor `" ++

213 V.toString name ++ "` while checking types."

220 V.toString name ++ "` while checking types."

214

221

215− T.App t ts ->

222+ T.App func args ->

216− do t' <- go t

223+ do tfunc <- go func

217− ts' <- mapM go ts

224+ targs <- mapM go args

218− return $ foldl (<|) t' ts'

225+ return $ foldl (<|) tfunc targs

219

226

220 T.Record fields ext ->

227 T.Record fields ext ->

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

228+ do tfields <- traverse go (Map.fromList fields)

222− ext' <-

229+ text <-

223 case ext of

230 case ext of

231+ Nothing ->

224− Nothing -> return $ termN EmptyRecord1

232+ return $ TermN EmptyRecord1

233+

225− Just x -> go x

234+ Just extType ->

235+ go extType

236+

226− return $ termN (Record1 fields' ext')

237+ return $ TermN (Record1 tfields text)

src/Type/Inference.hs+5−6

@@ -42,13 +42,12 @@ infer interfaces modul =

42genConstraints

43 :: Module.Interfaces

44 -> Module.CanonicalModule

45− -> IO (Env.TypeDict, T.TypeConstraint)

45+ -> IO (Map.Map String T.Type, T.TypeConstraint)

46genConstraints interfaces modul =

47− do env <-

48− Env.initialEnvironment (canonicalizeAdts interfaces modul)

47+ do env <- Env.initialize (canonicalizeAdts interfaces modul)

50 ctors <-

49 ctors <-

51− forM (Map.keys (Env.constructor env)) $ \name ->

50+ forM (Env.ctorNames env) $ \name ->

52 do (_, vars, args, result) <- Env.freshDataScheme env name

51 do (_, vars, args, result) <- Env.freshDataScheme env name

53 return (name, (vars, foldr (T.==>) result args))

52 return (name, (vars, foldr (T.==>) result args))

@@ -60,10 +59,10 @@ genConstraints interfaces modul =

60 let header = Map.map snd (Map.fromList allTypes)

59 let header = Map.map snd (Map.fromList allTypes)

61 let environ = T.CLet [ T.Scheme vars [] T.CTrue (Map.map (A.A undefined) header) ]

60 let environ = T.CLet [ T.Scheme vars [] T.CTrue (Map.map (A.A undefined) header) ]

63− fvar <- T.variable T.Flexible

62+ fvar <- T.mkVar Nothing

65 constraint <-

64 constraint <-

66− TcExpr.constrain env (program (body modul)) (T.varN fvar)

65+ TcExpr.constrain env (program (body modul)) (T.VarN fvar)

68 return (header, environ constraint)

67 return (header, environ constraint)

src/Type/PrettyPrint.hsdeleted−20

@@ -1,20 +0,0 @@

1−module Type.PrettyPrint where

2−

3−import Text.PrettyPrint

4−

5−

6−data ParensWhen = Fn | App | Never

7−

8−

9−class PrettyType a where

10− pretty :: ParensWhen -> a -> Doc

11−

12−

13−commaSep :: [Doc] -> Doc

14−commaSep docs =

15− sep (punctuate comma docs)

16−

17−

18−parensIf :: Bool -> Doc -> Doc

19−parensIf bool doc =

20− if bool then parens doc else doc

src/Type/Solve.hs+152−98

@@ -2,7 +2,7 @@ module Type.Solve (solve) where

3import Control.Applicative ((<|>))

4import Control.Monad

5−import Control.Monad.State (StateT, execStateT, liftIO)

5+import Control.Monad.State (execStateT, liftIO)

6import Control.Monad.Except (ExceptT, throwError)

7import qualified Data.Foldable as F

8import qualified Data.List as List

@@ -14,21 +14,22 @@ import qualified AST.Type as Type

14import qualified Reporting.Annotation as A

15import qualified Reporting.Error.Type as Error

16import qualified Type.State as TS

17−import Type.Type

17+import Type.Type as Type

18import Type.Unify

21+

21{-| Every variable has rank less than or equal to the maxRank of the pool.

22{-| Every variable has rank less than or equal to the maxRank of the pool.

22This sorts variables into the young and old pools accordingly.

23This sorts variables into the young and old pools accordingly.

23-}

24-}

24−generalize :: TS.Pool -> StateT TS.SolverState IO ()

25+generalize :: TS.Pool -> TS.Solver ()

25generalize youngPool =

26generalize youngPool =

26 do youngMark <- TS.uniqueMark

27 do youngMark <- TS.uniqueMark

27 let youngRank = TS.maxRank youngPool

28 let youngRank = TS.maxRank youngPool

28 let insert dict var =

29 let insert dict var =

29 do descriptor <- liftIO $ UF.descriptor var

30 do descriptor <- liftIO $ UF.descriptor var

30− liftIO $ UF.modifyDescriptor var (\desc -> desc { mark = youngMark })

31+ liftIO $ UF.modifyDescriptor var (\desc -> desc { _mark = youngMark })

31− return $ Map.insertWith (++) (rank descriptor) [var] dict

32+ return $ Map.insertWith (++) (_rank descriptor) [var] dict

33 -- Sort the youngPool variables by rank.

34 -- Sort the youngPool variables by rank.

34 rankDict <- foldM insert Map.empty (TS.inhabitants youngPool)

35 rankDict <- foldM insert Map.empty (TS.inhabitants youngPool)

@@ -58,63 +59,98 @@ generalize youngPool =

58 True -> return ()

59 True -> return ()

59 False -> do

60 False -> do

60 desc <- liftIO $ UF.descriptor var

61 desc <- liftIO $ UF.descriptor var

61− case rank desc < youngRank of

62+ case _rank desc < youngRank of

63+ True ->

62− True -> TS.register var >> return ()

64+ TS.register var >> return ()

63− False -> do

65+ False ->

64− let flex' = case flex desc of { Flexible -> Rigid ; other -> other }

65− liftIO $ UF.setDescriptor var (desc { rank = noRank, flex = flex' })

66+ liftIO $ UF.setDescriptor var $ desc

67+ { _rank = noRank

68+ , _content = rigidify (_content desc)

69+ }

67 mapM_ registerIfLowerRank (Map.findWithDefault [] youngRank rankDict)

71 mapM_ registerIfLowerRank (Map.findWithDefault [] youngRank rankDict)

74+rigidify :: Content -> Content

75+rigidify content =

76+ case content of

77+ Var Flex maybeSuper _ ->

78+ Var Rigid maybeSuper Nothing

79+

80+ _ ->

81+ content

82+

83+

70-- adjust the ranks of variables such that ranks never increase as you

84-- adjust the ranks of variables such that ranks never increase as you

71-- move deeper into a variable.

85-- move deeper into a variable.

72−adjustRank :: Int -> Int -> Int -> Variable -> StateT TS.SolverState IO Int

86+adjustRank :: Int -> Int -> Int -> Variable -> TS.Solver Int

73adjustRank youngMark visitedMark groupRank var =

87adjustRank youngMark visitedMark groupRank var =

74 do descriptor <- liftIO $ UF.descriptor var

88 do descriptor <- liftIO $ UF.descriptor var

75− case () of

89+ adjustRankHelp youngMark visitedMark groupRank var descriptor

90+

91+

92+adjustRankHelp :: Int -> Int -> Int -> Variable -> Descriptor -> TS.Solver Int

93+adjustRankHelp youngMark visitedMark groupRank var descriptor =

76− () | mark descriptor == youngMark ->

94+ if _mark descriptor == youngMark then

95+

77− do -- Set the variable as marked first because it may be cyclic.

96+ do -- Set the variable as marked first because it may be cyclic.

78− liftIO $ UF.modifyDescriptor var $ \desc ->

97+ liftIO $ UF.modifyDescriptor var $ \desc ->

79− desc { mark = visitedMark }

98+ desc { _mark = visitedMark }

80− rank' <- maybe (return groupRank) adjustTerm (structure descriptor)

99+

100+ maxRank <-

101+ adjustRankContent youngMark visitedMark groupRank (_content descriptor)

102+

81− liftIO $ UF.modifyDescriptor var $ \desc ->

103+ liftIO $ UF.modifyDescriptor var $ \desc ->

82− desc { rank = rank' }

104+ desc { _rank = maxRank }

105+

83− return rank'

106+ return maxRank

84−

107+

85− | mark descriptor /= visitedMark ->

108+ else if _mark descriptor /= visitedMark then

109+

86− do let rank' = min groupRank (rank descriptor)

110+ do let minRank = min groupRank (_rank descriptor)

87− liftIO $ UF.setDescriptor var (descriptor { mark = visitedMark, rank = rank' })

111+ liftIO $ UF.setDescriptor var (descriptor { _mark = visitedMark, _rank = minRank })

88− return rank'

112+ return minRank

89−

113+

90− | otherwise ->

114+ else

115+

91− return (rank descriptor)

116+ return (_rank descriptor)

92− where

117+

93− adjust =

118+

119+adjustRankContent :: Int -> Int -> Int -> Content -> TS.Solver Int

120+adjustRankContent youngMark visitedMark groupRank content =

121+ let

94− adjustRank youngMark visitedMark groupRank

122+ go = adjustRank youngMark visitedMark groupRank

95−

123+ in

96− adjustTerm term =

124+ case content of

97− case term of

125+ Error ->

98− App1 a b ->

126+ return groupRank

99− max `liftM` adjust a `ap` adjust b

127+

100−

128+ Atom _ ->

101− Fun1 a b ->

129+ return groupRank

102− max `liftM` adjust a `ap` adjust b

130+

103−

131+ Var _ _ _ ->

104− Var1 x ->

132+ return groupRank

105− adjust x

133+

106−

134+ Alias _ args realVar ->

135+ maximum <$> mapM go (realVar : map snd args)

136+

137+ Structure (App1 func arg) ->

138+ max <$> go func <*> go arg

139+

140+ Structure (Fun1 arg result) ->

141+ max <$> go arg <*> go result

142+

107− EmptyRecord1 ->

143+ Structure EmptyRecord1 ->

108− return outermostRank

144+ return outermostRank

109−

145+

110− Record1 fields extension ->

146+ Structure (Record1 fields extension) ->

111− do ranks <- mapM adjust (concat (Map.elems fields))

147+ maximum <$> mapM go (extension : Map.elems fields)

112− rnk <- adjust extension

148+

113− return . maximum $ rnk : ranks

114

149

115

150

116-- SOLVER

151-- SOLVER

117

152

153+

118solve :: TypeConstraint -> ExceptT [A.Located Error.Error] IO TS.SolverState

154solve :: TypeConstraint -> ExceptT [A.Located Error.Error] IO TS.SolverState

119solve constraint =

155solve constraint =

120 do state <-

156 do state <-

@@ -126,7 +162,7 @@ solve constraint =

126 throwError errors

162 throwError errors

127

163

128

164

129−actuallySolve :: TypeConstraint -> StateT TS.SolverState IO ()

165+actuallySolve :: TypeConstraint -> TS.Solver ()

130actuallySolve constraint =

166actuallySolve constraint =

131 case constraint of

167 case constraint of

132 CTrue ->

168 CTrue ->

@@ -151,7 +187,7 @@ actuallySolve constraint =

151

187

152 CLet schemes constraint' ->

188 CLet schemes constraint' ->

153 do oldEnv <- TS.getEnv

189 do oldEnv <- TS.getEnv

154− headers <- Map.unions `fmap` mapM solveScheme schemes

190+ headers <- Map.unions <$> mapM solveScheme schemes

155 TS.modifyEnv $ \env -> Map.union headers env

191 TS.modifyEnv $ \env -> Map.union headers env

156 actuallySolve constraint'

192 actuallySolve constraint'

157 mapM occurs $ Map.toList headers

193 mapM occurs $ Map.toList headers

@@ -165,17 +201,17 @@ actuallySolve constraint =

165 TS.makeInstance tipe

201 TS.makeInstance tipe

166

202

167 Nothing ->

203 Nothing ->

168− if List.isPrefixOf "Native." name

204+ if List.isPrefixOf "Native." name then

169− then liftIO (variable Flexible)

205+ liftIO (mkVar Nothing)

206+

207+ else

170− else error ("Could not find `" ++ name ++ "` when solving type constraints.")

208+ error ("Could not find `" ++ name ++ "` when solving type constraints.")

171

209

172 t <- TS.flatten term

210 t <- TS.flatten term

173 unify (Error.Instance name) region freshCopy t

211 unify (Error.Instance name) region freshCopy t

174

212

175

213

176−solveScheme

177− :: TypeScheme

178− -> StateT TS.SolverState IO (Map.Map String (A.Located Variable))

214+solveScheme :: TypeScheme -> TS.Solver (Map.Map String (A.Located Variable))

179solveScheme scheme =

215solveScheme scheme =

180 let

216 let

181 flatten (A.A region term) =

217 flatten (A.A region term) =

@@ -210,26 +246,37 @@ solveScheme scheme =

210-- Checks that all of the given variables belong to distinct equivalence classes.

246-- Checks that all of the given variables belong to distinct equivalence classes.

211-- Also checks that their structure is Nothing, so they represent a variable, not

247-- Also checks that their structure is Nothing, so they represent a variable, not

212-- a more complex term.

248-- a more complex term.

213−allDistinct :: [Variable] -> StateT TS.SolverState IO ()

249+allDistinct :: [Variable] -> TS.Solver ()

214allDistinct vars =

250allDistinct vars =

215− do seen <- TS.uniqueMark

251+ do seenMark <- TS.uniqueMark

216 forM_ vars $ \var ->

252 forM_ vars $ \var ->

217 do desc <- liftIO $ UF.descriptor var

253 do desc <- liftIO $ UF.descriptor var

218− case structure desc of

254+ case _content desc of

219− Just _ ->

255+ Structure _ ->

220− crash "Cannot generalize something that is not a type variable."

256+ crash "Can only generalize type variables, not structures."

257+

258+ Atom _ ->

259+ crash "Can only generalize type variables, not structures."

260+

261+ Alias _ _ _ ->

262+ crash "Can only generalize type variables, not aliases."

263+

264+ Error ->

265+ crash "Can only generalize type variables, not error types."

266+

267+ Var _ _ _ ->

268+ if _mark desc == seenMark then

269+ crash "Duplicate variable during generalization."

221

270

222− Nothing ->

271+ else

223− if mark desc == seen

224− then crash "Duplicate variable during generalization."

225− else liftIO (UF.setDescriptor var (desc { mark = seen }))

272+ liftIO (UF.setDescriptor var (desc { _mark = seenMark }))

226

273

227

274

228-- Check that a variable has rank == noRank, meaning that it can be generalized.

275-- Check that a variable has rank == noRank, meaning that it can be generalized.

229−isGeneric :: Variable -> StateT TS.SolverState IO ()

276+isGeneric :: Variable -> TS.Solver ()

230isGeneric var =

277isGeneric var =

231 do desc <- liftIO $ UF.descriptor var

278 do desc <- liftIO $ UF.descriptor var

232− if rank desc == noRank

279+ if _rank desc == noRank

233 then return ()

280 then return ()

234 else crash "Unable to generalize a type variable. It is not unranked."

281 else crash "Unable to generalize a type variable. It is not unranked."

235

282

@@ -237,59 +284,66 @@ isGeneric var =

237crash :: String -> a

284crash :: String -> a

238crash msg =

285crash msg =

239 error $

286 error $

240− "It looks like something went wrong with the type inference algorithm.\n"

287+ "It looks like something went wrong with the type inference algorithm.\n\n"

241− ++ msg ++ "\n"

288+ ++ msg ++ "\n\n"

242 ++ "Please create a minimal example that triggers this problem and report it to\n"

289 ++ "Please create a minimal example that triggers this problem and report it to\n"

243 ++ "<https://github.com/elm-lang/elm-compiler/issues>"

290 ++ "<https://github.com/elm-lang/elm-compiler/issues>"

244

291

245

292

293+

294+-- OCCURS CHECK

295+

296+

246−occurs :: (String, A.Located Variable) -> StateT TS.SolverState IO ()

297+occurs :: (String, A.Located Variable) -> TS.Solver ()

247occurs (name, A.A region variable) =

298occurs (name, A.A region variable) =

248− do maybePair <- liftIO $ occursHelp [] variable

299+ do maybeInfinite <- liftIO $ occursHelp [] variable

249− case maybePair of

300+ case maybeInfinite of

250 Nothing ->

301 Nothing ->

251 return ()

302 return ()

252

303

253− Just (t1, t2) ->

304+ Just infiniteType ->

254− let

305+ do overallType <- liftIO (Type.toSrcType variable)

255− info = Error.InfiniteTypeInfo name t1 t2

256− in

257− TS.addError region (Error.InfiniteType info)

306+ TS.addError region (Error.InfiniteType name overallType infiniteType)

258

307

259

308

260−occursHelp

261− :: [Variable]

262− -> Variable

263− -> IO (Maybe (Type.Canonical, Type.Canonical))

309+occursHelp :: [Variable] -> Variable -> IO (Maybe Type.Canonical)

264occursHelp seen var =

310occursHelp seen var =

265 if elem var seen then

311 if elem var seen then

266− do desc <- UF.descriptor var

312+ do infiniteDescriptor <- UF.descriptor var

313+ structureVar <- UF.fresh infiniteDescriptor

267− UF.setDescriptor var (desc { structure = Nothing })

314+ UF.setDescriptor var (infiniteDescriptor { _content = Error })

268− var' <- UF.fresh desc

269− srcVar <- toSrcType var

315+ srcVar <- Type.toSrcType structureVar

270− srcVar' <- toSrcType var'

271− return (Just (srcVar, srcVar'))

316+ return (Just srcVar)

317+

272 else

318 else

273 do desc <- UF.descriptor var

319 do desc <- UF.descriptor var

274− case structure desc of

320+ case _content desc of

275− Nothing ->

321+ Atom _ ->

276 return Nothing

322 return Nothing

277

323

278− Just struct ->

324+ Var _ _ _ ->

325+ return Nothing

326+

327+ Error ->

328+ return Nothing

329+

330+ Alias _ args _ ->

331+ -- TODO is it okay to only check args?

332+ F.asum <$> mapM (occursHelp (var:seen) . snd) args

333+

334+ Structure term ->

335+ let

279− let go = occursHelp (var:seen)

336+ go = occursHelp (var:seen)

280 in

337 in

281− case struct of

338+ case term of

282 App1 a b ->

339 App1 a b ->

283 (<|>) <$> go a <*> go b

340 (<|>) <$> go a <*> go b

284

341

285 Fun1 a b ->

342 Fun1 a b ->

286 (<|>) <$> go a <*> go b

343 (<|>) <$> go a <*> go b

287

344

288− Var1 a ->

289− go a

290−

291 EmptyRecord1 ->

345 EmptyRecord1 ->

292 return Nothing

346 return Nothing

293

347

294 Record1 fields ext ->

348 Record1 fields ext ->

295− F.asum <$> mapM go (ext : concat (Map.elems fields))

349+ F.asum <$> mapM go (ext : Map.elems fields)

src/Type/State.hs+197−136

@@ -1,12 +1,9 @@

1−{-# LANGUAGE FlexibleContexts #-}

1+{-# OPTIONS_GHC -Wall #-}

2−{-# LANGUAGE MultiParamTypeClasses #-}

3module Type.State where

2module Type.State where

5−import Control.Applicative ((<|>))

6−import Control.Monad.State

4+import qualified Control.Monad.State as State

7import Data.Map ((!))

5import Data.Map ((!))

8import qualified Data.Map as Map

6import qualified Data.Map as Map

9−import qualified Data.Traversable as Traversable

10import qualified Data.UnionFind.IO as UF

7import qualified Data.UnionFind.IO as UF

12import qualified Reporting.Annotation as A

9import qualified Reporting.Annotation as A

@@ -37,6 +34,9 @@ emptyPool =

37type Env = Map.Map String (A.Located Variable)

34type Env = Map.Map String (A.Located Variable)

37+type Solver = State.StateT SolverState IO

38+

39+

40-- Keeps track of the environment, type variable pool, and a list of errors

41data SolverState = SS

42 { sEnv :: Env

@@ -58,191 +58,257 @@ initialState =

58 }

61−modifyEnv :: (MonadState SolverState m) => (Env -> Env) -> m ()

61+modifyEnv :: (Env -> Env) -> Solver ()

62modifyEnv f =

63− modify $ \state -> state { sEnv = f (sEnv state) }

63+ State.modify $ \state -> state { sEnv = f (sEnv state) }

66−modifyPool :: (MonadState SolverState m) => (Pool -> Pool) -> m ()

66+modifyPool :: (Pool -> Pool) -> Solver ()

67modifyPool f =

68− modify $ \state -> state { sPool = f (sPool state) }

68+ State.modify $ \state -> state { sPool = f (sPool state) }

71−addError :: R.Region -> Error.Error -> StateT SolverState IO ()

71+addError :: R.Region -> Error.Error -> Solver ()

72addError region err =

73− modify $ \state -> state { sError = A.A region err : sError state }

73+ State.modify $ \state -> state { sError = A.A region err : sError state }

76−switchToPool :: (MonadState SolverState m) => Pool -> m ()

76+switchToPool :: Pool -> Solver ()

77switchToPool pool =

78 modifyPool (\_ -> pool)

81−getPool :: StateT SolverState IO Pool

81+getPool :: Solver Pool

82getPool =

83− gets sPool

83+ State.gets sPool

86−getEnv :: StateT SolverState IO Env

86+getEnv :: Solver Env

87getEnv =

88− gets sEnv

88+ State.gets sEnv

91−saveLocalEnv :: StateT SolverState IO ()

91+saveLocalEnv :: Solver ()

92saveLocalEnv =

93 do currentEnv <- getEnv

94− modify $ \state -> state { sSavedEnv = currentEnv }

94+ State.modify $ \state -> state { sSavedEnv = currentEnv }

97−uniqueMark :: StateT SolverState IO Int

97+uniqueMark :: Solver Int

98uniqueMark =

99− do state <- get

99+ do state <- State.get

100 let mark = sMark state

101− put $ state { sMark = mark + 1 }

101+ State.put $ state { sMark = mark + 1 }

102 return mark

103

104

105−nextRankPool :: StateT SolverState IO Pool

105+nextRankPool :: Solver Pool

106nextRankPool =

107 do pool <- getPool

108 return $ Pool { maxRank = maxRank pool + 1, inhabitants = [] }

109

110

111−register :: Variable -> StateT SolverState IO Variable

111+register :: Variable -> Solver Variable

112register variable =

113 do modifyPool $ \pool -> pool { inhabitants = variable : inhabitants pool }

114 return variable

115

116

117−introduce :: Variable -> StateT SolverState IO Variable

117+introduce :: Variable -> Solver Variable

118introduce variable =

119 do pool <- getPool

120− liftIO $ UF.modifyDescriptor variable (\desc -> desc { rank = maxRank pool })

120+ State.liftIO $ UF.modifyDescriptor variable (\desc -> desc { _rank = maxRank pool })

121 register variable

122

123

124−flatten :: Type -> StateT SolverState IO Variable

124+flatten :: Type -> Solver Variable

125flatten term =

126 flattenHelp Map.empty term

127

128

129−flattenHelp :: Map.Map String Variable -> Type -> StateT SolverState IO Variable

129+flattenHelp :: Map.Map String Variable -> Type -> Solver Variable

130−flattenHelp aliasDict term =

130+flattenHelp aliasDict termN =

131− case term of

131+ case termN of

132 PlaceHolder name ->

133− return (aliasDict ! name)

133+ return (aliasDict ! name)

134−

134+

135+ AliasN name args realType ->

136+ do flatArgs <- mapM (traverse (flattenHelp aliasDict)) args

137+ flatVar <- flattenHelp (Map.fromList flatArgs) realType

138+ pool <- getPool

139+ variable <-

140+ State.liftIO . UF.fresh $ Descriptor

141+ { _content = Alias name flatArgs flatVar

142+ , _rank = maxRank pool

143+ , _mark = noMark

144+ , _copy = Nothing

145+ }

146+ register variable

147+

135− VarN maybeAlias v ->

148+ VarN v ->

136− do maybeAlias' <- Traversable.traverse flattenAlias maybeAlias

137− liftIO $ UF.modifyDescriptor v $ \desc ->

138− desc { alias = maybeAlias' <|> alias desc }

139− return v

149+ return v

140−

150+

141− TermN maybeAlias subTerm ->

151+ TermN term1 ->

142− do maybeAlias' <- Traversable.traverse flattenAlias maybeAlias

143− let localDict = maybe aliasDict (Map.fromList . snd) maybeAlias'

144− flatStructure <- traverseTerm (flattenHelp localDict) subTerm

152+ do variableTerm <- traverseTerm (flattenHelp aliasDict) term1

145− pool <- getPool

153+ pool <- getPool

146− var <-

154+ variable <-

147− liftIO . UF.fresh $ Descriptor

155+ State.liftIO . UF.fresh $ Descriptor

148− { structure = Just flatStructure

156+ { _content = Structure variableTerm

149− , rank = maxRank pool

157+ , _rank = maxRank pool

150− , flex = Flexible

158+ , _mark = noMark

151− , name = Nothing

159+ , _copy = Nothing

152− , copy = Nothing

160+ }

161+ register variable

162+

163+

164+makeInstance :: Variable -> Solver Variable

165+makeInstance var =

166+ do alreadyCopiedMark <- uniqueMark

167+ freshVar <- makeCopy alreadyCopiedMark var

168+ _ <- restore alreadyCopiedMark var

169+ return freshVar

170+

171+

172+makeCopy :: Int -> Variable -> Solver Variable

173+makeCopy alreadyCopiedMark variable =

174+ do desc <- State.liftIO $ UF.descriptor variable

175+ makeCopyHelp desc alreadyCopiedMark variable

176+

177+

178+makeCopyHelp :: Descriptor -> Int -> Variable -> Solver Variable

179+makeCopyHelp descriptor alreadyCopiedMark variable =

180+ if _mark descriptor == alreadyCopiedMark then

181+ case _copy descriptor of

182+ Just copiedVariable ->

183+ return copiedVariable

184+

185+ Nothing ->

186+ error $

187+ "Error copying type variable. This should be impossible." ++

188+ " Please report an error to the github repo!"

189+

190+ else if _rank descriptor /= noRank || not (needsCopy (_content descriptor)) then

191+ return variable

192+

193+ else

194+ do pool <- getPool

195+ newVar <-

196+ State.liftIO $ UF.fresh $ Descriptor

197+ { _content = error "will be filled in soon!"

198+ , _rank = maxRank pool

153− , mark = noMark

199+ , _mark = noMark

154− , alias = maybeAlias'

200+ , _copy = Nothing

155 }

201 }

156− register var

202+ _ <- register newVar

157− where

158− flattenAlias (name, args) =

159− let flattenPair (arg, subTerm) =

160− (,) arg <$> flattenHelp aliasDict subTerm

161− in

162− (,) name <$> mapM flattenPair args

163

203

204+ -- Link the original variable to the new variable. This lets us

205+ -- avoid making multiple copies of the variable we are instantiating.

206+ --

207+ -- Need to do this before recursively copying the content of

208+ -- the variable to avoid looping on cyclic terms.

209+ State.liftIO $ UF.modifyDescriptor variable $ \desc ->

210+ desc { _mark = alreadyCopiedMark, _copy = Just newVar }

164

211

212+ -- Now we recursively copy the content of the variable.

213+ -- We have already marked the variable as copied, so we

214+ -- will not repeat this work or crawl this variable again.

215+ let oldContent = _content descriptor

216+ newContent <-

217+ case oldContent of

218+ Structure term ->

219+ Structure <$> traverseTerm (makeCopy alreadyCopiedMark) term

165

220

221+ Atom _ ->

222+ return oldContent

166

223

167−makeInstance :: Variable -> StateT SolverState IO Variable

224+ Var Rigid maybeSuper _ ->

168−makeInstance var =

225+ return (Var Flex maybeSuper Nothing)

169− do alreadyCopied <- uniqueMark

226+

170− freshVar <- makeCopy alreadyCopied var

227+ Var Flex _ _ ->

171− restore alreadyCopied var

228+ return oldContent

172− return freshVar

229+

230+ Alias name args realType ->

231+ Alias name

232+ <$> mapM (traverse (makeCopy alreadyCopiedMark)) args

233+ <*> makeCopy alreadyCopiedMark realType

234+

235+ Error ->

236+ return oldContent

237+

238+ State.liftIO $ UF.modifyDescriptor newVar $ \desc ->

239+ desc { _content = newContent }

173

240

241+ return newVar

174

242

243+

244+needsCopy :: Content -> Bool

245+needsCopy content =

246+ case content of

247+ Structure _ ->

248+ True

249+

250+ Atom _ ->

251+ False

252+

253+ Var _ _ _ ->

254+ True

255+

256+ Alias _ _ _ ->

257+ True

258+

259+ Error ->

260+ False

261+

262+

263+

175−makeCopy :: Int -> Variable -> StateT SolverState IO Variable

264+restore :: Int -> Variable -> Solver Variable

176−makeCopy alreadyCopied variable = do

265+restore alreadyCopiedMark variable =

177− desc <- liftIO $ UF.descriptor variable

266+ do desc <- State.liftIO $ UF.descriptor variable

178− case () of

267+ if _mark desc /= alreadyCopiedMark

179− () | mark desc == alreadyCopied ->

268+ then

180− case copy desc of

181− Just v ->

182− return v

183− Nothing ->

184− error $

185− "Error copying type variable. This should be impossible." ++

186− " Please report an error to the github repo!"

187−

188− | rank desc /= noRank || flex desc == Constant ->

189 return variable

269 return variable

190

270

191− | otherwise ->

271+ else

192− do pool <- getPool

272+ do restoredContent <-

193− newVar <-

273+ restoreContent alreadyCopiedMark (_content desc)

194− liftIO $ UF.fresh $ Descriptor

274+ State.liftIO $ UF.setDescriptor variable $ Descriptor

195− { structure = Nothing

275+ { _content = restoredContent

196− , rank = maxRank pool

276+ , _rank = noRank

197− , mark = noMark

277+ , _mark = noMark

198− , flex =

278+ , _copy = Nothing

199− case flex desc of

279+ }

200− Is s -> Is s

201− _ -> Flexible

202− , copy = Nothing

203− , name =

204− case flex desc of

205− Rigid -> Nothing

206− _ -> name desc

207− , alias = Nothing

208− }

209− register newVar

210−

211− -- Link the original variable to the new variable. This lets us

212− -- avoid making multiple copies of the variable we are instantiating.

213− --

214− -- Need to do this before recursively copying the structure of

215− -- the variable to avoid looping on cyclic terms.

216− liftIO $ UF.modifyDescriptor variable $ \desc ->

217− desc { mark = alreadyCopied, copy = Just newVar }

218−

219− -- Now we recursively copy the structure of the variable.

220− -- We have already marked the variable as copied, so we

221− -- will not repeat this work or crawl this variable again.

222− case structure desc of

223− Nothing ->

224− return newVar

225−

226− Just term ->

227− do newTerm <- traverseTerm (makeCopy alreadyCopied) term

228− liftIO $ UF.modifyDescriptor newVar $ \desc ->

229− desc { structure = Just newTerm }

230− return newVar

231−

232−

233−restore :: Int -> Variable -> StateT SolverState IO Variable

234−restore alreadyCopied variable =

235− do desc <- liftIO $ UF.descriptor variable

236− case mark desc /= alreadyCopied of

237− True -> return variable

238− False ->

239− do restoredStructure <-

240− Traversable.traverse (traverseTerm (restore alreadyCopied)) (structure desc)

241− liftIO $ UF.modifyDescriptor variable $ \desc ->

242− desc { mark = noMark, rank = noRank, structure = restoredStructure }

243 return variable

280 return variable

244

281

245

282

283+

284+restoreContent :: Int -> Content -> Solver Content

285+restoreContent alreadyCopiedMark content =

286+ let

287+ go = restore alreadyCopiedMark

288+ in

289+ case content of

290+ Structure term ->

291+ Structure <$> traverseTerm go term

292+

293+ Atom _ ->

294+ return content

295+

296+ Var _ _ _ ->

297+ return content

298+

299+ Alias name args var ->

300+ Alias name

301+ <$> mapM (traverse go) args

302+ <*> go var

303+

304+ Error ->

305+ return content

306+

307+

308+

309+-- TERM TRAVERSAL

310+

311+

246traverseTerm :: (Monad f, Applicative f) => (a -> f b) -> Term1 a -> f (Term1 b)

312traverseTerm :: (Monad f, Applicative f) => (a -> f b) -> Term1 a -> f (Term1 b)

247traverseTerm f term =

313traverseTerm f term =

248 case term of

314 case term of

@@ -252,13 +318,8 @@ traverseTerm f term =

252 Fun1 a b ->

318 Fun1 a b ->

253 Fun1 <$> f a <*> f b

319 Fun1 <$> f a <*> f b

254

320

255− Var1 x ->

256− Var1 <$> f x

257−

258 EmptyRecord1 ->

321 EmptyRecord1 ->

259 return EmptyRecord1

322 return EmptyRecord1

260

323

261 Record1 fields ext ->

324 Record1 fields ext ->

262− Record1

263− <$> Traversable.traverse (mapM f) fields

325+ Record1 <$> traverse f fields <*> f ext

264− <*> f ext

src/Type/Type.hs+219−444

@@ -1,108 +1,117 @@

1+{-# OPTIONS_GHC -Wall #-}

1module Type.Type where

2module Type.Type where

3import Control.Monad.State (StateT)

4import Control.Monad.State (StateT)

4import qualified Control.Monad.State as State

5import qualified Control.Monad.State as State

5−import qualified Data.Char as Char

6+import qualified Data.List as List

6import qualified Data.Map as Map

7import qualified Data.Map as Map

7import qualified Data.Set as Set

8import qualified Data.Set as Set

8import qualified Data.Traversable as Traverse (traverse)

9import qualified Data.Traversable as Traverse (traverse)

9import qualified Data.UnionFind.IO as UF

10import qualified Data.UnionFind.IO as UF

10−import Text.PrettyPrint as P

11−import System.IO.Unsafe

13import qualified AST.Type as T

12import qualified AST.Type as T

14import qualified AST.Variable as Var

13import qualified AST.Variable as Var

15import qualified Reporting.Annotation as A

14import qualified Reporting.Annotation as A

16import qualified Reporting.Error.Type as Error

15import qualified Reporting.Error.Type as Error

17import qualified Reporting.Region as R

16import qualified Reporting.Region as R

18−import Type.PrettyPrint

17+

21-- CONCRETE TYPES

20-- CONCRETE TYPES

23−type Type = TermN Variable

23+type Type =

24+ TermN Variable

25+

26+

27+type Variable =

25−type Variable = UF.Point Descriptor

28+ UF.Point Descriptor

29+

31+type TypeConstraint =

27−type TypeConstraint = Constraint Type Variable

32+ Constraint Type Variable

29−type TypeScheme = Scheme Type Variable

31−type Alias a = Maybe (Var.Canonical, [(String,a)])

35+type TypeScheme =

36+ Scheme Type Variable

37+

34-- TYPE PRIMITIVES

40-- TYPE PRIMITIVES

42+

36data Term1 a

43data Term1 a

37 = App1 a a

44 = App1 a a

38 | Fun1 a a

45 | Fun1 a a

39− | Var1 a

40 | EmptyRecord1

46 | EmptyRecord1

41− | Record1 (Map.Map String [a]) a

47+ | Record1 (Map.Map String a) a

44data TermN a

50data TermN a

45 = PlaceHolder String

51 = PlaceHolder String

52+ | AliasN Var.Canonical [(String, TermN a)] (TermN a)

46− | VarN (Alias (TermN a)) a

53+ | VarN a

47− | TermN (Alias (TermN a)) (Term1 (TermN a))

54+ | TermN (Term1 (TermN a))

48−

50−varN :: a -> TermN a

51−varN =

52− VarN Nothing

54−

55−termN :: (Term1 (TermN a)) -> TermN a

56−termN =

57− TermN Nothing

58−

59−

60−record :: Map.Map String [TermN a] -> TermN a -> TermN a

57+record :: Map.Map String (TermN a) -> TermN a -> TermN a

61record fs rec =

58record fs rec =

62− termN (Record1 fs rec)

59+ TermN (Record1 fs rec)

60+

65-- DESCRIPTORS

63-- DESCRIPTORS

65+

67data Descriptor = Descriptor

66data Descriptor = Descriptor

68− { structure :: Maybe (Term1 Variable)

67+ { _content :: Content

69− , rank :: Int

68+ , _rank :: Int

70− , flex :: Flex

71− , name :: Maybe TypeName

72− , copy :: Maybe Variable

73− , mark :: Int

69+ , _mark :: Int

74− , alias :: Alias Variable

70+ , _copy :: Maybe Variable

75 }

71 }

73+

74+data Content

75+ = Structure (Term1 Variable)

76+ | Atom Var.Canonical

77+ | Var Flex (Maybe Super) (Maybe String)

78+ | Alias Var.Canonical [(String,Variable)] Variable

79+ | Error

80+

81+

82+data Flex

83+ = Rigid

84+ | Flex

85+

86+

87+data Super

88+ = Number

89+ | Comparable

90+ | Appendable

91+ | CompAppend

92+ deriving (Eq)

93+

94+

77noRank :: Int

95noRank :: Int

78noRank = -1

96noRank = -1

98+

80outermostRank :: Int

99outermostRank :: Int

81outermostRank = 0

100outermostRank = 0

101

102+

83noMark :: Int

103noMark :: Int

84noMark = 0

104noMark = 0

105

106+

86initialMark :: Int

107initialMark :: Int

87initialMark = 1

108initialMark = 1

109

89−data Flex

90− = Rigid

91− | Flexible

92− | Constant

93− | Is SuperType

94− | Error

95− deriving (Eq)

96−

97−data SuperType

98− = Number

99− | Comparable

100− | Appendable

101− deriving (Eq)

102

110

103

111

104-- CONSTRAINTS

112-- CONSTRAINTS

105

113

114+

106data Constraint a b

115data Constraint a b

107 = CTrue

116 = CTrue

108 | CSaveEnv

117 | CSaveEnv

@@ -111,66 +120,88 @@ data Constraint a b

111 | CLet [Scheme a b] (Constraint a b)

120 | CLet [Scheme a b] (Constraint a b)

112 | CInstance R.Region SchemeName a

121 | CInstance R.Region SchemeName a

113

122

123+

114type SchemeName = String

124type SchemeName = String

115

125

116−type TypeName = Var.Canonical

117

126

118data Scheme a b = Scheme

127data Scheme a b = Scheme

119− { rigidQuantifiers :: [b]

128+ { _rigidQuantifiers :: [b]

120− , flexibleQuantifiers :: [b]

129+ , _flexibleQuantifiers :: [b]

121− , constraint :: Constraint a b

130+ , _constraint :: Constraint a b

122− , header :: Map.Map String (A.Located a)

131+ , _header :: Map.Map String (A.Located a)

123 }

132 }

124

133

125

134

135+

126-- TYPE HELPERS

136-- TYPE HELPERS

127

137

138+

128infixr 9 ==>

139infixr 9 ==>

129

140

141+

130(==>) :: Type -> Type -> Type

142(==>) :: Type -> Type -> Type

131(==>) a b =

143(==>) a b =

132− termN (Fun1 a b)

144+ TermN (Fun1 a b)

133

145

134

146

135(<|) :: TermN a -> TermN a -> TermN a

147(<|) :: TermN a -> TermN a -> TermN a

136(<|) f a =

148(<|) f a =

137− termN (App1 f a)

149+ TermN (App1 f a)

138−

139

150

140−-- VARIABLE HELPERS

141

151

142−namedVar :: Flex -> Var.Canonical -> IO Variable

143−namedVar flex name = UF.fresh $ Descriptor

144− { structure = Nothing

145− , rank = noRank

146− , flex = flex

147− , name = Just name

148− , copy = Nothing

149− , mark = noMark

150− , alias = Nothing

151− }

152

153+-- VARIABLE CREATION

153

154

154−variable :: Flex -> IO Variable

155−variable flex =

156− UF.fresh (descriptor flex)

157

155

158−

156+mkDescriptor :: Content -> Descriptor

159−descriptor :: Flex -> Descriptor

157+mkDescriptor content =

160−descriptor flex =

161 Descriptor

158 Descriptor

162− { structure = Nothing

159+ { _content = content

163− , rank = noRank

160+ , _rank = noRank

164− , flex = flex

165− , name = Nothing

166− , copy = Nothing

167− , mark = noMark

161+ , _mark = noMark

168− , alias = Nothing

162+ , _copy = Nothing

169 }

163 }

170

164

171

165

166+mkAtom :: Var.Canonical -> IO Variable

167+mkAtom name =

168+ UF.fresh $ mkDescriptor (Atom name)

169+

170+

171+mkVar :: Maybe Super -> IO Variable

172+mkVar maybeSuper =

173+ UF.fresh $ mkDescriptor (Var Flex maybeSuper Nothing)

174+

175+

176+mkNamedVar :: String -> IO Variable

177+mkNamedVar name =

178+ UF.fresh $ mkDescriptor (Var Flex (toSuper name) Nothing)

179+

180+

181+mkRigid :: String -> IO Variable

182+mkRigid name =

183+ UF.fresh $ mkDescriptor (Var Rigid (toSuper name) (Just name))

184+

185+

186+toSuper :: String -> Maybe Super

187+toSuper name =

188+ if List.isPrefixOf "number" name then

189+ Just Number

190+

191+ else if List.isPrefixOf "comparable" name then

192+ Just Comparable

193+

194+ else if List.isPrefixOf "appendable" name then

195+ Just Appendable

196+

197+ else

198+ Nothing

199+

200+

201+

172-- CONSTRAINT HELPERS

202-- CONSTRAINT HELPERS

173

203

204+

174monoscheme :: Map.Map String (A.Located a) -> Scheme a b

205monoscheme :: Map.Map String (A.Located a) -> Scheme a b

175monoscheme headers =

206monoscheme headers =

176 Scheme [] [] CTrue headers

207 Scheme [] [] CTrue headers

@@ -200,401 +231,178 @@ fl rqs constraint =

200

231

201exists :: (Type -> IO TypeConstraint) -> IO TypeConstraint

232exists :: (Type -> IO TypeConstraint) -> IO TypeConstraint

202exists f =

233exists f =

203− do v <- variable Flexible

234+ do v <- mkVar Nothing

204− ex [v] <$> f (varN v)

235+ ex [v] <$> f (VarN v)

205

236

206

237

207existsNumber :: (Type -> IO TypeConstraint) -> IO TypeConstraint

238existsNumber :: (Type -> IO TypeConstraint) -> IO TypeConstraint

208existsNumber f =

239existsNumber f =

209− do v <- variable (Is Number)

240+ do v <- mkVar (Just Number)

210− ex [v] <$> f (varN v)

241+ ex [v] <$> f (VarN v)

211−

212−

213−-- TYPES TO PRETTY STRINGS

214−

215−instance PrettyType a => PrettyType (UF.Point a) where

216− pretty when point =

217− unsafePerformIO $ fmap (pretty when) (UF.descriptor point)

218−

219−

220−instance PrettyType a => PrettyType (Term1 a) where

221− pretty when term =

222− let prty = pretty Never in

223− case term of

224− App1 f x ->

225− parensIf needed (px <+> pretty App x)

226− where

227− px = prty f

228− needed =

229− case when of

230− App -> True

231− _ -> False

232−

233− Fun1 arg body ->

234− parensIf needed (pretty Fn arg <+> P.text "->" <+> prty body)

235− where

236− needed =

237− case when of

238− Never -> False

239− _ -> True

240−

241− Var1 x ->

242− prty x

243−

244− EmptyRecord1 ->

245− P.braces P.empty

246−

247− Record1 fields ext ->

248− P.braces (extend <+> commaSep prettyFields)

249− where

250− prettyExt = prty ext

251−

252− extend

253− | P.render prettyExt == "{}" =

254− P.empty

255− | otherwise =

256− prettyExt <+> P.text "|"

257−

258− mkPretty f t =

259− P.text f <+> P.text ":" <+> prty t

260−

261− prettyFields =

262− concatMap (\(f,ts) -> map (mkPretty f) ts) (Map.toList fields)

263−

264−

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

266− pretty when term =

267− case term of

268− PlaceHolder _ ->

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

270−

271− VarN alias x ->

272− either alias (pretty when x)

273−

274− TermN alias t1 ->

275− either alias (pretty when t1)

276− where

277− either maybeAlias doc =

278− case maybeAlias of

279− Nothing -> doc

280− Just (name, args) ->

281− P.hang

282− (P.text (Var.toString name))

283− 2

284− (P.sep (map (pretty App . snd) args))

285−

286−

287−instance PrettyType Descriptor where

288− pretty when desc =

289− case (alias desc, structure desc, name desc) of

290− (Just (name, args), _, _) ->

291− P.hang

292− (P.text (Var.toString name))

293− 4

294− (P.sep (map (pretty App . snd) args))

295−

296− (_, Just term, _) ->

297− pretty when term

298−

299− (_, _, Just name)

300− | Var.isTuple name ->

301− P.parens . P.text $ replicate (read (drop 6 (Var.toString name)) - 1) ','

302− | otherwise ->

303− P.text (Var.toString name)

304−

305− _ -> P.text "?"

306−

307−

308−instance (PrettyType a, PrettyType b) => PrettyType (Constraint a b) where

309− pretty _ constraint =

310− let prty = pretty Never in

311− case constraint of

312− CTrue ->

313− P.text "True"

314−

315− CSaveEnv ->

316− P.text "SaveTheEnvironment!!!"

317−

318− CEqual _ _ a b ->

319− prty a <+> P.text "=" <+> prty b

320−

321− CAnd [] ->

322− P.text "True"

323−

324− CAnd cs ->

325− P.parens . P.sep $ P.punctuate (P.text " and") (map (pretty Never) cs)

326−

327− CLet [Scheme [] fqs constraint header] CTrue | Map.null header ->

328− P.sep [ binder, pretty Never c ]

329− where

330− mergeExists vs c =

331− case c of

332− CLet [Scheme [] fqs' c' _] CTrue -> mergeExists (vs ++ fqs') c'

333− _ -> (vs, c)

334−

335− (fqs', c) = mergeExists fqs constraint

336−

337− binder =

338− if null fqs'

339− then P.empty

340− else

341− P.text "\x2203" <+> P.hsep (map (pretty Never) fqs') <> P.text "."

342−

343− CLet schemes constraint ->

344− P.fsep

345− [ P.hang (P.text "let") 4 (P.brackets . commaSep $ map (pretty Never) schemes)

346− , P.text "in", pretty Never constraint

347− ]

348

242

349− CInstance _region name tipe ->

350− P.text name <+> P.text "<" <+> prty tipe

351

243

352

244

353−instance (PrettyType a, PrettyType b) => PrettyType (Scheme a b) where

245+-- CONVERT TO SOURCE TYPES

354− pretty _ (Scheme rqs fqs constraint headers) =

355− P.sep [ forall, cs, headers' ]

356− where

357− prty = pretty Never

358−

359− forall =

360− if null rqs && null fqs

361− then P.empty

362− else P.text "\x2200" <+> frees <+> rigids

363−

364− frees = P.hsep (map prty fqs)

365−

366− rigids =

367− if null rqs

368− then P.empty

369− else P.braces . P.hsep $ map prty rqs

370

246

371− cs =

372− case constraint of

373− CTrue -> P.empty

374− CAnd [] -> P.empty

375− _ -> P.brackets (pretty Never constraint)

376

247

377− headers' =

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

378− if Map.size headers > 0 then dict else P.empty

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

250+toSrcType :: Variable -> IO T.Canonical

251+toSrcType variable =

252+ do usedNames <- getVarNames variable

253+ State.evalStateT (variableToSrcType variable) (makeNameState usedNames)

379

254

380− dict =

381− P.parens . commaSep . map prettyPair $ Map.toList headers

382

255

383− prettyPair (fieldName, A.A _ tipe) =

256+variableToSrcType :: Variable -> StateT NameState IO T.Canonical

384− P.text fieldName <+> P.text ":" <+> pretty Never tipe

257+variableToSrcType variable =

258+ do descriptor <- State.liftIO (UF.descriptor variable)

259+ case _content descriptor of

260+ Structure term ->

261+ termToSrcType term

385

262

263+ Atom name ->

264+ return (T.Type name)

386

265

387−-- CONVERT TO SOURCE TYPES

266+ Var _ _ (Just name) ->

267+ return (T.Var name)

388

268

389−-- TODO: Attach resulting type to the descriptor so that you

269+ Var flex maybeSuper Nothing ->

390−-- never have to do extra work, particularly nice for aliased types

270+ do freshName <- getFreshName maybeSuper

391−toSrcType :: Variable -> IO T.Canonical

271+ State.liftIO $ UF.modifyDescriptor variable $ \desc ->

392−toSrcType variable =

272+ desc { _content = Var flex maybeSuper (Just freshName) }

393− do addNames variable

273+ return (T.Var freshName)

394− variableToSrcType variable variable

395

274

275+ Alias name args realVariable ->

276+ do srcArgs <- mapM (\(arg,tvar) -> (,) arg <$> variableToSrcType tvar) args

277+ srcType <- variableToSrcType realVariable

278+ return (T.Aliased name srcArgs (T.Filled srcType))

396

279

397−variableToSrcType :: Variable -> Variable -> IO T.Canonical

280+ Error ->

398−variableToSrcType rootVariable variable =

399− do desc <- UF.descriptor variable

400− srcType <- maybe (backupSrcType desc) (termToSrcType rootVariable) (structure desc)

401− case alias desc of

402− Nothing ->

403− return srcType

281+ return (T.Var "?")

404

282

405− Just (name, args) ->

406− case srcType of

407− T.Type (Var.Canonical Var.BuiltIn _) ->

408− return srcType

409

283

410− _ ->

411− do args' <- mapM (\(arg,tvar) -> (,) arg <$> variableToSrcType rootVariable tvar) args

412− return (T.Aliased name args' (T.Filled srcType))

413− where

414− backupSrcType :: Descriptor -> IO T.Canonical

415− backupSrcType desc =

416− case name desc of

417− Just v@(Var.Canonical _ x@(c:_))

418− | Char.isLower c ->

419− return (T.Var x)

420− | otherwise ->

421− return $ T.Type v

422−

423− _ ->

424− error $

425− concat

426− [ "Problem converting the following type "

427− , "from a type-checker type to a source-syntax type:"

428− , P.render (pretty Never rootVariable)

429− ]

430−

431−

432−termToSrcType :: Variable -> Term1 Variable -> IO T.Canonical

284+termToSrcType :: Term1 Variable -> StateT NameState IO T.Canonical

433−termToSrcType rootVariable term =

285+termToSrcType term =

434− let go = variableToSrcType rootVariable in

435 case term of

286 case term of

436− App1 a b ->

287+ App1 func arg ->

437− do a' <- go a

288+ do srcFunc <- variableToSrcType func

438− b' <- go b

289+ srcArg <- variableToSrcType arg

439− case a' of

290+ case srcFunc of

440 T.App f args ->

291 T.App f args ->

441− return $ T.App f (args ++ [b'])

292+ return (T.App f (args ++ [srcArg]))

293+

442 _ ->

294 _ ->

443− return $ T.App a' [b']

295+ return (T.App srcFunc [srcArg])

444

296

445 Fun1 a b ->

297 Fun1 a b ->

446− T.Lambda <$> go a <*> go b

298+ T.Lambda

447−

299+ <$> variableToSrcType a

448− Var1 a ->

300+ <*> variableToSrcType b

449− go a

450

301

451 EmptyRecord1 ->

302 EmptyRecord1 ->

452 return $ T.Record [] Nothing

303 return $ T.Record [] Nothing

453

304

454− Record1 tfields extension ->

305+ Record1 fields extension ->

455− do fields' <- Traverse.traverse (mapM go) tfields

306+ do srcFields <- Map.toList <$> Traverse.traverse variableToSrcType fields

456− let fields = concat [ map ((,) name) ts | (name,ts) <- Map.toList fields' ]

307+ srcExt <- T.iteratedDealias <$> variableToSrcType extension

457− ext' <- dealias <$> go extension

458 return $

308 return $

459− case ext' of

309+ case srcExt of

460− T.Record fs ext -> T.Record (fs ++ fields) ext

310+ T.Record subFields subExt ->

461− T.Var _ -> T.Record fields (Just ext')

311+ T.Record (subFields ++ srcFields) subExt

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

463− where

464− dealias :: T.Canonical -> T.Canonical

465− dealias tipe =

466− case tipe of

467− T.Aliased _ args tipe' ->

468− T.dealias args tipe'

469− _ ->

470− tipe

471

312

313+ T.Var _ ->

314+ T.Record srcFields (Just srcExt)

472

315

473−-- ADD NAMES TO TYPES

316+ _ ->

317+ error "Used toSrcType on a type that is not well-formed"

474

318

475−addNames :: Variable -> IO ()

476−addNames variable =

477− do usedNames <- getVarNames variable

478− let freeNames = makeFreeNames usedNames

479− State.runStateT (varAddNames variable) (NameState freeNames 0 0 0)

480− return ()

481

319

482

320

483−makeFreeNames :: Set.Set String -> [String]

321+-- MANAGE FRESH VARIABLE NAMES

484−makeFreeNames usedNames =

485− let makeName suffix =

486− map (:suffix) ['a'..'z']

487−

488− allNames =

489− concatMap makeName ("" : "'" : "_" : map show [ (0 :: Int) .. ])

490− in

491− filter (\name -> Set.notMember name usedNames) allNames

492

322

493

323

494data NameState = NameState

324data NameState = NameState

495− { freeNames :: [String]

325+ { _freeNames :: [String]

496− , numberPrimes :: Int

326+ , _numberPrimes :: Int

497− , comparablePrimes :: Int

327+ , _comparablePrimes :: Int

498− , appendablePrimes :: Int

328+ , _appendablePrimes :: Int

329+ , _compAppendPrimes :: Int

499 }

330 }

500

331

501

332

502−varAddNames :: Variable -> StateT NameState IO ()

333+makeNameState :: Set.Set String -> NameState

503−varAddNames var =

334+makeNameState usedNames =

504− do desc <- State.liftIO (UF.descriptor var)

335+ let

505− case alias desc of

336+ makeName suffix =

506− Nothing ->

337+ map (:suffix) ['a'..'z']

507− return ()

508−

509− Just (_name, args) ->

510− mapM_ (\(v,t) -> (,) v <$> varAddNames t) args

511−

512− case structure desc of

513− Just term ->

514− termAddNames term

515−

516− Nothing ->

517− case name desc of

518− Just _ -> return ()

519− Nothing ->

520− do name' <- createName desc

521− State.liftIO $ UF.modifyDescriptor var $ \desc ->

522− desc { name = Just (Var.local name') }

523−

524−

525−termAddNames :: Term1 Variable -> StateT NameState IO ()

526−termAddNames term =

527− case term of

528− App1 a b ->

529− do varAddNames a

530− varAddNames b

531

338

532− Fun1 a b ->

339+ allNames =

533− do varAddNames a

340+ concatMap makeName ("" : map show [ (1 :: Int) .. ])

534− varAddNames b

535

341

536− Var1 a ->

342+ freeNames =

537− varAddNames a

343+ filter (\name -> Set.notMember name usedNames) allNames

344+ in

345+ NameState freeNames 0 0 0 0

538

346

539− EmptyRecord1 ->

540− return ()

541−

542− Record1 fields extension ->

543− do mapM_ varAddNames (concat (Map.elems fields))

544− varAddNames extension

545

347

348+getFreshName :: (Monad m) => Maybe Super -> StateT NameState m String

349+getFreshName maybeSuper =

350+ case maybeSuper of

351+ Nothing ->

352+ do names <- State.gets _freeNames

353+ State.modify (\state -> state { _freeNames = tail names })

354+ return (head names)

546

355

547−createName :: (Monad m) => Descriptor -> StateT NameState m String

548−createName desc =

549− case flex desc of

550− Is Number ->

356+ Just Number ->

551− do primes <- State.gets numberPrimes

357+ do primes <- State.gets _numberPrimes

552− State.modify (\state -> state { numberPrimes = primes + 1 })

358+ State.modify (\state -> state { _numberPrimes = primes + 1 })

553 return ("number" ++ replicate primes '\'')

359 return ("number" ++ replicate primes '\'')

554

360

555− Is Comparable ->

361+ Just Comparable ->

556− do primes <- State.gets comparablePrimes

362+ do primes <- State.gets _comparablePrimes

557− State.modify (\state -> state { comparablePrimes = primes + 1 })

363+ State.modify (\state -> state { _comparablePrimes = primes + 1 })

558 return ("comparable" ++ replicate primes '\'')

364 return ("comparable" ++ replicate primes '\'')

559

365

560− Is Appendable ->

366+ Just Appendable ->

561− do primes <- State.gets appendablePrimes

367+ do primes <- State.gets _appendablePrimes

562− State.modify (\state -> state { appendablePrimes = primes + 1 })

368+ State.modify (\state -> state { _appendablePrimes = primes + 1 })

563 return ("appendable" ++ replicate primes '\'')

369 return ("appendable" ++ replicate primes '\'')

564

370

565− _ ->

371+ Just CompAppend ->

566− do names <- State.gets freeNames

372+ do primes <- State.gets _compAppendPrimes

567− State.modify (\state -> state { freeNames = tail names })

373+ State.modify (\state -> state { _compAppendPrimes = primes + 1 })

568− return (head names)

374+ return ("compappend" ++ replicate primes '\'')

375+

569

376

570

377

571-- GET ALL VARIABLE NAMES

378-- GET ALL VARIABLE NAMES

572

379

380+

573getVarNames :: Variable -> IO (Set.Set String)

381getVarNames :: Variable -> IO (Set.Set String)

574getVarNames var =

382getVarNames var =

575 do desc <- UF.descriptor var

383 do desc <- UF.descriptor var

576

384

577− let baseSet =

578− case name desc of

385+ case _content desc of

386+ Var _ _ (Just name) ->

579− Just var -> Set.singleton (Var.toString var)

387+ return (Set.singleton name)

388+

389+ Var _ _ Nothing ->

580− Nothing -> Set.empty

390+ return Set.empty

581

391

582− structureSet <-

392+ Structure term ->

583− case structure desc of

584− Nothing -> return Set.empty

585− Just term -> getVarNamesTerm term

393+ getVarNamesTerm term

586

394

587− aliasSet <-

395+ Alias _name args realVar ->

588− case alias desc of

396+ do let argSet = Set.fromList (map fst args)

589− Nothing ->

397+ realSet <- getVarNames realVar

590− return Set.empty

398+ sets <- mapM (getVarNames . snd) args

399+ return (Set.unions (realSet : argSet : sets))

591

400

592− Just (_name, args) ->

401+ Atom _ ->

593− do let set = Set.fromList (map fst args)

594− sets <- mapM (getVarNames . snd) args

595− return (Set.unions (set : sets))

402+ return Set.empty

596

403

597− return (Set.unions [ baseSet, structureSet, aliasSet ])

404+ Error ->

405+ return Set.empty

598

406

599

407

600getVarNamesTerm :: Term1 Variable -> IO (Set.Set String)

408getVarNamesTerm :: Term1 Variable -> IO (Set.Set String)

@@ -607,43 +415,10 @@ getVarNamesTerm term =

607 Fun1 a b ->

415 Fun1 a b ->

608 Set.union <$> go a <*> go b

416 Set.union <$> go a <*> go b

609

417

610− Var1 a ->

611− go a

612−

613 EmptyRecord1 ->

418 EmptyRecord1 ->

614 return Set.empty

419 return Set.empty

615

420

616 Record1 fields extension ->

421 Record1 fields extension ->

617− do fieldVars <- Set.unions <$> mapM go (concat (Map.elems fields))

422+ do fieldVars <- Set.unions <$> mapM go (Map.elems fields)

618 Set.union fieldVars <$> go extension

423 Set.union fieldVars <$> go extension

619

424

620−

621−-- COLLECT APPLICATIONS

622−

623−data AppStructure

624− = List Variable

625− | Tuple [Variable]

626− | Other

627−

628−

629−collectApps :: Variable -> IO AppStructure

630−collectApps var =

631− go [] var

632− where

633− go vars var = do

634− desc <- UF.descriptor var

635− case (structure desc, vars) of

636− (Nothing, [v]) ->

637− case name desc of

638− Just n | Var.isList n -> return (List v)

639− _ -> return Other

640−

641− (Nothing, vs) ->

642− case name desc of

643− Just n | Var.isTuple n -> return (Tuple vs)

644− _ -> return Other

645−

646− (Just term, _) ->

647− case term of

648− App1 a b -> go (vars ++ [b]) a

649− _ -> return Other

src/Type/Unify.hs+593−376

@@ -1,12 +1,10 @@

1+{-# OPTIONS_GHC -Wall #-}

1module Type.Unify (unify) where

2module Type.Unify (unify) where

3−import Control.Applicative ((<|>))

4+import Control.Monad (zipWithM_)

4−import Control.Monad.Except (ExceptT, throwError, runExceptT)

5+import Control.Monad.Except (ExceptT, lift, liftIO, throwError, runExceptT)

5−import Control.Monad.State as State

6−import qualified Data.List as List

7import qualified Data.Map as Map

6import qualified Data.Map as Map

8import qualified Data.UnionFind.IO as UF

7import qualified Data.UnionFind.IO as UF

9−import Text.PrettyPrint (render)

11import qualified AST.Type as AstType

9import qualified AST.Type as AstType

12import qualified AST.Variable as Var

10import qualified AST.Variable as Var

@@ -14,435 +12,654 @@ import qualified Reporting.Region as R

14import qualified Reporting.Error.Type as Error

12import qualified Reporting.Error.Type as Error

15import qualified Type.State as TS

13import qualified Type.State as TS

16import Type.Type as Type

14import Type.Type as Type

17−import Type.PrettyPrint

15+

18−import Elm.Utils ((|>))

16+

19−

17+

20−

18+-- KICK OFF UNIFICATION

21−unify

19+

22− :: Error.Hint

20+

23− -> R.Region

21+unify :: Error.Hint -> R.Region -> Variable -> Variable -> TS.Solver ()

24− -> Variable

25− -> Variable

26− -> StateT TS.SolverState IO ()

27−unify hint region variable1 variable2 =

22+unify hint region expected actual =

28− do result <- runExceptT (unifyHelp variable1 variable2)

23+ do result <- runExceptT (guardedUnify ExpectedActual expected actual)

29 case result of

24 case result of

30 Right state ->

25 Right state ->

31 return state

26 return state

33− Left (RawMismatch (leftType, rightType, note)) ->

28+ Left (Mismatch leftType rightType maybeReason) ->

29+ do rootType <- liftIO (Type.toSrcType expected)

34− TS.addError region $ Error.Mismatch $

30+ TS.addError region $ Error.Mismatch $

35− Error.MismatchInfo hint leftType rightType note

31+ Error.MismatchInfo hint rootType leftType rightType maybeReason

32+

38−-- ACTUALLY UNIFY STUFF

35+-- UNIFICATION HELPERS

36+

40type Unify =

38type Unify =

41− ExceptT RawMismatch (StateT TS.SolverState IO)

39+ ExceptT Mismatch TS.Solver

40+

41+

42+data Context = Context

43+ { _orientation :: Orientation

44+ , _first :: Variable

45+ , _firstDesc :: Descriptor

46+ , _second :: Variable

47+ , _secondDesc :: Descriptor

48+ }

49+

50+

51+data Orientation = ExpectedActual | ActualExpected

52+

53+

54+reorient :: Context -> Context

55+reorient (Context orientation var1 desc1 var2 desc2) =

56+ let

57+ otherOrientation =

58+ case orientation of

59+ ExpectedActual -> ActualExpected

60+ ActualExpected -> ExpectedActual

61+ in

62+ Context otherOrientation var2 desc2 var1 desc1

63+

64+

65+

66+-- ERROR MESSAGES

67+

68+

69+data Mismatch

70+ = Mismatch AstType.Canonical AstType.Canonical (Maybe Error.Reason)

71+

73+mismatch :: Context -> Maybe Error.Reason -> Unify a

74+mismatch (Context orientation first _ second _) maybeReason =

75+ let

76+ (expected, actual) =

77+ case orientation of

78+ ExpectedActual ->

79+ (first, second)

80+

81+ ActualExpected ->

82+ (second, first)

83+ in

84+ do errorMsg <- liftIO $

85+ do expectedSrcType <- Type.toSrcType expected

86+ actualSrcType <- Type.toSrcType actual

87+ return (Mismatch expectedSrcType actualSrcType maybeReason)

88+ mergeHelp expected actual Error

89+ throwError errorMsg

90+

91+

92+rigidityError :: Context -> Maybe String -> Unify ()

93+rigidityError context maybeName =

94+ mismatch context (Just (Error.Rigid maybeName))

95+

96+

97+

98+-- MERGE

99+

100+

101+merge :: Context -> Content -> Unify ()

102+merge (Context _ first _ second _) content =

103+ mergeHelp first second content

104+

105+

106+mergeHelp :: Variable -> Variable -> Content -> Unify ()

107+mergeHelp first second content =

108+ liftIO $ UF.union' first second $ \desc1 desc2 ->

109+ return $

110+ Descriptor

111+ { _content = content

112+ , _rank = min (_rank desc1) (_rank desc2)

113+ , _mark = noMark

114+ , _copy = Nothing

115+ }

116

44−newtype RawMismatch =

45− RawMismatch (AstType.Canonical, AstType.Canonical, Maybe String)

117

118+fresh :: Context -> Content -> Unify Variable

119+fresh (Context _ _ desc1 _ desc2) content =

120+ do freshVariable <-

121+ liftIO $ UF.fresh $

122+ Descriptor

123+ { _content = content

124+ , _rank = min (_rank desc1) (_rank desc2)

125+ , _mark = noMark

126+ , _copy = Nothing

127+ }

128+ lift (TS.register freshVariable)

129

48−typeError

49− :: UF.Point Descriptor

50− -> UF.Point Descriptor

51− -> Maybe String

52− -> Unify a

53−typeError leftType rightType note =

54− do leftSrcType <- liftIO (Type.toSrcType leftType)

55− rightSrcType <- liftIO (Type.toSrcType rightType)

56− liftIO $ do

57− UF.setDescriptor leftType (Type.descriptor Error)

58− UF.setDescriptor rightType (Type.descriptor Error)

59− throwError (RawMismatch (leftSrcType, rightSrcType, note))

130

131

132+-- ACTUALLY UNIFY THINGS

133+

134+

62−unifyHelp :: Variable -> Variable -> Unify ()

135+guardedUnify :: Orientation -> Variable -> Variable -> Unify ()

63−unifyHelp variable1 variable2 =

136+guardedUnify orientation left right =

64− do equivalent <- liftIO $ UF.equivalent variable1 variable2

137+ do equivalent <- liftIO $ UF.equivalent left right

65 if equivalent

138 if equivalent

66− then return ()

139+ then return ()

67− else actuallyUnify variable1 variable2

140+ else

68−

69−

70−actuallyUnify :: Variable -> Variable -> Unify ()

71−actuallyUnify variable1 variable2 = do

72− desc1 <- liftIO $ UF.descriptor variable1

141+ do leftDesc <- liftIO $ UF.descriptor left

73− desc2 <- liftIO $ UF.descriptor variable2

142+ rightDesc <- liftIO $ UF.descriptor right

74− let name' = pickName desc1 desc2

143+ actuallyUnify (Context orientation left leftDesc right rightDesc)

75− flex' = pickFlex desc1 desc2

76− rank' = pickRank desc1 desc2

77− alias' = pickAlias desc1 desc2

78−

79− merge1 :: Unify ()

80− merge1 =

81− liftIO $ do

82− if rank desc1 < rank desc2

83− then UF.union variable2 variable1

84− else UF.union variable1 variable2

85− UF.modifyDescriptor variable1 $ \desc ->

86− desc { structure = structure desc1

87− , flex = flex'

88− , name = name'

89− , alias = alias'

90− }

91−

92− merge2 :: Unify ()

93− merge2 =

94− liftIO $ do

95− if rank desc1 < rank desc2

96− then UF.union variable2 variable1

97− else UF.union variable1 variable2

98− UF.modifyDescriptor variable2 $ \desc ->

99− desc { structure = structure desc2

100− , flex = flex'

101− , name = name'

102− , alias = alias'

103− }

104−

105− merge =

106− if rank desc1 < rank desc2 then merge1 else merge2

107−

108− fresh :: Maybe (Term1 Variable) -> Unify Variable

109− fresh structure =

110− do v <- liftIO . UF.fresh $ Descriptor

111− { structure = structure

112− , rank = rank'

113− , flex = flex'

114− , name = name'

115− , copy = Nothing

116− , mark = noMark

117− , alias = alias'

118− }

119− lift (TS.register v)

120−

121− flexAndUnify v =

122− do liftIO $ UF.modifyDescriptor v $ \desc -> desc { flex = Flexible }

123− unifyHelp variable1 variable2

124−

125− unifyNumber svar (Var.Canonical home name) =

126− case home of

127− Var.BuiltIn | name `elem` ["Int","Float"] ->

128− flexAndUnify svar

129−

130− Var.Local | List.isPrefixOf "number" name ->

131− flexAndUnify svar

132−

133− Var.TopLevel _ | List.isPrefixOf "number" name ->

134− flexAndUnify svar

135−

136− _ ->

137− typeError variable1 variable2 Nothing

138−

139− comparableError maybeHint =

140− typeError variable1 variable2 $ Just $

141− "Note: comparable types include Int, Float, Char, String, lists, and tuples."

142− ++ maybe "" ("\n"++) maybeHint

143−

144− appendableError =

145− typeError variable1 variable2 $ Just $

146− "Note: appendable types include only Strings, Lists, and Text."

147−

148− unifyComparable v (Var.Canonical home name) =

149− case home of

150− Var.BuiltIn | name `elem` ["Int","Float","Char","String"] ->

151− flexAndUnify v

152− Var.Local | List.isPrefixOf "comparable" name ->

153− flexAndUnify v

154− _ ->

155− comparableError Nothing

156−

157− unifyComparableStructure varSuper varFlex =

158− do struct <- liftIO $ collectApps varFlex

159− case struct of

160− Other ->

161− comparableError Nothing

162−

163− List v ->

164− do flexAndUnify varSuper

165− unifyHelp v =<< liftIO (variable $ Is Comparable)

166−

167− Tuple vs ->

168− if length vs > 6 then

169− comparableError $ Just $

170− "Furthermore, it cannot be a tuple with more than 6 elements."

171− else

172− do flexAndUnify varSuper

173− cmpVars <- liftIO $ forM [1..length vs] $ \_ -> variable (Is Comparable)

174− zipWithM_ unifyHelp vs cmpVars

175−

176− unifyAppendable v cvar =

177− let

178− canUnify =

179− Var.isPrim "String" cvar

180− || Var.isText cvar

181− || Var.isLocal (List.isPrefixOf "comparable") cvar

182− || Var.isLocal (List.isPrefixOf "appendable") cvar

183− in

184− if canUnify then

185− flexAndUnify v

186− else

187− appendableError

188−

189− unifyAppendableStructure varSuper varFlex =

190− do struct <- liftIO $ collectApps varFlex

191− case struct of

192− List _ -> flexAndUnify varSuper

193− _ -> appendableError

194−

195− rigidError var =

196− typeError variable1 variable2 $ Just $

197− rigidErrorMessage (render (pretty Never var))

198−

199− superUnify =

200− case (flex desc1, flex desc2, name desc1, name desc2) of

201− (Is super1, Is super2, _, _)

202− | super1 == super2 -> merge

203− (Is Number, Is Comparable, _, _) -> merge1

204− (Is Comparable, Is Number, _, _) -> merge2

205−

206− (Is Number, _, _, Just name) -> unifyNumber variable1 name

207− (_, Is Number, Just name, _) -> unifyNumber variable2 name

208−

209− (Is Appendable, _, _, Just name) -> unifyAppendable variable1 name

210− (_, Is Appendable, Just name, _) -> unifyAppendable variable2 name

211− (Is Appendable, _, _, _) -> unifyAppendableStructure variable1 variable2

212− (_, Is Appendable, _, _) -> unifyAppendableStructure variable2 variable1

213−

214− (Is Comparable, _, _, Just name) -> unifyComparable variable1 name

215− (_, Is Comparable, Just name, _) -> unifyComparable variable2 name

216− (Is Comparable, _, _, _) -> unifyComparableStructure variable1 variable2

217− (_, Is Comparable, _, _) -> unifyComparableStructure variable2 variable1

218−

219− (Rigid, _, _, _) -> rigidError variable1

220− (_, Rigid, _, _) -> rigidError variable2

221− _ -> typeError variable1 variable2 Nothing

222−

223− case (structure desc1, structure desc2) of

224− (Nothing, Nothing)

225− | flex desc1 == Flexible && flex desc1 == Flexible ->

226− merge

227−

228− (Nothing, _)

229− | flex desc1 == Flexible -> merge2

230− | flex desc1 == Error -> return ()

231−

232− (_, Nothing)

233− | flex desc2 == Flexible -> merge1

234− | flex desc2 == Error -> return ()

235−

236− (Just (Var1 v), _) ->

237− unifyHelp v variable2

238−

239− (_, Just (Var1 v)) ->

240− unifyHelp variable1 v

241−

242− (Nothing, _) ->

243− superUnify

244−

245− (_, Nothing) ->

246− superUnify

247−

248− (Just type1, Just type2) ->

249− case (type1,type2) of

250− (App1 term1 term2, App1 term1' term2') ->

251− do merge

252− unifyHelp term1 term1'

253− unifyHelp term2 term2'

254− (Fun1 term1 term2, Fun1 term1' term2') ->

255− do merge

256− unifyHelp term1 term1'

257− unifyHelp term2 term2'

258

144

259− (EmptyRecord1, EmptyRecord1) ->

260− return ()

261

145

262− (Record1 fields ext, EmptyRecord1) | Map.null fields -> unifyHelp ext variable2

146+subUnify :: Context -> Variable -> Variable -> Unify ()

263− (EmptyRecord1, Record1 fields ext) | Map.null fields -> unifyHelp variable1 ext

147+subUnify context var1 var2 =

148+ guardedUnify (_orientation context) var1 var2

149+

264

150

265− (Record1 _ _, Record1 _ _) ->

151+actuallyUnify :: Context -> Unify ()

266− recordUnify fresh variable1 variable2

152+actuallyUnify context@(Context _ _ firstDesc _ secondDesc) =

153+ let

154+ secondContent = _content secondDesc

155+ in

156+ case _content firstDesc of

157+ Error ->

158+ -- If there was an error, just pretend it is okay. This lets us avoid

159+ -- "cascading" errors where one problem manifests as multiple message.

160+ return ()

267

161

268− _ -> typeError variable1 variable2 Nothing

162+ Var Flex Nothing _ ->

163+ unifyFlex context secondContent

269

164

165+ Var Flex (Just super) _ ->

166+ unifySuper context super secondContent

270

167

271−-- RIGID ERROR

168+ Var Rigid maybeSuper maybeName ->

169+ unifyRigid context maybeSuper maybeName secondContent

272

170

273−rigidErrorMessage :: String -> String

171+ Atom name ->

274−rigidErrorMessage var =

172+ unifyAtom context name secondContent

275− "Could not unify user provided type variable `" ++ var ++ "`. The most likely cases are:\n\n"

276− ++ " 1. The type you wrote down is too general. It says any type can go through\n"

277− ++ " but in fact only a certain type can.\n"

278− ++ " 2. A type variable is probably being shared between two type annotations.\n"

279− ++ " They are treated as different things in the current implementation, so\n"

280− ++ " Try commenting out some type annotations and see what happens."

281

173

174+ Alias name args realVar ->

175+ unifyAlias context name args realVar secondContent

282

176

283−-- RECORD UNIFICATION

177+ Structure term ->

178+ unifyStructure context term secondContent

284

179

285−recordUnify

286− :: (Maybe (Term1 Variable) -> Unify Variable)

287− -> Variable

288− -> Variable

289− -> Unify ()

290−recordUnify fresh variable1 variable2 =

291− do (ExpandedRecord fields1 ext1) <- liftIO (gatherFields variable1)

292− (ExpandedRecord fields2 ext2) <- liftIO (gatherFields variable2)

293

180

294− unifyOverlappingFields fields1 fields2

295

181

296− let freshRecord fields ext =

182+-- UNIFY FLEXIBLE VARIABLES

297− fresh (Just (Record1 fields ext))

298

183

299− let uniqueFields1 = diffFields fields1 fields2

300− let uniqueFields2 = diffFields fields2 fields1

301

184

302− let addFieldMismatchError missingFields =

185+unifyFlex :: Context -> Content -> Unify ()

303− typeError variable1 variable2 $ Just $

186+unifyFlex context otherContent =

304− fieldMismatchError missingFields

187+ case otherContent of

188+ Error ->

189+ return ()

305

190

306− case (ext1, ext2) of

191+ Var Flex _ _ ->

307− (Empty _, Empty _) ->

192+ merge context otherContent

308− case Map.null uniqueFields1 && Map.null uniqueFields2 of

309− True -> return ()

310− False -> typeError variable1 variable2 Nothing

311

193

312− (Empty var1, Extension var2) ->

194+ Var Rigid _ _ ->

313− case (Map.null uniqueFields1, Map.null uniqueFields2) of

195+ merge context otherContent

314− (_, False) -> addFieldMismatchError uniqueFields2

315− (True, True) -> unifyHelp var1 var2

316− (False, True) ->

317− do subRecord <- freshRecord uniqueFields1 var1

318− unifyHelp subRecord var2

319

196

320− (Extension var1, Empty var2) ->

197+ Atom _ ->

321− case (Map.null uniqueFields1, Map.null uniqueFields2) of

198+ merge context otherContent

322− (False, _) -> addFieldMismatchError uniqueFields1

323− (True, True) -> unifyHelp var1 var2

324− (True, False) ->

325− do subRecord <- freshRecord uniqueFields2 var2

326− unifyHelp var1 subRecord

327

199

328− (Extension var1, Extension var2) ->

200+ Alias _ _ _ ->

329− case (Map.null uniqueFields1, Map.null uniqueFields2) of

201+ merge context otherContent

330− (True, True) ->

331− unifyHelp var1 var2

332

202

203+ Structure _ ->

204+ merge context otherContent

205+

206+

207+

208+-- UNIFY RIGID VARIABLES

209+

210+

211+unifyRigid :: Context -> Maybe Super -> Maybe String -> Content -> Unify ()

212+unifyRigid context maybeSuper maybeName otherContent =

213+ case otherContent of

214+ Error ->

215+ return ()

216+

217+ Var Flex otherMaybeSuper _ ->

218+ if maybeSuper == otherMaybeSuper then

219+ merge context (Var Rigid maybeSuper maybeName)

220+ else

221+ rigidityError context maybeName

222+

223+ Var Rigid _ _ ->

224+ rigidityError context maybeName

225+

226+ Atom _ ->

227+ rigidityError context maybeName

228+

229+ Alias _ _ _ ->

230+ rigidityError context maybeName

231+

232+ Structure _ ->

233+ rigidityError context maybeName

234+

235+

236+-- UNIFY SUPER VARIABLES

237+

238+

239+unifySuper :: Context -> Super -> Content -> Unify ()

240+unifySuper context super otherContent =

241+ case otherContent of

242+ Structure term ->

243+ unifySuperStructure context super term

244+

245+ Atom name ->

246+ if atomMatchesSuper super name then

247+ merge context otherContent

248+ else

249+ mismatch context Nothing

250+

251+ Var Rigid Nothing maybeName ->

252+ rigidityError context maybeName

253+

254+ Var Rigid (Just otherSuper) maybeName ->

255+ if super == otherSuper then

256+ merge context otherContent

257+ else

258+ rigidityError context maybeName

259+

260+ Var Flex Nothing _ ->

261+ merge context (Var Flex (Just super) Nothing)

262+

263+ Var Flex (Just otherSuper) _ ->

264+ case combineSupers super otherSuper of

265+ Nothing ->

266+ mismatch context Nothing

267+

268+ Just newSuper ->

269+ merge context (Var Flex (Just newSuper) Nothing)

270+

271+ Alias _ _ realVar ->

272+ subUnify context (_first context) realVar

273+

274+ Error ->

275+ return ()

276+

277+

278+combineSupers :: Super -> Super -> Maybe Super

279+combineSupers firstSuper secondSuper =

280+ case (firstSuper, secondSuper) of

281+ (Number , Number ) -> Just Number

282+ (Comparable, Number ) -> Just Number

283+ (Number , Comparable) -> Just Number

284+

285+ (Comparable, Comparable) -> Just Comparable

286+ (Appendable, Appendable) -> Just Appendable

287+

288+ (Appendable, Comparable) -> Just CompAppend

289+ (Comparable, Appendable) -> Just CompAppend

290+

291+ (CompAppend, CompAppend) -> Just CompAppend

292+ (CompAppend, Comparable) -> Just CompAppend

293+ (Comparable, CompAppend) -> Just CompAppend

294+ (CompAppend, Appendable) -> Just CompAppend

295+ (Appendable, CompAppend) -> Just CompAppend

296+

297+ (_ , _ ) -> Nothing

298+

299+

300+isPrimitiveFrom :: [String] -> Var.Canonical -> Bool

301+isPrimitiveFrom prims var =

302+ any (\p -> Var.isPrim p var) prims

303+

304+

305+atomMatchesSuper :: Super -> Var.Canonical -> Bool

306+atomMatchesSuper super name =

307+ case super of

308+ Number ->

309+ isPrimitiveFrom ["Int", "Float"] name

310+

311+ Comparable ->

312+ isPrimitiveFrom ["Int", "Float", "Char", "String"] name

313+

314+ Appendable ->

315+ Var.isPrim "String" name || Var.isText name

316+

317+ CompAppend ->

318+ Var.isPrim "String" name

319+

320+

321+unifySuperStructure :: Context -> Super -> Term1 Variable -> Unify ()

322+unifySuperStructure context super term =

323+ do appStructure <- liftIO (collectApps (Structure term))

324+ case appStructure of

325+ Other ->

326+ mismatch context Nothing

327+

328+ List variable ->

329+ case super of

330+ Number ->

331+ mismatch context Nothing

332+

333+ Appendable ->

334+ merge context (Structure term)

335+

336+ Comparable ->

337+ do merge context (Structure term)

338+ unifyComparableRecursive (_orientation context) variable

339+

340+ CompAppend ->

341+ do merge context (Structure term)

342+ unifyComparableRecursive (_orientation context) variable

343+

344+ Tuple entries ->

345+ case super of

346+ Number ->

347+ mismatch context Nothing

348+

349+ Appendable ->

350+ mismatch context Nothing

351+

352+ Comparable ->

353+ if length entries > 6 then

354+ mismatch context (Just (Error.TooLongComparableTuple (length entries)))

355+

356+ else

357+ do merge context (Structure term)

358+ mapM_ (unifyComparableRecursive (_orientation context)) entries

359+

360+ CompAppend ->

361+ mismatch context Nothing

362+

363+

364+unifyComparableRecursive :: Orientation -> Variable -> Unify ()

365+unifyComparableRecursive orientation var =

366+ do compVar <-

367+ liftIO $

368+ do desc <- UF.descriptor var

369+ UF.fresh $

370+ Descriptor

371+ { _content = Var Flex (Just Comparable) Nothing

372+ , _rank = _rank desc

373+ , _mark = noMark

374+ , _copy = Nothing

375+ }

376+

377+ guardedUnify orientation compVar var

378+

379+

380+data AppStructure

381+ = List Variable

382+ | Tuple [Variable]

383+ | Other

384+

385+

386+collectApps :: Content -> IO AppStructure

387+collectApps content =

388+ collectAppsHelp [] content

389+

390+

391+collectAppsHelp :: [Variable] -> Content -> IO AppStructure

392+collectAppsHelp args content =

393+ case (content, args) of

394+ (Structure (App1 func arg), _) ->

395+ collectAppsHelp (args ++ [arg]) =<< getContent func

396+

397+ (Atom name, [arg]) | Var.isList name ->

398+ return (List arg)

399+

400+ (Atom name, _) | Var.isTuple name ->

401+ return (Tuple args)

402+

403+ _ ->

404+ return Other

405+

406+

407+getContent :: Variable -> IO Content

408+getContent variable =

409+ _content <$> UF.descriptor variable

410+

411+

412+

413+-- UNIFY ATOMS

414+

415+

416+unifyAtom :: Context -> Var.Canonical -> Content -> Unify ()

417+unifyAtom context name otherContent =

418+ case otherContent of

419+ Error ->

420+ return ()

421+

422+ Var Flex Nothing _ ->

423+ merge context (Atom name)

424+

425+ Var Flex (Just super) _ ->

426+ if atomMatchesSuper super name then

427+ merge context (Atom name)

428+

429+ else

430+ mismatch context Nothing

431+

432+ Var Rigid _ maybeName ->

433+ rigidityError context maybeName

434+

435+ Atom otherName ->

436+ if name == otherName then

437+ merge context otherContent

438+

439+ else

440+ mismatch context Nothing

441+

442+ Alias _ _ realVar ->

443+ subUnify context (_first context) realVar

444+

445+ Structure _ ->

446+ mismatch context Nothing

447+

448+

449+

450+-- UNIFY ALIASES

451+

452+unifyAlias :: Context -> Var.Canonical -> [(String, Variable)] -> Variable -> Content -> Unify ()

453+unifyAlias context name args realVar otherContent =

454+ case otherContent of

455+ Error ->

456+ return ()

457+

458+ Var Flex Nothing _ ->

459+ merge context (Alias name args realVar)

460+

461+ Var _ _ _ ->

462+ subUnify context realVar (_second context)

463+

464+ Atom _ ->

465+ subUnify context realVar (_second context)

466+

467+

468+ Alias otherName otherArgs otherRealVar ->

469+ if name == otherName then

470+ do merge context otherContent

471+ zipWithM_ (subUnify context) (map snd args) (map snd otherArgs)

472+

473+ else

474+ subUnify context realVar otherRealVar

475+

476+ Structure _ ->

477+ subUnify context realVar (_second context)

478+

479+

480+

481+-- UNIFY STRUCTURES

482+

483+

484+unifyStructure :: Context -> Term1 Variable -> Content -> Unify ()

485+unifyStructure context term otherContent =

486+ case otherContent of

487+ Error ->

488+ return ()

489+

490+ Var Flex Nothing _ ->

491+ merge context (Structure term)

492+

493+ Var Flex (Just super) _ ->

494+ unifySuper (reorient context) super (Structure term)

495+

496+ Var Rigid _ maybeName ->

497+ rigidityError context maybeName

498+

499+ Atom _ ->

500+ mismatch context Nothing

501+

502+ Alias _ _ realVar ->

503+ subUnify context (_first context) realVar

504+

505+ Structure otherTerm ->

506+ case (term, otherTerm) of

507+ (App1 func arg, App1 otherFunc otherArg) ->

508+ do merge context otherContent

509+ subUnify context func otherFunc

510+ subUnify context arg otherArg

511+

512+ (Fun1 arg result, Fun1 otherArg otherResult) ->

513+ do merge context otherContent

514+ subUnify context arg otherArg

515+ subUnify context result otherResult

516+

517+ (EmptyRecord1, EmptyRecord1) ->

518+ merge context otherContent

519+

520+ (Record1 fields ext, EmptyRecord1) | Map.null fields ->

521+ subUnify context ext (_second context)

522+

523+ (EmptyRecord1, Record1 fields ext) | Map.null fields ->

524+ subUnify context (_first context) ext

525+

526+ (Record1 fields extension, Record1 otherFields otherExtension) ->

527+ do firstStructure <- gatherFields context fields extension

528+ secondStructure <- gatherFields context otherFields otherExtension

529+ unifyRecord context firstStructure secondStructure

530+

531+ _ ->

532+ mismatch context Nothing

533+

534+

535+

536+-- UNIFY RECORDS

537+

538+

539+unifyRecord :: Context -> RecordStructure -> RecordStructure -> Unify ()

540+unifyRecord context firstStructure secondStructure =

541+ do let (RecordStructure expFields expVar expStruct) = firstStructure

542+ let (RecordStructure actFields actVar actStruct) = secondStructure

543+

544+ -- call after unifying extension, make sure record shape matches before

545+ -- looking into whether the particular field types match.

546+ let unifySharedFields otherFields ext =

547+ do let sharedFields = Map.intersectionWith (,) expFields actFields

548+ _ <- traverse (uncurry (subUnify context)) sharedFields

549+ let allFields = Map.union (Map.map fst sharedFields) otherFields

550+ merge context (Structure (Record1 allFields ext))

551+

552+ let uniqueExpFields = Map.difference expFields actFields

553+ let uniqueActFields = Map.difference actFields expFields

554+

555+ case (expStruct, actStruct) of

556+ (Empty, Empty) ->

557+ if Map.null uniqueExpFields && Map.null uniqueActFields then

558+ do mergeHelp expVar actVar (Structure EmptyRecord1)

559+ unifySharedFields Map.empty expVar

560+

561+ else

562+ mismatch context (Just (Error.MessyFields (Map.keys uniqueExpFields) (Map.keys uniqueActFields)))

563+

564+ (Empty, Extension) ->

565+ case (Map.null uniqueExpFields, Map.null uniqueActFields) of

333− (True, False) ->

566+ (_, False) ->

334− do subRecord <- freshRecord uniqueFields2 var2

567+ mismatch context (Just (Error.ActualFields (Map.keys uniqueActFields)))

335− unifyHelp var1 subRecord

568+

569+ (True, True) ->

570+ do subUnify context expVar actVar

571+ unifySharedFields Map.empty expVar

336

572

337 (False, True) ->

573 (False, True) ->

338− do subRecord <- freshRecord uniqueFields1 var1

574+ do subRecord <- fresh context (Structure (Record1 uniqueExpFields expVar))

339− unifyHelp subRecord var2

575+ subUnify context subRecord actVar

576+ unifySharedFields Map.empty subRecord

340

577

578+ (Extension, Empty) ->

579+ case (Map.null uniqueExpFields, Map.null uniqueActFields) of

341− (False, False) ->

580+ (False, _) ->

342− do record1' <- freshRecord uniqueFields1 =<< fresh Nothing

581+ mismatch context (Just (Error.ExpectedFields (Map.keys uniqueExpFields)))

343− record2' <- freshRecord uniqueFields2 =<< fresh Nothing

344− unifyHelp record1' var2

345− unifyHelp var1 record2'

346−

347−

348−unifyOverlappingFields

349− :: Map.Map String [Variable]

350− -> Map.Map String [Variable]

351− -> Unify ()

352−unifyOverlappingFields fields1 fields2 =

353− Map.intersectionWith (zipWith unifyHelp) fields1 fields2

354− |> Map.elems

355− |> concat

356− |> sequence_

357−

358−

359−diffFields :: Map.Map String [a] -> Map.Map String [a] -> Map.Map String [a]

360−diffFields fields1 fields2 =

361− let eat (_:xs) (_:ys) = eat xs ys

362− eat xs _ = xs

363− in

364− Map.union (Map.intersectionWith eat fields1 fields2) fields1

365− |> Map.filter (not . null)

366

582

583+ (True, True) ->

584+ do subUnify context expVar actVar

585+ unifySharedFields Map.empty expVar

367

586

368−data ExpandedRecord = ExpandedRecord

587+ (True, False) ->

369− { _fields :: Map.Map String [Variable]

588+ do subRecord <- fresh context (Structure (Record1 uniqueActFields actVar))

370− , _extension :: Extension

589+ subUnify context expVar subRecord

371− }

590+ unifySharedFields Map.empty subRecord

372

591

373−data Extension = Empty Variable | Extension Variable

592+ (Extension, Extension) ->

593+ case (Map.null uniqueExpFields, Map.null uniqueActFields) of

594+ (True, True) ->

595+ do subUnify context expVar actVar

596+ unifySharedFields Map.empty expVar

374

597

598+ (True, False) ->

599+ do subRecord <- fresh context (Structure (Record1 uniqueActFields actVar))

600+ subUnify context expVar subRecord

601+ unifySharedFields Map.empty subRecord

375

602

376−gatherFields :: Variable -> IO ExpandedRecord

603+ (False, True) ->

377−gatherFields var =

604+ do subRecord <- fresh context (Structure (Record1 uniqueExpFields expVar))

378− do desc <- UF.descriptor var

605+ subUnify context subRecord actVar

379− case structure desc of

606+ unifySharedFields Map.empty subRecord

380− (Just (Record1 fields ext)) ->

381− do (ExpandedRecord deeperFields rootExt) <- gatherFields ext

382− return (ExpandedRecord (Map.unionWith (++) fields deeperFields) rootExt)

383

607

384− (Just EmptyRecord1) ->

608+ (False, False) ->

385− return (ExpandedRecord Map.empty (Empty var))

609+ do let subFields = Map.union uniqueExpFields uniqueActFields

610+ subExt <- fresh context (Var Flex Nothing Nothing)

611+ expRecord <- fresh context (Structure (Record1 uniqueActFields subExt))

612+ actRecord <- fresh context (Structure (Record1 uniqueExpFields subExt))

613+ subUnify context expVar expRecord

614+ subUnify context actRecord actVar

615+ unifySharedFields subFields subExt

386

616

387− _ ->

388− return (ExpandedRecord Map.empty (Extension var))

389

617

390

618

391−-- assumes that one of the dicts has stuff in it

619+-- GATHER RECORD STRUCTURE

392−fieldMismatchError :: Map.Map String a -> String

393−fieldMismatchError missingFields =

394− case Map.keys missingFields of

395− [] ->

396− ""

397

620

398− [key] ->

399− "Looks like a record is missing the field `" ++ key ++ "`"

400

621

401− keys ->

622+data RecordStructure = RecordStructure

402− "Looks like a record is missing fields "

623+ { _fields :: Map.Map String Variable

403− ++ List.intercalate ", " (init keys) ++ ", and " ++ last keys

624+ , _extVar :: Variable

625+ , _extStruct :: ExtensionStructure

626+ }

404

627

405

628

629+data ExtensionStructure

630+ = Empty

631+ | Extension

406

632

407−pickAlias :: Descriptor -> Descriptor -> Alias Variable

408−pickAlias desc1 desc2 =

409− alias desc1 <|> alias desc2

410

633

634+gatherFields :: Context -> Map.Map String Variable -> Variable -> Unify RecordStructure

635+gatherFields context fields variable =

636+ do desc <- liftIO (UF.descriptor variable)

637+ case _content desc of

638+ Structure (Record1 subFields subExt) ->

639+ gatherFields context (Map.union fields subFields) subExt

411

640

412−pickRank :: Descriptor -> Descriptor -> Int

641+ Structure (EmptyRecord1) ->

413−pickRank desc1 desc2 =

642+ return (RecordStructure fields variable Empty)

414− min (rank desc1) (rank desc2)

415

643

644+ Structure (App1 _ _) ->

645+ mismatch context (Just Error.NotRecord)

416

646

417−pickFlex :: Descriptor -> Descriptor -> Flex

647+ Structure (Fun1 _ _) ->

418−pickFlex desc1 desc2 =

648+ mismatch context (Just Error.NotRecord)

419− case (flex desc1, flex desc2) of

420− ( f , Flexible ) -> f

421− ( Flexible , f ) -> f

422− ( Is Number , Is _ ) -> Is Number

423− ( Is _ , Is Number ) -> Is Number

424− ( Is super , Is _ ) -> Is super

425− ( _ , _ ) -> Flexible

426

649

650+ Atom _ ->

651+ mismatch context (Just Error.NotRecord)

427

652

428−pickName :: Descriptor -> Descriptor -> Maybe Var.Canonical

653+ Var _ Nothing _ ->

429−pickName desc1 desc2 =

654+ return (RecordStructure fields variable Extension)

430− case (name desc1, name desc2) of

431− (Nothing, Nothing) ->

432− Nothing

433

655

434− (Just name1, Nothing) ->

656+ Var _ (Just _) _ ->

435− Just name1

657+ mismatch context (Just Error.NotRecord)

436

658

437− (Nothing, Just name2) ->

659+ -- TODO may be dropping useful alias info here

438− Just name2

660+ Alias _ _ var ->

661+ gatherFields context fields var

439

662

440− (Just name1, Just name2) ->

663+ Error ->

441− case (flex desc1, flex desc2) of

664+ return (RecordStructure fields variable Extension)

442− ( _ , Flexible ) -> Just name1

443− ( Flexible , _ ) -> Just name2

444− ( Is Number , Is _ ) -> Just name1

445− ( Is _ , Is Number ) -> Just name2

446− ( Is _ , Is _ ) -> Just name1

447− ( _ , _ ) -> Nothing

448

665