git.iko.soy/elk
on 1238607 help sign in
elk/compiler/src/Type/Type.hs
726 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 Type.Error as ET
45import qualified Type.UnionFind as UF
49-- CONSTRAINTS
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 }
69exists :: [Variable] -> Constraint -> Constraint
70exists flexVars constraint =
71 CLet [] flexVars Map.empty constraint CTrue
75-- TYPE PRIMITIVES
78type Variable =
79 UF.Point Descriptor
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)
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)
104-- DESCRIPTORS
107data Descriptor =
108 Descriptor
109 { _content :: Content
110 , _rank :: Int
111 , _mark :: Mark
112 , _copy :: Maybe Variable
113 }
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
126data SuperType
127 = Number
128 | Comparable
129 | Appendable
130 | CompAppend
131 deriving (Eq)
134makeDescriptor :: Content -> Descriptor
135makeDescriptor content =
136 Descriptor content noRank noMark Nothing
140-- RANKS
143noRank :: Int
144noRank =
145 0
148outermostRank :: Int
149outermostRank =
150 1
154-- MARKS
157newtype Mark = Mark Word32
158 deriving (Eq, Ord)
161noMark :: Mark
162noMark =
163 Mark 2
166occursMark :: Mark
167occursMark =
168 Mark 1
171getVarNamesMark :: Mark
172getVarNamesMark =
173 Mark 0
176{-# INLINE nextMark #-}
177nextMark :: Mark -> Mark
178nextMark (Mark mark) =
179 Mark (mark + 1)
183-- FUNCTION TYPES
186infixr 9 ==>
189{-# INLINE (==>) #-}
190(==>) :: Type -> Type -> Type
191(==>) =
192 FunN
196-- PRIMITIVE TYPES
199{-# NOINLINE int #-}
200int :: Type
201int = AppN ModuleName.basics "Int" []
204{-# NOINLINE float #-}
205float :: Type
206float = AppN ModuleName.basics "Float" []
209{-# NOINLINE char #-}
210char :: Type
211char = AppN ModuleName.char "Char" []
214{-# NOINLINE string #-}
215string :: Type
216string = AppN ModuleName.string "String" []
219{-# NOINLINE bool #-}
220bool :: Type
221bool = AppN ModuleName.basics "Bool" []
224{-# NOINLINE never #-}
225never :: Type
226never = AppN ModuleName.basics "Never" []
230-- WEBGL TYPES
233{-# NOINLINE vec2 #-}
234vec2 :: Type
235vec2 = AppN ModuleName.vector2 "Vec2" []
238{-# NOINLINE vec3 #-}
239vec3 :: Type
240vec3 = AppN ModuleName.vector3 "Vec3" []
243{-# NOINLINE vec4 #-}
244vec4 :: Type
245vec4 = AppN ModuleName.vector4 "Vec4" []
248{-# NOINLINE mat4 #-}
249mat4 :: Type
250mat4 = AppN ModuleName.matrix4 "Mat4" []
253{-# NOINLINE texture #-}
254texture :: Type
255texture = AppN ModuleName.texture "Texture" []
259-- MAKE FLEX VARIABLES
262mkFlexVar :: IO Variable
263mkFlexVar =
264 UF.fresh flexVarDescriptor
267{-# NOINLINE flexVarDescriptor #-}
268flexVarDescriptor :: Descriptor
269flexVarDescriptor =
270 makeDescriptor unnamedFlexVar
273{-# NOINLINE unnamedFlexVar #-}
274unnamedFlexVar :: Content
275unnamedFlexVar =
276 FlexVar Nothing
280-- MAKE FLEX NUMBERS
283mkFlexNumber :: IO Variable
284mkFlexNumber =
285 UF.fresh flexNumberDescriptor
288{-# NOINLINE flexNumberDescriptor #-}
289flexNumberDescriptor :: Descriptor
290flexNumberDescriptor =
291 makeDescriptor (unnamedFlexSuper Number)
294unnamedFlexSuper :: SuperType -> Content
295unnamedFlexSuper super =
296 FlexSuper super Nothing
300-- MAKE NAMED VARIABLES
303nameToFlex :: Name.Name -> IO Variable
304nameToFlex name =
305 UF.fresh $ makeDescriptor $
306 maybe FlexVar FlexSuper (toSuper name) (Just name)
309nameToRigid :: Name.Name -> IO Variable
310nameToRigid name =
311 UF.fresh $ makeDescriptor $
312 maybe RigidVar RigidSuper (toSuper name) name
315toSuper :: Name.Name -> Maybe SuperType
316toSuper name =
317 if Name.isNumberType name then
318 Just Number
320 else if Name.isComparableType name then
321 Just Comparable
323 else if Name.isAppendableType name then
324 Just Appendable
326 else if Name.isCompappendType name then
327 Just CompAppend
329 else
330 Nothing
334-- TO TYPE ANNOTATION
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
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
352 FlexVar maybeName ->
353 case maybeName of
354 Just name ->
355 return (Can.TVar name)
357 Nothing ->
358 do name <- getFreshVarName
359 liftIO $ UF.modify variable (\desc -> desc { _content = FlexVar (Just name) })
360 return (Can.TVar name)
362 FlexSuper super maybeName ->
363 case maybeName of
364 Just name ->
365 return (Can.TVar name)
367 Nothing ->
368 do name <- getFreshSuperName super
369 liftIO $ UF.modify variable (\desc -> desc { _content = FlexSuper super (Just name) })
370 return (Can.TVar name)
372 RigidVar name ->
373 return (Can.TVar name)
375 RigidSuper _ name ->
376 return (Can.TVar name)
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))
383 Error ->
384 error "cannot handle Error types in variableToCanType"
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
393 Fun1 a b ->
394 Can.TLambda
395 <$> variableToCanType a
396 <*> variableToCanType b
398 EmptyRecord1 ->
399 return $ Can.TRecord Map.empty Nothing
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
409 Can.TVar name ->
410 Can.TRecord canFields (Just name)
412 _ ->
413 error "Used toAnnotation on a type that is not well-formed"
415 Unit1 ->
416 return Can.TUnit
418 Tuple1 a b maybeC ->
419 Can.TTuple
420 <$> variableToCanType a
421 <*> variableToCanType b
422 <*> traverse variableToCanType maybeC
425fieldToCanType :: Variable -> StateT NameState IO Can.FieldType
426fieldToCanType variable =
427 do tipe <- variableToCanType variable
428 return (Can.FieldType 0 tipe)
432-- TO ERROR TYPE
435toErrorType :: Variable -> IO ET.Type
436toErrorType variable =
437 do userNames <- getVarNames variable Map.empty
438 State.evalStateT (variableToErrorType variable) (makeNameState userNames)
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
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
456contentToErrorType :: Variable -> Content -> StateT NameState IO ET.Type
457contentToErrorType variable content =
458 case content of
459 Structure term ->
460 termToErrorType term
462 FlexVar maybeName ->
463 case maybeName of
464 Just name ->
465 return (ET.FlexVar name)
467 Nothing ->
468 do name <- getFreshVarName
469 liftIO $ UF.modify variable (\desc -> desc { _content = FlexVar (Just name) })
470 return (ET.FlexVar name)
472 FlexSuper super maybeName ->
473 case maybeName of
474 Just name ->
475 return (ET.FlexSuper (superToSuper super) name)
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)
482 RigidVar name ->
483 return (ET.RigidVar name)
485 RigidSuper super name ->
486 return (ET.RigidSuper (superToSuper super) name)
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)
493 Error ->
494 return ET.Error
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
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
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)
520 _ ->
521 ET.Lambda arg result []
523 EmptyRecord1 ->
524 return $ ET.Record Map.empty ET.Closed
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
534 ET.FlexVar ext ->
535 ET.Record errFields (ET.FlexOpen ext)
537 ET.RigidVar ext ->
538 ET.Record errFields (ET.RigidOpen ext)
540 _ ->
541 error "Used toErrorType on a type that is not well-formed"
543 Unit1 ->
544 return ET.Unit
546 Tuple1 a b maybeC ->
547 ET.Tuple
548 <$> variableToErrorType a
549 <*> variableToErrorType b
550 <*> traverse variableToErrorType maybeC
554-- MANAGE FRESH VARIABLE NAMES
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 }
568makeNameState :: Map.Map Name.Name Variable -> NameState
569makeNameState taken =
570 NameState (Map.map (const ()) taken) 0 0 0 0 0
574-- FRESH VAR NAMES
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
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 )
599-- FRESH SUPER NAMES
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 })
608 Comparable ->
609 getFreshSuper "comparable" _comparables (\index state -> state { _comparables = index })
611 Appendable ->
612 getFreshSuper "appendable" _appendables (\index state -> state { _appendables = index })
614 CompAppend ->
615 getFreshSuper "compappend" _compAppends (\index state -> state { _compAppends = index })
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
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
636 else
637 ( name, index + 1, Map.insert name () taken )
641-- GET ALL VARIABLE NAMES
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
655 FlexVar maybeName ->
656 case maybeName of
657 Nothing ->
658 return takenNames
660 Just name ->
661 addName 0 name var (FlexVar . Just) takenNames
663 FlexSuper super maybeName ->
664 case maybeName of
665 Nothing ->
666 return takenNames
668 Just name ->
669 addName 0 name var (FlexSuper super . Just) takenNames
671 RigidVar name ->
672 addName 0 name var RigidVar takenNames
674 RigidSuper super name ->
675 addName 0 name var (RigidSuper super) takenNames
677 Alias _ _ args _ ->
678 foldrM getVarNames takenNames (map snd args)
680 Structure flatType ->
681 case flatType of
682 App1 _ _ args ->
683 foldrM getVarNames takenNames args
685 Fun1 arg body ->
686 getVarNames arg =<< getVarNames body takenNames
688 EmptyRecord1 ->
689 return takenNames
691 Record1 fields extension ->
692 getVarNames extension =<<
693 foldrM getVarNames takenNames (Map.elems fields)
695 Unit1 ->
696 return takenNames
698 Tuple1 a b Nothing ->
699 getVarNames a =<< getVarNames b takenNames
701 Tuple1 a b (Just c) ->
702 getVarNames a =<< getVarNames b =<< getVarNames c takenNames
706-- REGISTER NAME / RENAME DUPLICATES
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
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