git.iko.soy/elk
on eb236ca help sign in
elk/compiler/src/Type/Type.hs
733 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 | CLet
62 { _rigidVars :: [Variable]
63 , _flexVars :: [Variable]
64 , _header :: Map.Map N.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 N.Name [Variable]
85 | Fun1 Variable Variable
86 | EmptyRecord1
87 | Record1 (Map.Map N.Name Variable) Variable
88 | Unit1
89 | Tuple1 Variable Variable (Maybe Variable)
92data Type
93 = PlaceHolder N.Name
94 | AliasN ModuleName.Canonical N.Name [(N.Name, Type)] Type
95 | VarN Variable
96 | AppN ModuleName.Canonical N.Name [Type]
97 | FunN Type Type
98 | EmptyRecordN
99 | RecordN (Map.Map N.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 N.Name)
119 | FlexSuper SuperType (Maybe N.Name)
120 | RigidVar N.Name
121 | RigidSuper SuperType N.Name
122 | Structure FlatType
123 | Alias ModuleName.Canonical N.Name [(N.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 :: N.Name -> IO Variable
305nameToFlex name =
306 UF.fresh $ makeDescriptor $
307 maybe FlexVar FlexSuper (toSuper name) (Just name)
310nameToRigid :: N.Name -> IO Variable
311nameToRigid name =
312 UF.fresh $ makeDescriptor $
313 maybe RigidVar RigidSuper (toSuper name) name
316toSuper :: N.Name -> Maybe SuperType
317toSuper name =
318 if N.startsWith "number" name then
319 Just Number
321 else if N.startsWith "comparable" name then
322 Just Comparable
324 else if N.startsWith "appendable" name then
325 Just Appendable
327 else if N.startsWith "compappend" 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 N.Name ()
561 , _normals :: Int
562 , _numbers :: Int
563 , _comparables :: Int
564 , _appendables :: Int
565 , _compAppends :: Int
566 }
569makeNameState :: Map.Map N.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 N.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 N.Name () -> (N.Name, Int, Map.Map N.Name ())
588getFreshVarNameHelp index taken =
589 let
590 (postfix, letter) =
591 quotRem index 26
593 chr = N.fromLetter letter
594 name = if postfix <= 0 then chr else N.addIndex chr postfix
595 in
596 if Map.member name taken then
597 getFreshVarNameHelp (index + 1) taken
598 else
599 ( name, index + 1, Map.insert name () taken )
603-- FRESH SUPER NAMES
606getFreshSuperName :: (Monad m) => SuperType -> StateT NameState m N.Name
607getFreshSuperName super =
608 case super of
609 Number ->
610 getFreshSuper "number" _numbers (\index state -> state { _numbers = index })
612 Comparable ->
613 getFreshSuper "comparable" _comparables (\index state -> state { _comparables = index })
615 Appendable ->
616 getFreshSuper "appendable" _appendables (\index state -> state { _appendables = index })
618 CompAppend ->
619 getFreshSuper "compappend" _compAppends (\index state -> state { _compAppends = index })
622getFreshSuper :: (Monad m) => N.Name -> (NameState -> Int) -> (Int -> NameState -> NameState) -> StateT NameState m N.Name
623getFreshSuper prefix getter setter =
624 do index <- State.gets getter
625 taken <- State.gets _taken
626 let (name, newIndex, newTaken) = getFreshSuperHelp prefix index taken
627 State.modify (\state -> setter newIndex state { _taken = newTaken })
628 return name
631getFreshSuperHelp :: N.Name -> Int -> Map.Map N.Name () -> (N.Name, Int, Map.Map N.Name ())
632getFreshSuperHelp prefix index taken =
633 let
634 name =
635 if index <= 0 then prefix else N.addIndex prefix index
636 in
637 if Map.member name taken then
638 getFreshSuperHelp prefix (index + 1) taken
640 else
641 ( name, index + 1, Map.insert name () taken )
645-- GET ALL VARIABLE NAMES
648getVarNames :: Variable -> Map.Map N.Name Variable -> IO (Map.Map N.Name Variable)
649getVarNames var takenNames =
650 do (Descriptor content rank mark copy) <- UF.get var
651 if mark == getVarNamesMark
652 then return takenNames
653 else
654 do UF.set var (Descriptor content rank getVarNamesMark copy)
655 case content of
656 Error ->
657 return takenNames
659 FlexVar maybeName ->
660 case maybeName of
661 Nothing ->
662 return takenNames
664 Just name ->
665 addName 0 name var (FlexVar . Just) takenNames
667 FlexSuper super maybeName ->
668 case maybeName of
669 Nothing ->
670 return takenNames
672 Just name ->
673 addName 0 name var (FlexSuper super . Just) takenNames
675 RigidVar name ->
676 addName 0 name var RigidVar takenNames
678 RigidSuper super name ->
679 addName 0 name var (RigidSuper super) takenNames
681 Alias _ _ args _ ->
682 foldrM getVarNames takenNames (map snd args)
684 Structure flatType ->
685 case flatType of
686 App1 _ _ args ->
687 foldrM getVarNames takenNames args
689 Fun1 arg body ->
690 getVarNames arg =<< getVarNames body takenNames
692 EmptyRecord1 ->
693 return takenNames
695 Record1 fields extension ->
696 getVarNames extension =<<
697 foldrM getVarNames takenNames (Map.elems fields)
699 Unit1 ->
700 return takenNames
702 Tuple1 a b Nothing ->
703 getVarNames a =<< getVarNames b takenNames
705 Tuple1 a b (Just c) ->
706 getVarNames a =<< getVarNames b =<< getVarNames c takenNames
710-- REGISTER NAME / RENAME DUPLICATES
713addName :: Int -> N.Name -> Variable -> (N.Name -> Content) -> Map.Map N.Name Variable -> IO (Map.Map N.Name Variable)
714addName index givenName var makeContent takenNames =
715 let
716 indexedName =
717 if index <= 0 then
718 givenName
719 else
720 N.addSafeIndex givenName index
721 in
722 case Map.lookup indexedName takenNames of
723 Nothing ->
724 do if indexedName == givenName then return () else
725 UF.modify var $ \(Descriptor _ rank mark copy) ->
726 Descriptor (makeContent indexedName) rank mark copy
727 return $ Map.insert indexedName var takenNames
729 Just otherVar ->
730 do same <- UF.equivalent var otherVar
731 if same
732 then return takenNames
733 else addName (index + 1) givenName var makeContent takenNames