git.iko.soy/elk
on b5df201 help sign in
elk/src/Type/Type.hs
725 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 name)
478 Nothing ->
479 do name <- getFreshSuperName super
480 liftIO $ UF.modify variable (\desc -> desc { _content = FlexSuper super (Just name) })
481 return (ET.FlexSuper name)
483 RigidVar name ->
484 return (ET.RigidVar name)
486 RigidSuper _ name ->
487 return (ET.RigidSuper 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
498termToErrorType :: FlatType -> StateT NameState IO ET.Type
499termToErrorType term =
500 case term of
501 App1 home name args ->
502 ET.Type home name <$> traverse variableToErrorType args
504 Fun1 a b ->
505 do arg <- variableToErrorType a
506 result <- variableToErrorType b
507 return $
508 case result of
509 ET.Lambda arg1 arg2 others ->
510 ET.Lambda arg arg1 (arg2:others)
512 _ ->
513 ET.Lambda arg result []
515 EmptyRecord1 ->
516 return $ ET.Record Map.empty ET.Closed
518 Record1 fields extension ->
519 do errFields <- traverse variableToErrorType fields
520 errExt <- ET.iteratedDealias <$> variableToErrorType extension
521 return $
522 case errExt of
523 ET.Record subFields subExt ->
524 ET.Record (Map.union subFields errFields) subExt
526 ET.FlexVar ext ->
527 ET.Record errFields (ET.FlexOpen ext)
529 ET.RigidVar ext ->
530 ET.Record errFields (ET.RigidOpen ext)
532 _ ->
533 error "Used toErrorType on a type that is not well-formed"
535 Unit1 ->
536 return ET.Unit
538 Tuple1 a b maybeC ->
539 ET.Tuple
540 <$> variableToErrorType a
541 <*> variableToErrorType b
542 <*> traverse variableToErrorType maybeC
546-- MANAGE FRESH VARIABLE NAMES
549data NameState =
550 NameState
551 { _taken :: TakenNames
552 , _normals :: Int
553 , _numbers :: Int
554 , _comparables :: Int
555 , _appendables :: Int
556 , _compAppends :: Int
557 }
560type TakenNames = Map.Map N.Name Variable
563makeNameState :: TakenNames -> NameState
564makeNameState taken =
565 NameState taken 0 0 0 0 0
568getFreshVarName :: (Monad m) => StateT NameState m N.Name
569getFreshVarName =
570 do index <- State.gets _normals
571 taken <- State.gets _taken
572 let (uniqueName, newIndex) = getFreshNormal index taken
573 State.modify (\state -> state { _normals = newIndex })
574 return uniqueName
577getFreshSuperName :: (Monad m) => SuperType -> StateT NameState m N.Name
578getFreshSuperName super =
579 case super of
580 Number ->
581 getFreshSuper "number" _numbers (\index state -> state { _numbers = index })
583 Comparable ->
584 getFreshSuper "comparable" _comparables (\index state -> state { _comparables = index })
586 Appendable ->
587 getFreshSuper "appendable" _appendables (\index state -> state { _appendables = index })
589 CompAppend ->
590 getFreshSuper "compappend" _compAppends (\index state -> state { _compAppends = index })
593getFreshNormal :: Int -> TakenNames -> (N.Name, Int)
594getFreshNormal index taken =
595 let
596 (postfix, letter) =
597 quotRem index 26
599 chr = N.fromLetter letter
600 name = if postfix <= 0 then chr else N.addIndex chr postfix
601 in
602 if Map.member name taken then
603 getFreshNormal (index + 1) taken
605 else
606 (name, index + 1)
609getFreshSuper
610 :: (Monad m)
611 => N.Name
612 -> (NameState -> Int)
613 -> (Int -> NameState -> NameState)
614 -> StateT NameState m N.Name
615getFreshSuper name getter setter =
616 do index <- State.gets getter
617 taken <- State.gets _taken
618 let (uniqueName, newIndex) = getFreshSuperHelp name index taken
619 State.modify (setter newIndex)
620 return uniqueName
623getFreshSuperHelp :: N.Name -> Int -> TakenNames -> (N.Name, Int)
624getFreshSuperHelp name index taken =
625 let
626 newName =
627 if index <= 0 then name else N.addIndex name index
628 in
629 if Map.member newName taken then
630 getFreshSuperHelp name (index + 1) taken
632 else
633 (newName, index + 1)
637-- GET ALL VARIABLE NAMES
640getVarNames :: Variable -> TakenNames -> IO TakenNames
641getVarNames var takenNames =
642 do (Descriptor content rank mark copy) <- UF.get var
643 if mark == getVarNamesMark
644 then return takenNames
645 else
646 do UF.set var (Descriptor content rank getVarNamesMark copy)
647 case content of
648 Error ->
649 return takenNames
651 FlexVar maybeName ->
652 case maybeName of
653 Nothing ->
654 return takenNames
656 Just name ->
657 addName 0 name var (FlexVar . Just) takenNames
659 FlexSuper super maybeName ->
660 case maybeName of
661 Nothing ->
662 return takenNames
664 Just name ->
665 addName 0 name var (FlexSuper super . Just) takenNames
667 RigidVar name ->
668 addName 0 name var RigidVar takenNames
670 RigidSuper super name ->
671 addName 0 name var (RigidSuper super) takenNames
673 Alias _ _ args _ ->
674 foldrM getVarNames takenNames (map snd args)
676 Structure flatType ->
677 case flatType of
678 App1 _ _ args ->
679 foldrM getVarNames takenNames args
681 Fun1 arg body ->
682 getVarNames arg =<< getVarNames body takenNames
684 EmptyRecord1 ->
685 return takenNames
687 Record1 fields extension ->
688 getVarNames extension =<<
689 foldrM getVarNames takenNames (Map.elems fields)
691 Unit1 ->
692 return takenNames
694 Tuple1 a b Nothing ->
695 getVarNames a =<< getVarNames b takenNames
697 Tuple1 a b (Just c) ->
698 getVarNames a =<< getVarNames b =<< getVarNames c takenNames
702-- REGISTER NAME / RENAME DUPLICATES
705addName :: Int -> N.Name -> Variable -> (N.Name -> Content) -> TakenNames -> IO TakenNames
706addName index givenName var makeContent takenNames =
707 let
708 indexedName =
709 if index <= 0 then
710 givenName
711 else
712 N.addSafeIndex givenName index
713 in
714 case Map.lookup indexedName takenNames of
715 Nothing ->
716 do if indexedName == givenName then return () else
717 UF.modify var $ \(Descriptor _ rank mark copy) ->
718 Descriptor (makeContent indexedName) rank mark copy
719 return $ Map.insert indexedName var takenNames
721 Just otherVar ->
722 do same <- UF.equivalent var otherVar
723 if same
724 then return takenNames
725 else addName (index + 1) givenName var makeContent takenNames