git.iko.soy/elk
on 6a96e21 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 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.webgl "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 variableToCanType 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
427-- TO ERROR TYPE
430toErrorType :: Variable -> IO ET.Type
431toErrorType variable =
432 do userNames <- getVarNames variable Map.empty
433 State.evalStateT (variableToErrorType variable) (makeNameState userNames)
436variableToErrorType :: Variable -> StateT NameState IO ET.Type
437variableToErrorType variable =
438 do descriptor <- liftIO $ UF.get variable
439 let mark = _mark descriptor
440 if mark == occursMark
441 then
442 return ET.Infinite
444 else
445 do liftIO $ UF.modify variable (\desc -> desc { _mark = occursMark })
446 errType <- contentToErrorType variable (_content descriptor)
447 liftIO $ UF.modify variable (\desc -> desc { _mark = mark })
448 return errType
451contentToErrorType :: Variable -> Content -> StateT NameState IO ET.Type
452contentToErrorType variable content =
453 case content of
454 Structure term ->
455 termToErrorType term
457 FlexVar maybeName ->
458 case maybeName of
459 Just name ->
460 return (ET.FlexVar name)
462 Nothing ->
463 do name <- getFreshVarName
464 liftIO $ UF.modify variable (\desc -> desc { _content = FlexVar (Just name) })
465 return (ET.FlexVar name)
467 FlexSuper super maybeName ->
468 case maybeName of
469 Just name ->
470 return (ET.FlexSuper (superToSuper super) name)
472 Nothing ->
473 do name <- getFreshSuperName super
474 liftIO $ UF.modify variable (\desc -> desc { _content = FlexSuper super (Just name) })
475 return (ET.FlexSuper (superToSuper super) name)
477 RigidVar name ->
478 return (ET.RigidVar name)
480 RigidSuper super name ->
481 return (ET.RigidSuper (superToSuper super) name)
483 Alias home name args realVariable ->
484 do errArgs <- traverse (traverse variableToErrorType) args
485 errType <- variableToErrorType realVariable
486 return (ET.Alias home name errArgs errType)
488 Error ->
489 return ET.Error
492superToSuper :: SuperType -> ET.Super
493superToSuper super =
494 case super of
495 Number -> ET.Number
496 Comparable -> ET.Comparable
497 Appendable -> ET.Appendable
498 CompAppend -> ET.CompAppend
501termToErrorType :: FlatType -> StateT NameState IO ET.Type
502termToErrorType term =
503 case term of
504 App1 home name args ->
505 ET.Type home name <$> traverse variableToErrorType args
507 Fun1 a b ->
508 do arg <- variableToErrorType a
509 result <- variableToErrorType b
510 return $
511 case result of
512 ET.Lambda arg1 arg2 others ->
513 ET.Lambda arg arg1 (arg2:others)
515 _ ->
516 ET.Lambda arg result []
518 EmptyRecord1 ->
519 return $ ET.Record Map.empty ET.Closed
521 Record1 fields extension ->
522 do errFields <- traverse variableToErrorType fields
523 errExt <- ET.iteratedDealias <$> variableToErrorType extension
524 return $
525 case errExt of
526 ET.Record subFields subExt ->
527 ET.Record (Map.union subFields errFields) subExt
529 ET.FlexVar ext ->
530 ET.Record errFields (ET.FlexOpen ext)
532 ET.RigidVar ext ->
533 ET.Record errFields (ET.RigidOpen ext)
535 _ ->
536 error "Used toErrorType on a type that is not well-formed"
538 Unit1 ->
539 return ET.Unit
541 Tuple1 a b maybeC ->
542 ET.Tuple
543 <$> variableToErrorType a
544 <*> variableToErrorType b
545 <*> traverse variableToErrorType maybeC
549-- MANAGE FRESH VARIABLE NAMES
552data NameState =
553 NameState
554 { _taken :: Map.Map N.Name ()
555 , _normals :: Int
556 , _numbers :: Int
557 , _comparables :: Int
558 , _appendables :: Int
559 , _compAppends :: Int
560 }
563makeNameState :: Map.Map N.Name Variable -> NameState
564makeNameState taken =
565 NameState (Map.map (const ()) taken) 0 0 0 0 0
569-- FRESH VAR NAMES
572getFreshVarName :: (Monad m) => StateT NameState m N.Name
573getFreshVarName =
574 do index <- State.gets _normals
575 taken <- State.gets _taken
576 let (name, newIndex, newTaken) = getFreshVarNameHelp index taken
577 State.modify $ \state -> state { _taken = newTaken, _normals = newIndex }
578 return name
581getFreshVarNameHelp :: Int -> Map.Map N.Name () -> (N.Name, Int, Map.Map N.Name ())
582getFreshVarNameHelp index taken =
583 let
584 (postfix, letter) =
585 quotRem index 26
587 chr = N.fromLetter letter
588 name = if postfix <= 0 then chr else N.addIndex chr postfix
589 in
590 if Map.member name taken then
591 getFreshVarNameHelp (index + 1) taken
592 else
593 ( name, index + 1, Map.insert name () taken )
597-- FRESH SUPER NAMES
600getFreshSuperName :: (Monad m) => SuperType -> StateT NameState m N.Name
601getFreshSuperName super =
602 case super of
603 Number ->
604 getFreshSuper "number" _numbers (\index state -> state { _numbers = index })
606 Comparable ->
607 getFreshSuper "comparable" _comparables (\index state -> state { _comparables = index })
609 Appendable ->
610 getFreshSuper "appendable" _appendables (\index state -> state { _appendables = index })
612 CompAppend ->
613 getFreshSuper "compappend" _compAppends (\index state -> state { _compAppends = index })
616getFreshSuper :: (Monad m) => N.Name -> (NameState -> Int) -> (Int -> NameState -> NameState) -> StateT NameState m N.Name
617getFreshSuper prefix getter setter =
618 do index <- State.gets getter
619 taken <- State.gets _taken
620 let (name, newIndex, newTaken) = getFreshSuperHelp prefix index taken
621 State.modify (\state -> setter newIndex state { _taken = newTaken })
622 return name
625getFreshSuperHelp :: N.Name -> Int -> Map.Map N.Name () -> (N.Name, Int, Map.Map N.Name ())
626getFreshSuperHelp prefix index taken =
627 let
628 name =
629 if index <= 0 then prefix else N.addIndex prefix index
630 in
631 if Map.member name taken then
632 getFreshSuperHelp prefix (index + 1) taken
634 else
635 ( name, index + 1, Map.insert name () taken )
639-- GET ALL VARIABLE NAMES
642getVarNames :: Variable -> Map.Map N.Name Variable -> IO (Map.Map N.Name Variable)
643getVarNames var takenNames =
644 do (Descriptor content rank mark copy) <- UF.get var
645 if mark == getVarNamesMark
646 then return takenNames
647 else
648 do UF.set var (Descriptor content rank getVarNamesMark copy)
649 case content of
650 Error ->
651 return takenNames
653 FlexVar maybeName ->
654 case maybeName of
655 Nothing ->
656 return takenNames
658 Just name ->
659 addName 0 name var (FlexVar . Just) takenNames
661 FlexSuper super maybeName ->
662 case maybeName of
663 Nothing ->
664 return takenNames
666 Just name ->
667 addName 0 name var (FlexSuper super . Just) takenNames
669 RigidVar name ->
670 addName 0 name var RigidVar takenNames
672 RigidSuper super name ->
673 addName 0 name var (RigidSuper super) takenNames
675 Alias _ _ args _ ->
676 foldrM getVarNames takenNames (map snd args)
678 Structure flatType ->
679 case flatType of
680 App1 _ _ args ->
681 foldrM getVarNames takenNames args
683 Fun1 arg body ->
684 getVarNames arg =<< getVarNames body takenNames
686 EmptyRecord1 ->
687 return takenNames
689 Record1 fields extension ->
690 getVarNames extension =<<
691 foldrM getVarNames takenNames (Map.elems fields)
693 Unit1 ->
694 return takenNames
696 Tuple1 a b Nothing ->
697 getVarNames a =<< getVarNames b takenNames
699 Tuple1 a b (Just c) ->
700 getVarNames a =<< getVarNames b =<< getVarNames c takenNames
704-- REGISTER NAME / RENAME DUPLICATES
707addName :: Int -> N.Name -> Variable -> (N.Name -> Content) -> Map.Map N.Name Variable -> IO (Map.Map N.Name Variable)
708addName index givenName var makeContent takenNames =
709 let
710 indexedName =
711 if index <= 0 then
712 givenName
713 else
714 N.addSafeIndex 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