git.iko.soy/elk
on 32ff950 help sign in
elk/compiler/src/Type/Type.hs
734 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 Data.Word (Word32)
38import qualified AST.Canonical as Can
39import qualified AST.Module.Name as ModuleName
40import qualified AST.Utils.Type as Type
41import qualified Elm.Name as N
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 N.Name (E.Expected Type)
58 | CForeign R.Region N.Name Can.Annotation (E.Expected Type)
59 | CPattern R.Region E.PCategory Type (E.PExpected Type)
60 | CAnd [Constraint]
61 | CBranch
62 { _a :: Type
63 , _b :: Type
64 , _eq :: Constraint
65 , _neq :: IO Constraint
66 }
67 | CLet
68 { _rigidVars :: [Variable]
69 , _flexVars :: [Variable]
70 , _header :: Map.Map N.Name (A.Located Type)
71 , _headerCon :: Constraint
72 , _bodyCon :: Constraint
73 }
76exists :: [Variable] -> Constraint -> Constraint
77exists flexVars constraint =
78 CLet [] flexVars Map.empty constraint CTrue
82-- TYPE PRIMITIVES
85type Variable =
86 UF.Point Descriptor
89data FlatType
90 = App1 ModuleName.Canonical N.Name [Variable]
91 | Fun1 Variable Variable
92 | EmptyRecord1
93 | Record1 (Map.Map N.Name Variable) Variable
94 | Unit1
95 | Tuple1 Variable Variable (Maybe Variable)
98data Type
99 = PlaceHolder N.Name
100 | AliasN ModuleName.Canonical N.Name [(N.Name, Type)] Type
101 | VarN Variable
102 | AppN ModuleName.Canonical N.Name [Type]
103 | FunN Type Type
104 | EmptyRecordN
105 | RecordN (Map.Map N.Name Type) Type
106 | UnitN
107 | TupleN Type Type (Maybe Type)
111-- DESCRIPTORS
114data Descriptor =
115 Descriptor
116 { _content :: Content
117 , _rank :: Int
118 , _mark :: Mark
119 , _copy :: Maybe Variable
120 }
123data Content
124 = FlexVar (Maybe N.Name)
125 | FlexSuper SuperType (Maybe N.Name)
126 | RigidVar N.Name
127 | RigidSuper SuperType N.Name
128 | Structure FlatType
129 | Alias ModuleName.Canonical N.Name [(N.Name,Variable)] Variable
130 | Error
133data SuperType
134 = Number
135 | Comparable
136 | Appendable
137 | CompAppend
138 deriving (Eq)
141makeDescriptor :: Content -> Descriptor
142makeDescriptor content =
143 Descriptor content noRank noMark Nothing
147-- RANKS
150noRank :: Int
151noRank =
152 0
155outermostRank :: Int
156outermostRank =
157 1
161-- MARKS
164newtype Mark = Mark Word32
165 deriving (Eq, Ord)
168noMark :: Mark
169noMark =
170 Mark 2
173occursMark :: Mark
174occursMark =
175 Mark 1
178getVarNamesMark :: Mark
179getVarNamesMark =
180 Mark 0
183{-# INLINE nextMark #-}
184nextMark :: Mark -> Mark
185nextMark (Mark mark) =
186 Mark (mark + 1)
190-- FUNCTION TYPES
193infixr 9 ==>
196{-# INLINE (==>) #-}
197(==>) :: Type -> Type -> Type
198(==>) =
199 FunN
203-- PRIMITIVE TYPES
206{-# NOINLINE int #-}
207int :: Type
208int = AppN ModuleName.basics "Int" []
211{-# NOINLINE float #-}
212float :: Type
213float = AppN ModuleName.basics "Float" []
216{-# NOINLINE char #-}
217char :: Type
218char = AppN ModuleName.char "Char" []
221{-# NOINLINE string #-}
222string :: Type
223string = AppN ModuleName.string "String" []
226{-# NOINLINE bool #-}
227bool :: Type
228bool = AppN ModuleName.basics "Bool" []
231{-# NOINLINE never #-}
232never :: Type
233never = AppN ModuleName.basics "Never" []
237-- WEBGL TYPES
240{-# NOINLINE vec2 #-}
241vec2 :: Type
242vec2 = AppN ModuleName.vector2 "Vec2" []
245{-# NOINLINE vec3 #-}
246vec3 :: Type
247vec3 = AppN ModuleName.vector3 "Vec3" []
250{-# NOINLINE vec4 #-}
251vec4 :: Type
252vec4 = AppN ModuleName.vector4 "Vec4" []
255{-# NOINLINE mat4 #-}
256mat4 :: Type
257mat4 = AppN ModuleName.matrix4 "Mat4" []
260{-# NOINLINE texture #-}
261texture :: Type
262texture = AppN ModuleName.webgl "Texture" []
266-- MAKE FLEX VARIABLES
269mkFlexVar :: IO Variable
270mkFlexVar =
271 UF.fresh flexVarDescriptor
274{-# NOINLINE flexVarDescriptor #-}
275flexVarDescriptor :: Descriptor
276flexVarDescriptor =
277 makeDescriptor unnamedFlexVar
280{-# NOINLINE unnamedFlexVar #-}
281unnamedFlexVar :: Content
282unnamedFlexVar =
283 FlexVar Nothing
287-- MAKE FLEX NUMBERS
290mkFlexNumber :: IO Variable
291mkFlexNumber =
292 UF.fresh flexNumberDescriptor
295{-# NOINLINE flexNumberDescriptor #-}
296flexNumberDescriptor :: Descriptor
297flexNumberDescriptor =
298 makeDescriptor (unnamedFlexSuper Number)
301unnamedFlexSuper :: SuperType -> Content
302unnamedFlexSuper super =
303 FlexSuper super Nothing
307-- MAKE NAMED VARIABLES
310nameToFlex :: N.Name -> IO Variable
311nameToFlex name =
312 UF.fresh $ makeDescriptor $
313 maybe FlexVar FlexSuper (toSuper name) (Just name)
316nameToRigid :: N.Name -> IO Variable
317nameToRigid name =
318 UF.fresh $ makeDescriptor $
319 maybe RigidVar RigidSuper (toSuper name) name
322toSuper :: N.Name -> Maybe SuperType
323toSuper name =
324 if N.startsWith "number" name then
325 Just Number
327 else if N.startsWith "comparable" name then
328 Just Comparable
330 else if N.startsWith "appendable" name then
331 Just Appendable
333 else if N.startsWith "compappend" name then
334 Just CompAppend
336 else
337 Nothing
341-- TO TYPE ANNOTATION
344toAnnotation :: Variable -> IO Can.Annotation
345toAnnotation variable =
346 do userNames <- getVarNames variable Map.empty
347 (tipe, NameState allNames _ _ _ _ _) <-
348 State.runStateT (variableToCanType variable) (makeNameState userNames)
349 return $ Can.Forall (Map.map (const ()) allNames) tipe
352variableToCanType :: Variable -> StateT NameState IO Can.Type
353variableToCanType variable =
354 do (Descriptor content _ _ _) <- liftIO $ UF.get variable
355 case content of
356 Structure term ->
357 termToCanType term
359 FlexVar maybeName ->
360 case maybeName of
361 Just name ->
362 return (Can.TVar name)
364 Nothing ->
365 do name <- getFreshVarName
366 liftIO $ UF.modify variable (\desc -> desc { _content = FlexVar (Just name) })
367 return (Can.TVar name)
369 FlexSuper super maybeName ->
370 case maybeName of
371 Just name ->
372 return (Can.TVar name)
374 Nothing ->
375 do name <- getFreshSuperName super
376 liftIO $ UF.modify variable (\desc -> desc { _content = FlexSuper super (Just name) })
377 return (Can.TVar name)
379 RigidVar name ->
380 return (Can.TVar name)
382 RigidSuper _ name ->
383 return (Can.TVar name)
385 Alias home name args realVariable ->
386 do canArgs <- traverse (traverse variableToCanType) args
387 canType <- variableToCanType realVariable
388 return (Can.TAlias home name canArgs (Can.Filled canType))
390 Error ->
391 error "cannot handle Error types in variableToCanType"
394termToCanType :: FlatType -> StateT NameState IO Can.Type
395termToCanType term =
396 case term of
397 App1 home name args ->
398 Can.TType home name <$> traverse variableToCanType args
400 Fun1 a b ->
401 Can.TLambda
402 <$> variableToCanType a
403 <*> variableToCanType b
405 EmptyRecord1 ->
406 return $ Can.TRecord Map.empty Nothing
408 Record1 fields extension ->
409 do canFields <- traverse variableToCanType fields
410 canExt <- Type.iteratedDealias <$> variableToCanType extension
411 return $
412 case canExt of
413 Can.TRecord subFields subExt ->
414 Can.TRecord (Map.union subFields canFields) subExt
416 Can.TVar name ->
417 Can.TRecord canFields (Just name)
419 _ ->
420 error "Used toAnnotation on a type that is not well-formed"
422 Unit1 ->
423 return Can.TUnit
425 Tuple1 a b maybeC ->
426 Can.TTuple
427 <$> variableToCanType a
428 <*> variableToCanType b
429 <*> traverse variableToCanType maybeC
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 :: TakenNames
561 , _normals :: Int
562 , _numbers :: Int
563 , _comparables :: Int
564 , _appendables :: Int
565 , _compAppends :: Int
566 }
569type TakenNames = Map.Map N.Name Variable
572makeNameState :: TakenNames -> NameState
573makeNameState taken =
574 NameState taken 0 0 0 0 0
577getFreshVarName :: (Monad m) => StateT NameState m N.Name
578getFreshVarName =
579 do index <- State.gets _normals
580 taken <- State.gets _taken
581 let (uniqueName, newIndex) = getFreshNormal index taken
582 State.modify (\state -> state { _normals = newIndex })
583 return uniqueName
586getFreshSuperName :: (Monad m) => SuperType -> StateT NameState m N.Name
587getFreshSuperName super =
588 case super of
589 Number ->
590 getFreshSuper "number" _numbers (\index state -> state { _numbers = index })
592 Comparable ->
593 getFreshSuper "comparable" _comparables (\index state -> state { _comparables = index })
595 Appendable ->
596 getFreshSuper "appendable" _appendables (\index state -> state { _appendables = index })
598 CompAppend ->
599 getFreshSuper "compappend" _compAppends (\index state -> state { _compAppends = index })
602getFreshNormal :: Int -> TakenNames -> (N.Name, Int)
603getFreshNormal index taken =
604 let
605 (postfix, letter) =
606 quotRem index 26
608 chr = N.fromLetter letter
609 name = if postfix <= 0 then chr else N.addIndex chr postfix
610 in
611 if Map.member name taken then
612 getFreshNormal (index + 1) taken
614 else
615 (name, index + 1)
618getFreshSuper
619 :: (Monad m)
620 => N.Name
621 -> (NameState -> Int)
622 -> (Int -> NameState -> NameState)
623 -> StateT NameState m N.Name
624getFreshSuper name getter setter =
625 do index <- State.gets getter
626 taken <- State.gets _taken
627 let (uniqueName, newIndex) = getFreshSuperHelp name index taken
628 State.modify (setter newIndex)
629 return uniqueName
632getFreshSuperHelp :: N.Name -> Int -> TakenNames -> (N.Name, Int)
633getFreshSuperHelp name index taken =
634 let
635 newName =
636 if index <= 0 then name else N.addIndex name index
637 in
638 if Map.member newName taken then
639 getFreshSuperHelp name (index + 1) taken
641 else
642 (newName, index + 1)
646-- GET ALL VARIABLE NAMES
649getVarNames :: Variable -> TakenNames -> IO TakenNames
650getVarNames var takenNames =
651 do (Descriptor content rank mark copy) <- UF.get var
652 if mark == getVarNamesMark
653 then return takenNames
654 else
655 do UF.set var (Descriptor content rank getVarNamesMark copy)
656 case content of
657 Error ->
658 return takenNames
660 FlexVar maybeName ->
661 case maybeName of
662 Nothing ->
663 return takenNames
665 Just name ->
666 addName 0 name var (FlexVar . Just) takenNames
668 FlexSuper super maybeName ->
669 case maybeName of
670 Nothing ->
671 return takenNames
673 Just name ->
674 addName 0 name var (FlexSuper super . Just) takenNames
676 RigidVar name ->
677 addName 0 name var RigidVar takenNames
679 RigidSuper super name ->
680 addName 0 name var (RigidSuper super) takenNames
682 Alias _ _ args _ ->
683 foldrM getVarNames takenNames (map snd args)
685 Structure flatType ->
686 case flatType of
687 App1 _ _ args ->
688 foldrM getVarNames takenNames args
690 Fun1 arg body ->
691 getVarNames arg =<< getVarNames body takenNames
693 EmptyRecord1 ->
694 return takenNames
696 Record1 fields extension ->
697 getVarNames extension =<<
698 foldrM getVarNames takenNames (Map.elems fields)
700 Unit1 ->
701 return takenNames
703 Tuple1 a b Nothing ->
704 getVarNames a =<< getVarNames b takenNames
706 Tuple1 a b (Just c) ->
707 getVarNames a =<< getVarNames b =<< getVarNames c takenNames
711-- REGISTER NAME / RENAME DUPLICATES
714addName :: Int -> N.Name -> Variable -> (N.Name -> Content) -> TakenNames -> IO TakenNames
715addName index givenName var makeContent takenNames =
716 let
717 indexedName =
718 if index <= 0 then
719 givenName
720 else
721 N.addSafeIndex givenName index
722 in
723 case Map.lookup indexedName takenNames of
724 Nothing ->
725 do if indexedName == givenName then return () else
726 UF.modify var $ \(Descriptor _ rank mark copy) ->
727 Descriptor (makeContent indexedName) rank mark copy
728 return $ Map.insert indexedName var takenNames
730 Just otherVar ->
731 do same <- UF.equivalent var otherVar
732 if same
733 then return takenNames
734 else addName (index + 1) givenName var makeContent takenNames