git.iko.soy/elk
on 2ecbee3 help sign in
elk/compiler/src/Type/Type.hs
727 lines 17 kB history raw
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
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)
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 Reporting.Region as R
45import qualified Type.Error as ET
46import qualified Type.UnionFind as UF
50-- CONSTRAINTS
53data Constraint
54 = CTrue
55 | CSaveTheEnvironment
56 | CEqual R.Region E.Category Type (E.Expected Type)
57 | CLocal R.Region Name.Name (E.Expected Type)
58 | CForeign R.Region Name.Name Can.Annotation (E.Expected Type)
59 | CPattern R.Region E.PCategory Type (E.PExpected Type)
60 | CAnd [Constraint]
61 | CLet
62 { _rigidVars :: [Variable]
63 , _flexVars :: [Variable]
64 , _header :: Map.Map Name.Name (A.Located Type)
65 , _headerCon :: Constraint
66 , _bodyCon :: Constraint
67 }
70exists :: [Variable] -> Constraint -> Constraint
71exists flexVars constraint =
72 CLet [] flexVars Map.empty constraint CTrue
76-- TYPE PRIMITIVES
79type Variable =
80 UF.Point Descriptor
83data FlatType
84 = App1 ModuleName.Canonical Name.Name [Variable]
85 | Fun1 Variable Variable
86 | EmptyRecord1
87 | Record1 (Map.Map Name.Name Variable) Variable
88 | Unit1
89 | Tuple1 Variable Variable (Maybe Variable)
92data Type
93 = PlaceHolder Name.Name
94 | AliasN ModuleName.Canonical Name.Name [(Name.Name, Type)] Type
95 | VarN Variable
96 | AppN ModuleName.Canonical Name.Name [Type]
97 | FunN Type Type
98 | EmptyRecordN
99 | RecordN (Map.Map Name.Name Type) Type
100 | UnitN
101 | TupleN Type Type (Maybe Type)
105-- DESCRIPTORS
108data Descriptor =
109 Descriptor
110 { _content :: Content
111 , _rank :: Int
112 , _mark :: Mark
113 , _copy :: Maybe Variable
114 }
117data Content
118 = FlexVar (Maybe Name.Name)
119 | FlexSuper SuperType (Maybe Name.Name)
120 | RigidVar Name.Name
121 | RigidSuper SuperType Name.Name
122 | Structure FlatType
123 | Alias ModuleName.Canonical Name.Name [(Name.Name,Variable)] Variable
124 | Error
127data SuperType
128 = Number
129 | Comparable
130 | Appendable
131 | CompAppend
132 deriving (Eq)
135makeDescriptor :: Content -> Descriptor
136makeDescriptor content =
137 Descriptor content noRank noMark Nothing
141-- RANKS
144noRank :: Int
145noRank =
146 0
149outermostRank :: Int
150outermostRank =
151 1
155-- MARKS
158newtype Mark = Mark Word32
159 deriving (Eq, Ord)
162noMark :: Mark
163noMark =
164 Mark 2
167occursMark :: Mark
168occursMark =
169 Mark 1
172getVarNamesMark :: Mark
173getVarNamesMark =
174 Mark 0
177{-# INLINE nextMark #-}
178nextMark :: Mark -> Mark
179nextMark (Mark mark) =
180 Mark (mark + 1)
184-- FUNCTION TYPES
187infixr 9 ==>
190{-# INLINE (==>) #-}
191(==>) :: Type -> Type -> Type
192(==>) =
193 FunN
197-- PRIMITIVE TYPES
200{-# NOINLINE int #-}
201int :: Type
202int = AppN ModuleName.basics "Int" []
205{-# NOINLINE float #-}
206float :: Type
207float = AppN ModuleName.basics "Float" []
210{-# NOINLINE char #-}
211char :: Type
212char = AppN ModuleName.char "Char" []
215{-# NOINLINE string #-}
216string :: Type
217string = AppN ModuleName.string "String" []
220{-# NOINLINE bool #-}
221bool :: Type
222bool = AppN ModuleName.basics "Bool" []
225{-# NOINLINE never #-}
226never :: Type
227never = AppN ModuleName.basics "Never" []
231-- WEBGL TYPES
234{-# NOINLINE vec2 #-}
235vec2 :: Type
236vec2 = AppN ModuleName.vector2 "Vec2" []
239{-# NOINLINE vec3 #-}
240vec3 :: Type
241vec3 = AppN ModuleName.vector3 "Vec3" []
244{-# NOINLINE vec4 #-}
245vec4 :: Type
246vec4 = AppN ModuleName.vector4 "Vec4" []
249{-# NOINLINE mat4 #-}
250mat4 :: Type
251mat4 = AppN ModuleName.matrix4 "Mat4" []
254{-# NOINLINE texture #-}
255texture :: Type
256texture = AppN ModuleName.texture "Texture" []
260-- MAKE FLEX VARIABLES
263mkFlexVar :: IO Variable
264mkFlexVar =
265 UF.fresh flexVarDescriptor
268{-# NOINLINE flexVarDescriptor #-}
269flexVarDescriptor :: Descriptor
270flexVarDescriptor =
271 makeDescriptor unnamedFlexVar
274{-# NOINLINE unnamedFlexVar #-}
275unnamedFlexVar :: Content
276unnamedFlexVar =
277 FlexVar Nothing
281-- MAKE FLEX NUMBERS
284mkFlexNumber :: IO Variable
285mkFlexNumber =
286 UF.fresh flexNumberDescriptor
289{-# NOINLINE flexNumberDescriptor #-}
290flexNumberDescriptor :: Descriptor
291flexNumberDescriptor =
292 makeDescriptor (unnamedFlexSuper Number)
295unnamedFlexSuper :: SuperType -> Content
296unnamedFlexSuper super =
297 FlexSuper super Nothing
301-- MAKE NAMED VARIABLES
304nameToFlex :: Name.Name -> IO Variable
305nameToFlex name =
306 UF.fresh $ makeDescriptor $
307 maybe FlexVar FlexSuper (toSuper name) (Just name)
310nameToRigid :: Name.Name -> IO Variable
311nameToRigid name =
312 UF.fresh $ makeDescriptor $
313 maybe RigidVar RigidSuper (toSuper name) name
316toSuper :: Name.Name -> Maybe SuperType
317toSuper name =
318 if Name.isNumberType name then
319 Just Number
321 else if Name.isComparableType name then
322 Just Comparable
324 else if Name.isAppendableType name then
325 Just Appendable
327 else if Name.isCompappendType name then
328 Just CompAppend
330 else
331 Nothing
335-- TO TYPE ANNOTATION
338toAnnotation :: Variable -> IO Can.Annotation
339toAnnotation variable =
340 do userNames <- getVarNames variable Map.empty
341 (tipe, NameState freeVars _ _ _ _ _) <-
342 State.runStateT (variableToCanType variable) (makeNameState userNames)
343 return $ Can.Forall freeVars tipe
346variableToCanType :: Variable -> StateT NameState IO Can.Type
347variableToCanType variable =
348 do (Descriptor content _ _ _) <- liftIO $ UF.get variable
349 case content of
350 Structure term ->
351 termToCanType term
353 FlexVar maybeName ->
354 case maybeName of
355 Just name ->
356 return (Can.TVar name)
358 Nothing ->
359 do name <- getFreshVarName
360 liftIO $ UF.modify variable (\desc -> desc { _content = FlexVar (Just name) })
361 return (Can.TVar name)
363 FlexSuper super maybeName ->
364 case maybeName of
365 Just name ->
366 return (Can.TVar name)
368 Nothing ->
369 do name <- getFreshSuperName super
370 liftIO $ UF.modify variable (\desc -> desc { _content = FlexSuper super (Just name) })
371 return (Can.TVar name)
373 RigidVar name ->
374 return (Can.TVar name)
376 RigidSuper _ name ->
377 return (Can.TVar name)
379 Alias home name args realVariable ->
380 do canArgs <- traverse (traverse variableToCanType) args
381 canType <- variableToCanType realVariable
382 return (Can.TAlias home name canArgs (Can.Filled canType))
384 Error ->
385 error "cannot handle Error types in variableToCanType"
388termToCanType :: FlatType -> StateT NameState IO Can.Type
389termToCanType term =
390 case term of
391 App1 home name args ->
392 Can.TType home name <$> traverse variableToCanType args
394 Fun1 a b ->
395 Can.TLambda
396 <$> variableToCanType a
397 <*> variableToCanType b
399 EmptyRecord1 ->
400 return $ Can.TRecord Map.empty Nothing
402 Record1 fields extension ->
403 do canFields <- traverse fieldToCanType fields
404 canExt <- Type.iteratedDealias <$> variableToCanType extension
405 return $
406 case canExt of
407 Can.TRecord subFields subExt ->
408 Can.TRecord (Map.union subFields canFields) subExt
410 Can.TVar name ->
411 Can.TRecord canFields (Just name)
413 _ ->
414 error "Used toAnnotation on a type that is not well-formed"
416 Unit1 ->
417 return Can.TUnit
419 Tuple1 a b maybeC ->
420 Can.TTuple
421 <$> variableToCanType a
422 <*> variableToCanType b
423 <*> traverse variableToCanType maybeC
426fieldToCanType :: Variable -> StateT NameState IO Can.FieldType
427fieldToCanType variable =
428 do tipe <- variableToCanType variable
429 return (Can.FieldType 0 tipe)
433-- TO ERROR TYPE
436toErrorType :: Variable -> IO ET.Type
437toErrorType variable =
438 do userNames <- getVarNames variable Map.empty
439 State.evalStateT (variableToErrorType variable) (makeNameState userNames)
442variableToErrorType :: Variable -> StateT NameState IO ET.Type
443variableToErrorType variable =
444 do descriptor <- liftIO $ UF.get variable
445 let mark = _mark descriptor
446 if mark == occursMark
447 then
448 return ET.Infinite
450 else
451 do liftIO $ UF.modify variable (\desc -> desc { _mark = occursMark })
452 errType <- contentToErrorType variable (_content descriptor)
453 liftIO $ UF.modify variable (\desc -> desc { _mark = mark })
454 return errType
457contentToErrorType :: Variable -> Content -> StateT NameState IO ET.Type
458contentToErrorType variable content =
459 case content of
460 Structure term ->
461 termToErrorType term
463 FlexVar maybeName ->
464 case maybeName of
465 Just name ->
466 return (ET.FlexVar name)
468 Nothing ->
469 do name <- getFreshVarName
470 liftIO $ UF.modify variable (\desc -> desc { _content = FlexVar (Just name) })
471 return (ET.FlexVar name)
473 FlexSuper super maybeName ->
474 case maybeName of
475 Just name ->
476 return (ET.FlexSuper (superToSuper super) name)
478 Nothing ->
479 do name <- getFreshSuperName super
480 liftIO $ UF.modify variable (\desc -> desc { _content = FlexSuper super (Just name) })
481 return (ET.FlexSuper (superToSuper super) name)
483 RigidVar name ->
484 return (ET.RigidVar name)
486 RigidSuper super name ->
487 return (ET.RigidSuper (superToSuper super) name)
489 Alias home name args realVariable ->
490 do errArgs <- traverse (traverse variableToErrorType) args
491 errType <- variableToErrorType realVariable
492 return (ET.Alias home name errArgs errType)
494 Error ->
495 return ET.Error
498superToSuper :: SuperType -> ET.Super
499superToSuper super =
500 case super of
501 Number -> ET.Number
502 Comparable -> ET.Comparable
503 Appendable -> ET.Appendable
504 CompAppend -> ET.CompAppend
507termToErrorType :: FlatType -> StateT NameState IO ET.Type
508termToErrorType term =
509 case term of
510 App1 home name args ->
511 ET.Type home name <$> traverse variableToErrorType args
513 Fun1 a b ->
514 do arg <- variableToErrorType a
515 result <- variableToErrorType b
516 return $
517 case result of
518 ET.Lambda arg1 arg2 others ->
519 ET.Lambda arg arg1 (arg2:others)
521 _ ->
522 ET.Lambda arg result []
524 EmptyRecord1 ->
525 return $ ET.Record Map.empty ET.Closed
527 Record1 fields extension ->
528 do errFields <- traverse variableToErrorType fields
529 errExt <- ET.iteratedDealias <$> variableToErrorType extension
530 return $
531 case errExt of
532 ET.Record subFields subExt ->
533 ET.Record (Map.union subFields errFields) subExt
535 ET.FlexVar ext ->
536 ET.Record errFields (ET.FlexOpen ext)
538 ET.RigidVar ext ->
539 ET.Record errFields (ET.RigidOpen ext)
541 _ ->
542 error "Used toErrorType on a type that is not well-formed"
544 Unit1 ->
545 return ET.Unit
547 Tuple1 a b maybeC ->
548 ET.Tuple
549 <$> variableToErrorType a
550 <*> variableToErrorType b
551 <*> traverse variableToErrorType maybeC
555-- MANAGE FRESH VARIABLE NAMES
558data NameState =
559 NameState
560 { _taken :: Map.Map Name.Name ()
561 , _normals :: Int
562 , _numbers :: Int
563 , _comparables :: Int
564 , _appendables :: Int
565 , _compAppends :: Int
566 }
569makeNameState :: Map.Map Name.Name Variable -> NameState
570makeNameState taken =
571 NameState (Map.map (const ()) taken) 0 0 0 0 0
575-- FRESH VAR NAMES
578getFreshVarName :: (Monad m) => StateT NameState m Name.Name
579getFreshVarName =
580 do index <- State.gets _normals
581 taken <- State.gets _taken
582 let (name, newIndex, newTaken) = getFreshVarNameHelp index taken
583 State.modify $ \state -> state { _taken = newTaken, _normals = newIndex }
584 return name
587getFreshVarNameHelp :: Int -> Map.Map Name.Name () -> (Name.Name, Int, Map.Map Name.Name ())
588getFreshVarNameHelp index taken =
589 let
590 name =
591 Name.fromTypeVariableScheme index
592 in
593 if Map.member name taken then
594 getFreshVarNameHelp (index + 1) taken
595 else
596 ( name, index + 1, Map.insert name () taken )
600-- FRESH SUPER NAMES
603getFreshSuperName :: (Monad m) => SuperType -> StateT NameState m Name.Name
604getFreshSuperName super =
605 case super of
606 Number ->
607 getFreshSuper "number" _numbers (\index state -> state { _numbers = index })
609 Comparable ->
610 getFreshSuper "comparable" _comparables (\index state -> state { _comparables = index })
612 Appendable ->
613 getFreshSuper "appendable" _appendables (\index state -> state { _appendables = index })
615 CompAppend ->
616 getFreshSuper "compappend" _compAppends (\index state -> state { _compAppends = index })
619getFreshSuper :: (Monad m) => Name.Name -> (NameState -> Int) -> (Int -> NameState -> NameState) -> StateT NameState m Name.Name
620getFreshSuper prefix getter setter =
621 do index <- State.gets getter
622 taken <- State.gets _taken
623 let (name, newIndex, newTaken) = getFreshSuperHelp prefix index taken
624 State.modify (\state -> setter newIndex state { _taken = newTaken })
625 return name
628getFreshSuperHelp :: Name.Name -> Int -> Map.Map Name.Name () -> (Name.Name, Int, Map.Map Name.Name ())
629getFreshSuperHelp prefix index taken =
630 let
631 name =
632 Name.fromTypeVariable prefix index
633 in
634 if Map.member name taken then
635 getFreshSuperHelp prefix (index + 1) taken
637 else
638 ( name, index + 1, Map.insert name () taken )
642-- GET ALL VARIABLE NAMES
645getVarNames :: Variable -> Map.Map Name.Name Variable -> IO (Map.Map Name.Name Variable)
646getVarNames var takenNames =
647 do (Descriptor content rank mark copy) <- UF.get var
648 if mark == getVarNamesMark
649 then return takenNames
650 else
651 do UF.set var (Descriptor content rank getVarNamesMark copy)
652 case content of
653 Error ->
654 return takenNames
656 FlexVar maybeName ->
657 case maybeName of
658 Nothing ->
659 return takenNames
661 Just name ->
662 addName 0 name var (FlexVar . Just) takenNames
664 FlexSuper super maybeName ->
665 case maybeName of
666 Nothing ->
667 return takenNames
669 Just name ->
670 addName 0 name var (FlexSuper super . Just) takenNames
672 RigidVar name ->
673 addName 0 name var RigidVar takenNames
675 RigidSuper super name ->
676 addName 0 name var (RigidSuper super) takenNames
678 Alias _ _ args _ ->
679 foldrM getVarNames takenNames (map snd args)
681 Structure flatType ->
682 case flatType of
683 App1 _ _ args ->
684 foldrM getVarNames takenNames args
686 Fun1 arg body ->
687 getVarNames arg =<< getVarNames body takenNames
689 EmptyRecord1 ->
690 return takenNames
692 Record1 fields extension ->
693 getVarNames extension =<<
694 foldrM getVarNames takenNames (Map.elems fields)
696 Unit1 ->
697 return takenNames
699 Tuple1 a b Nothing ->
700 getVarNames a =<< getVarNames b takenNames
702 Tuple1 a b (Just c) ->
703 getVarNames a =<< getVarNames b =<< getVarNames c takenNames
707-- REGISTER NAME / RENAME DUPLICATES
710addName :: Int -> Name.Name -> Variable -> (Name.Name -> Content) -> Map.Map Name.Name Variable -> IO (Map.Map Name.Name Variable)
711addName index givenName var makeContent takenNames =
712 let
713 indexedName =
714 Name.fromTypeVariable givenName index
715 in
716 case Map.lookup indexedName takenNames of
717 Nothing ->
718 do if indexedName == givenName then return () else
719 UF.modify var $ \(Descriptor _ rank mark copy) ->
720 Descriptor (makeContent indexedName) rank mark copy
721 return $ Map.insert indexedName var takenNames
723 Just otherVar ->
724 do same <- UF.equivalent var otherVar
725 if same
726 then return takenNames
727 else addName (index + 1) givenName var makeContent takenNames