1{-# OPTIONS_GHC -Wall #-} 2{-# LANGUAGE OverloadedStrings #-} 3module Type.Type 4 ( Constraint(..) 5 , exists 6 , Variable 7 , FlatType(..) 8 , Type(..) 9 , Descriptor(Descriptor) 10 , Content(..) 11 , SuperType(..) 12 , noRank 13 , outermostRank 14 , Mark 15 , noMark 16 , nextMark 17 , (==>) 18 , int, float, char, string, bool, never 19 , vec2, vec3, vec4, mat4, texture 20 , mkFlexVar 21 , mkFlexNumber 22 , unnamedFlexVar 23 , unnamedFlexSuper 24 , nameToFlex 25 , nameToRigid 26 , toAnnotation 27 , toErrorType 28 ) 29 where 30 31 32import Control.Monad.State.Strict (StateT, liftIO) 33import qualified Control.Monad.State.Strict as State 34import Data.Foldable (foldrM) 35import qualified Data.Map.Strict as Map 36import qualified Data.Name as Name 37import Data.Word (Word32) 38 39import qualified AST.Canonical as Can 40import qualified AST.Utils.Type as Type 41import qualified Elm.ModuleName as ModuleName 42import qualified Reporting.Annotation as A 43import qualified Reporting.Error.Type as E 44import qualified Type.Error as ET 45import qualified Type.UnionFind as UF 46 47 48 49-- CONSTRAINTS 50 51 52data Constraint 53 = CTrue 54 | CSaveTheEnvironment 55 | CEqual A.Region E.Category Type (E.Expected Type) 56 | CLocal A.Region Name.Name (E.Expected Type) 57 | CForeign A.Region Name.Name Can.Annotation (E.Expected Type) 58 | CPattern A.Region E.PCategory Type (E.PExpected Type) 59 | CAnd [Constraint] 60 | CLet 61 { _rigidVars :: [Variable] 62 , _flexVars :: [Variable] 63 , _header :: Map.Map Name.Name (A.Located Type) 64 , _headerCon :: Constraint 65 , _bodyCon :: Constraint 66 } 67 68 69exists :: [Variable] -> Constraint -> Constraint 70exists flexVars constraint = 71 CLet [] flexVars Map.empty constraint CTrue 72 73 74 75-- TYPE PRIMITIVES 76 77 78type Variable = 79 UF.Point Descriptor 80 81 82data FlatType 83 = App1 ModuleName.Canonical Name.Name [Variable] 84 | Fun1 Variable Variable 85 | EmptyRecord1 86 | Record1 (Map.Map Name.Name Variable) Variable 87 | Unit1 88 | Tuple1 Variable Variable (Maybe Variable) 89 90 91data Type 92 = PlaceHolder Name.Name 93 | AliasN ModuleName.Canonical Name.Name [(Name.Name, Type)] Type 94 | VarN Variable 95 | AppN ModuleName.Canonical Name.Name [Type] 96 | FunN Type Type 97 | EmptyRecordN 98 | RecordN (Map.Map Name.Name Type) Type 99 | UnitN 100 | TupleN Type Type (Maybe Type) 101 102 103 104-- DESCRIPTORS 105 106 107data Descriptor = 108 Descriptor 109 { _content :: Content 110 , _rank :: Int 111 , _mark :: Mark 112 , _copy :: Maybe Variable 113 } 114 115 116data Content 117 = FlexVar (Maybe Name.Name) 118 | FlexSuper SuperType (Maybe Name.Name) 119 | RigidVar Name.Name 120 | RigidSuper SuperType Name.Name 121 | Structure FlatType 122 | Alias ModuleName.Canonical Name.Name [(Name.Name,Variable)] Variable 123 | Error 124 125 126data SuperType 127 = Number 128 | Comparable 129 | Appendable 130 | CompAppend 131 deriving (Eq) 132 133 134makeDescriptor :: Content -> Descriptor 135makeDescriptor content = 136 Descriptor content noRank noMark Nothing 137 138 139 140-- RANKS 141 142 143noRank :: Int 144noRank = 145 0 146 147 148outermostRank :: Int 149outermostRank = 150 1 151 152 153 154-- MARKS 155 156 157newtype Mark = Mark Word32 158 deriving (Eq, Ord) 159 160 161noMark :: Mark 162noMark = 163 Mark 2 164 165 166occursMark :: Mark 167occursMark = 168 Mark 1 169 170 171getVarNamesMark :: Mark 172getVarNamesMark = 173 Mark 0 174 175 176{-# INLINE nextMark #-} 177nextMark :: Mark -> Mark 178nextMark (Mark mark) = 179 Mark (mark + 1) 180 181 182 183-- FUNCTION TYPES 184 185 186infixr 9 ==> 187 188 189{-# INLINE (==>) #-} 190(==>) :: Type -> Type -> Type 191(==>) = 192 FunN 193 194 195 196-- PRIMITIVE TYPES 197 198 199{-# NOINLINE int #-} 200int :: Type 201int = AppN ModuleName.basics "Int" [] 202 203 204{-# NOINLINE float #-} 205float :: Type 206float = AppN ModuleName.basics "Float" [] 207 208 209{-# NOINLINE char #-} 210char :: Type 211char = AppN ModuleName.char "Char" [] 212 213 214{-# NOINLINE string #-} 215string :: Type 216string = AppN ModuleName.string "String" [] 217 218 219{-# NOINLINE bool #-} 220bool :: Type 221bool = AppN ModuleName.basics "Bool" [] 222 223 224{-# NOINLINE never #-} 225never :: Type 226never = AppN ModuleName.basics "Never" [] 227 228 229 230-- WEBGL TYPES 231 232 233{-# NOINLINE vec2 #-} 234vec2 :: Type 235vec2 = AppN ModuleName.vector2 "Vec2" [] 236 237 238{-# NOINLINE vec3 #-} 239vec3 :: Type 240vec3 = AppN ModuleName.vector3 "Vec3" [] 241 242 243{-# NOINLINE vec4 #-} 244vec4 :: Type 245vec4 = AppN ModuleName.vector4 "Vec4" [] 246 247 248{-# NOINLINE mat4 #-} 249mat4 :: Type 250mat4 = AppN ModuleName.matrix4 "Mat4" [] 251 252 253{-# NOINLINE texture #-} 254texture :: Type 255texture = AppN ModuleName.texture "Texture" [] 256 257 258 259-- MAKE FLEX VARIABLES 260 261 262mkFlexVar :: IO Variable 263mkFlexVar = 264 UF.fresh flexVarDescriptor 265 266 267{-# NOINLINE flexVarDescriptor #-} 268flexVarDescriptor :: Descriptor 269flexVarDescriptor = 270 makeDescriptor unnamedFlexVar 271 272 273{-# NOINLINE unnamedFlexVar #-} 274unnamedFlexVar :: Content 275unnamedFlexVar = 276 FlexVar Nothing 277 278 279 280-- MAKE FLEX NUMBERS 281 282 283mkFlexNumber :: IO Variable 284mkFlexNumber = 285 UF.fresh flexNumberDescriptor 286 287 288{-# NOINLINE flexNumberDescriptor #-} 289flexNumberDescriptor :: Descriptor 290flexNumberDescriptor = 291 makeDescriptor (unnamedFlexSuper Number) 292 293 294unnamedFlexSuper :: SuperType -> Content 295unnamedFlexSuper super = 296 FlexSuper super Nothing 297 298 299 300-- MAKE NAMED VARIABLES 301 302 303nameToFlex :: Name.Name -> IO Variable 304nameToFlex name = 305 UF.fresh $ makeDescriptor $ 306 maybe FlexVar FlexSuper (toSuper name) (Just name) 307 308 309nameToRigid :: Name.Name -> IO Variable 310nameToRigid name = 311 UF.fresh $ makeDescriptor $ 312 maybe RigidVar RigidSuper (toSuper name) name 313 314 315toSuper :: Name.Name -> Maybe SuperType 316toSuper name = 317 if Name.isNumberType name then 318 Just Number 319 320 else if Name.isComparableType name then 321 Just Comparable 322 323 else if Name.isAppendableType name then 324 Just Appendable 325 326 else if Name.isCompappendType name then 327 Just CompAppend 328 329 else 330 Nothing 331 332 333 334-- TO TYPE ANNOTATION 335 336 337toAnnotation :: Variable -> IO Can.Annotation 338toAnnotation variable = 339 do userNames <- getVarNames variable Map.empty 340 (tipe, NameState freeVars _ _ _ _ _) <- 341 State.runStateT (variableToCanType variable) (makeNameState userNames) 342 return $ Can.Forall freeVars tipe 343 344 345variableToCanType :: Variable -> StateT NameState IO Can.Type 346variableToCanType variable = 347 do (Descriptor content _ _ _) <- liftIO $ UF.get variable 348 case content of 349 Structure term -> 350 termToCanType term 351 352 FlexVar maybeName -> 353 case maybeName of 354 Just name -> 355 return (Can.TVar name) 356 357 Nothing -> 358 do name <- getFreshVarName 359 liftIO $ UF.modify variable (\desc -> desc { _content = FlexVar (Just name) }) 360 return (Can.TVar name) 361 362 FlexSuper super maybeName -> 363 case maybeName of 364 Just name -> 365 return (Can.TVar name) 366 367 Nothing -> 368 do name <- getFreshSuperName super 369 liftIO $ UF.modify variable (\desc -> desc { _content = FlexSuper super (Just name) }) 370 return (Can.TVar name) 371 372 RigidVar name -> 373 return (Can.TVar name) 374 375 RigidSuper _ name -> 376 return (Can.TVar name) 377 378 Alias home name args realVariable -> 379 do canArgs <- traverse (traverse variableToCanType) args 380 canType <- variableToCanType realVariable 381 return (Can.TAlias home name canArgs (Can.Filled canType)) 382 383 Error -> 384 error "cannot handle Error types in variableToCanType" 385 386 387termToCanType :: FlatType -> StateT NameState IO Can.Type 388termToCanType term = 389 case term of 390 App1 home name args -> 391 Can.TType home name <$> traverse variableToCanType args 392 393 Fun1 a b -> 394 Can.TLambda 395 <$> variableToCanType a 396 <*> variableToCanType b 397 398 EmptyRecord1 -> 399 return $ Can.TRecord Map.empty Nothing 400 401 Record1 fields extension -> 402 do canFields <- traverse fieldToCanType fields 403 canExt <- Type.iteratedDealias <$> variableToCanType extension 404 return $ 405 case canExt of 406 Can.TRecord subFields subExt -> 407 Can.TRecord (Map.union subFields canFields) subExt 408 409 Can.TVar name -> 410 Can.TRecord canFields (Just name) 411 412 _ -> 413 error "Used toAnnotation on a type that is not well-formed" 414 415 Unit1 -> 416 return Can.TUnit 417 418 Tuple1 a b maybeC -> 419 Can.TTuple 420 <$> variableToCanType a 421 <*> variableToCanType b 422 <*> traverse variableToCanType maybeC 423 424 425fieldToCanType :: Variable -> StateT NameState IO Can.FieldType 426fieldToCanType variable = 427 do tipe <- variableToCanType variable 428 return (Can.FieldType 0 tipe) 429 430 431 432-- TO ERROR TYPE 433 434 435toErrorType :: Variable -> IO ET.Type 436toErrorType variable = 437 do userNames <- getVarNames variable Map.empty 438 State.evalStateT (variableToErrorType variable) (makeNameState userNames) 439 440 441variableToErrorType :: Variable -> StateT NameState IO ET.Type 442variableToErrorType variable = 443 do descriptor <- liftIO $ UF.get variable 444 let mark = _mark descriptor 445 if mark == occursMark 446 then 447 return ET.Infinite 448 449 else 450 do liftIO $ UF.modify variable (\desc -> desc { _mark = occursMark }) 451 errType <- contentToErrorType variable (_content descriptor) 452 liftIO $ UF.modify variable (\desc -> desc { _mark = mark }) 453 return errType 454 455 456contentToErrorType :: Variable -> Content -> StateT NameState IO ET.Type 457contentToErrorType variable content = 458 case content of 459 Structure term -> 460 termToErrorType term 461 462 FlexVar maybeName -> 463 case maybeName of 464 Just name -> 465 return (ET.FlexVar name) 466 467 Nothing -> 468 do name <- getFreshVarName 469 liftIO $ UF.modify variable (\desc -> desc { _content = FlexVar (Just name) }) 470 return (ET.FlexVar name) 471 472 FlexSuper super maybeName -> 473 case maybeName of 474 Just name -> 475 return (ET.FlexSuper (superToSuper super) name) 476 477 Nothing -> 478 do name <- getFreshSuperName super 479 liftIO $ UF.modify variable (\desc -> desc { _content = FlexSuper super (Just name) }) 480 return (ET.FlexSuper (superToSuper super) name) 481 482 RigidVar name -> 483 return (ET.RigidVar name) 484 485 RigidSuper super name -> 486 return (ET.RigidSuper (superToSuper super) name) 487 488 Alias home name args realVariable -> 489 do errArgs <- traverse (traverse variableToErrorType) args 490 errType <- variableToErrorType realVariable 491 return (ET.Alias home name errArgs errType) 492 493 Error -> 494 return ET.Error 495 496 497superToSuper :: SuperType -> ET.Super 498superToSuper super = 499 case super of 500 Number -> ET.Number 501 Comparable -> ET.Comparable 502 Appendable -> ET.Appendable 503 CompAppend -> ET.CompAppend 504 505 506termToErrorType :: FlatType -> StateT NameState IO ET.Type 507termToErrorType term = 508 case term of 509 App1 home name args -> 510 ET.Type home name <$> traverse variableToErrorType args 511 512 Fun1 a b -> 513 do arg <- variableToErrorType a 514 result <- variableToErrorType b 515 return $ 516 case result of 517 ET.Lambda arg1 arg2 others -> 518 ET.Lambda arg arg1 (arg2:others) 519 520 _ -> 521 ET.Lambda arg result [] 522 523 EmptyRecord1 -> 524 return $ ET.Record Map.empty ET.Closed 525 526 Record1 fields extension -> 527 do errFields <- traverse variableToErrorType fields 528 errExt <- ET.iteratedDealias <$> variableToErrorType extension 529 return $ 530 case errExt of 531 ET.Record subFields subExt -> 532 ET.Record (Map.union subFields errFields) subExt 533 534 ET.FlexVar ext -> 535 ET.Record errFields (ET.FlexOpen ext) 536 537 ET.RigidVar ext -> 538 ET.Record errFields (ET.RigidOpen ext) 539 540 _ -> 541 error "Used toErrorType on a type that is not well-formed" 542 543 Unit1 -> 544 return ET.Unit 545 546 Tuple1 a b maybeC -> 547 ET.Tuple 548 <$> variableToErrorType a 549 <*> variableToErrorType b 550 <*> traverse variableToErrorType maybeC 551 552 553 554-- MANAGE FRESH VARIABLE NAMES 555 556 557data NameState = 558 NameState 559 { _taken :: Map.Map Name.Name () 560 , _normals :: Int 561 , _numbers :: Int 562 , _comparables :: Int 563 , _appendables :: Int 564 , _compAppends :: Int 565 } 566 567 568makeNameState :: Map.Map Name.Name Variable -> NameState 569makeNameState taken = 570 NameState (Map.map (const ()) taken) 0 0 0 0 0 571 572 573 574-- FRESH VAR NAMES 575 576 577getFreshVarName :: (Monad m) => StateT NameState m Name.Name 578getFreshVarName = 579 do index <- State.gets _normals 580 taken <- State.gets _taken 581 let (name, newIndex, newTaken) = getFreshVarNameHelp index taken 582 State.modify $ \state -> state { _taken = newTaken, _normals = newIndex } 583 return name 584 585 586getFreshVarNameHelp :: Int -> Map.Map Name.Name () -> (Name.Name, Int, Map.Map Name.Name ()) 587getFreshVarNameHelp index taken = 588 let 589 name = 590 Name.fromTypeVariableScheme index 591 in 592 if Map.member name taken then 593 getFreshVarNameHelp (index + 1) taken 594 else 595 ( name, index + 1, Map.insert name () taken ) 596 597 598 599-- FRESH SUPER NAMES 600 601 602getFreshSuperName :: (Monad m) => SuperType -> StateT NameState m Name.Name 603getFreshSuperName super = 604 case super of 605 Number -> 606 getFreshSuper "number" _numbers (\index state -> state { _numbers = index }) 607 608 Comparable -> 609 getFreshSuper "comparable" _comparables (\index state -> state { _comparables = index }) 610 611 Appendable -> 612 getFreshSuper "appendable" _appendables (\index state -> state { _appendables = index }) 613 614 CompAppend -> 615 getFreshSuper "compappend" _compAppends (\index state -> state { _compAppends = index }) 616 617 618getFreshSuper :: (Monad m) => Name.Name -> (NameState -> Int) -> (Int -> NameState -> NameState) -> StateT NameState m Name.Name 619getFreshSuper prefix getter setter = 620 do index <- State.gets getter 621 taken <- State.gets _taken 622 let (name, newIndex, newTaken) = getFreshSuperHelp prefix index taken 623 State.modify (\state -> setter newIndex state { _taken = newTaken }) 624 return name 625 626 627getFreshSuperHelp :: Name.Name -> Int -> Map.Map Name.Name () -> (Name.Name, Int, Map.Map Name.Name ()) 628getFreshSuperHelp prefix index taken = 629 let 630 name = 631 Name.fromTypeVariable prefix index 632 in 633 if Map.member name taken then 634 getFreshSuperHelp prefix (index + 1) taken 635 636 else 637 ( name, index + 1, Map.insert name () taken ) 638 639 640 641-- GET ALL VARIABLE NAMES 642 643 644getVarNames :: Variable -> Map.Map Name.Name Variable -> IO (Map.Map Name.Name Variable) 645getVarNames var takenNames = 646 do (Descriptor content rank mark copy) <- UF.get var 647 if mark == getVarNamesMark 648 then return takenNames 649 else 650 do UF.set var (Descriptor content rank getVarNamesMark copy) 651 case content of 652 Error -> 653 return takenNames 654 655 FlexVar maybeName -> 656 case maybeName of 657 Nothing -> 658 return takenNames 659 660 Just name -> 661 addName 0 name var (FlexVar . Just) takenNames 662 663 FlexSuper super maybeName -> 664 case maybeName of 665 Nothing -> 666 return takenNames 667 668 Just name -> 669 addName 0 name var (FlexSuper super . Just) takenNames 670 671 RigidVar name -> 672 addName 0 name var RigidVar takenNames 673 674 RigidSuper super name -> 675 addName 0 name var (RigidSuper super) takenNames 676 677 Alias _ _ args _ -> 678 foldrM getVarNames takenNames (map snd args) 679 680 Structure flatType -> 681 case flatType of 682 App1 _ _ args -> 683 foldrM getVarNames takenNames args 684 685 Fun1 arg body -> 686 getVarNames arg =<< getVarNames body takenNames 687 688 EmptyRecord1 -> 689 return takenNames 690 691 Record1 fields extension -> 692 getVarNames extension =<< 693 foldrM getVarNames takenNames (Map.elems fields) 694 695 Unit1 -> 696 return takenNames 697 698 Tuple1 a b Nothing -> 699 getVarNames a =<< getVarNames b takenNames 700 701 Tuple1 a b (Just c) -> 702 getVarNames a =<< getVarNames b =<< getVarNames c takenNames 703 704 705 706-- REGISTER NAME / RENAME DUPLICATES 707 708 709addName :: Int -> Name.Name -> Variable -> (Name.Name -> Content) -> Map.Map Name.Name Variable -> IO (Map.Map Name.Name Variable) 710addName index givenName var makeContent takenNames = 711 let 712 indexedName = 713 Name.fromTypeVariable givenName index 714 in 715 case Map.lookup indexedName takenNames of 716 Nothing -> 717 do if indexedName == givenName then return () else 718 UF.modify var $ \(Descriptor _ rank mark copy) -> 719 Descriptor (makeContent indexedName) rank mark copy 720 return $ Map.insert indexedName var takenNames 721 722 Just otherVar -> 723 do same <- UF.equivalent var otherVar 724 if same 725 then return takenNames 726 else addName (index + 1) givenName var makeContent takenNames 727