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
30
31
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)
38
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
46
47
48
49-- CONSTRAINTS
50
51
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      }
67
68
69exists :: [Variable] -> Constraint -> Constraint
70exists flexVars constraint =
71  CLet [] flexVars Map.empty constraint CTrue
72
73
74
75-- TYPE PRIMITIVES
76
77
78type Variable =
79    UF.Point Descriptor
80
81
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)
89
90
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)
101
102
103
104-- DESCRIPTORS
105
106
107data Descriptor =
108  Descriptor
109    { _content :: Content
110    , _rank :: Int
111    , _mark :: Mark
112    , _copy :: Maybe Variable
113    }
114
115
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
124
125
126data SuperType
127  = Number
128  | Comparable
129  | Appendable
130  | CompAppend
131  deriving (Eq)
132
133
134makeDescriptor :: Content -> Descriptor
135makeDescriptor content =
136  Descriptor content noRank noMark Nothing
137
138
139
140-- RANKS
141
142
143noRank :: Int
144noRank =
145  0
146
147
148outermostRank :: Int
149outermostRank =
150  1
151
152
153
154-- MARKS
155
156
157newtype Mark = Mark Word32
158  deriving (Eq, Ord)
159
160
161noMark :: Mark
162noMark =
163  Mark 2
164
165
166occursMark :: Mark
167occursMark =
168  Mark 1
169
170
171getVarNamesMark :: Mark
172getVarNamesMark =
173  Mark 0
174
175
176{-# INLINE nextMark #-}
177nextMark :: Mark -> Mark
178nextMark (Mark mark) =
179  Mark (mark + 1)
180
181
182
183-- FUNCTION TYPES
184
185
186infixr 9 ==>
187
188
189{-# INLINE (==>) #-}
190(==>) :: Type -> Type -> Type
191(==>) =
192  FunN
193
194
195
196-- PRIMITIVE TYPES
197
198
199{-# NOINLINE int #-}
200int :: Type
201int = AppN ModuleName.basics "Int" []
202
203
204{-# NOINLINE float #-}
205float :: Type
206float = AppN ModuleName.basics "Float" []
207
208
209{-# NOINLINE char #-}
210char :: Type
211char = AppN ModuleName.char "Char" []
212
213
214{-# NOINLINE string #-}
215string :: Type
216string = AppN ModuleName.string "String" []
217
218
219{-# NOINLINE bool #-}
220bool :: Type
221bool = AppN ModuleName.basics "Bool" []
222
223
224{-# NOINLINE never #-}
225never :: Type
226never = AppN ModuleName.basics "Never" []
227
228
229
230-- WEBGL TYPES
231
232
233{-# NOINLINE vec2 #-}
234vec2 :: Type
235vec2 = AppN ModuleName.vector2 "Vec2" []
236
237
238{-# NOINLINE vec3 #-}
239vec3 :: Type
240vec3 = AppN ModuleName.vector3 "Vec3" []
241
242
243{-# NOINLINE vec4 #-}
244vec4 :: Type
245vec4 = AppN ModuleName.vector4 "Vec4" []
246
247
248{-# NOINLINE mat4 #-}
249mat4 :: Type
250mat4 = AppN ModuleName.matrix4 "Mat4" []
251
252
253{-# NOINLINE texture #-}
254texture :: Type
255texture = AppN ModuleName.texture "Texture" []
256
257
258
259-- MAKE FLEX VARIABLES
260
261
262mkFlexVar :: IO Variable
263mkFlexVar =
264  UF.fresh flexVarDescriptor
265
266
267{-# NOINLINE flexVarDescriptor #-}
268flexVarDescriptor :: Descriptor
269flexVarDescriptor =
270  makeDescriptor unnamedFlexVar
271
272
273{-# NOINLINE unnamedFlexVar #-}
274unnamedFlexVar :: Content
275unnamedFlexVar =
276  FlexVar Nothing
277
278
279
280-- MAKE FLEX NUMBERS
281
282
283mkFlexNumber :: IO Variable
284mkFlexNumber =
285  UF.fresh flexNumberDescriptor
286
287
288{-# NOINLINE flexNumberDescriptor #-}
289flexNumberDescriptor :: Descriptor
290flexNumberDescriptor =
291  makeDescriptor (unnamedFlexSuper Number)
292
293
294unnamedFlexSuper :: SuperType -> Content
295unnamedFlexSuper super =
296  FlexSuper super Nothing
297
298
299
300-- MAKE NAMED VARIABLES
301
302
303nameToFlex :: Name.Name -> IO Variable
304nameToFlex name =
305  UF.fresh $ makeDescriptor $
306    maybe FlexVar FlexSuper (toSuper name) (Just name)
307
308
309nameToRigid :: Name.Name -> IO Variable
310nameToRigid name =
311  UF.fresh $ makeDescriptor $
312    maybe RigidVar RigidSuper (toSuper name) name
313
314
315toSuper :: Name.Name -> Maybe SuperType
316toSuper name =
317  if Name.isNumberType name then
318      Just Number
319
320  else if Name.isComparableType name then
321      Just Comparable
322
323  else if Name.isAppendableType name then
324      Just Appendable
325
326  else if Name.isCompappendType name then
327      Just CompAppend
328
329  else
330      Nothing
331
332
333
334-- TO TYPE ANNOTATION
335
336
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
343
344
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
351
352        FlexVar maybeName ->
353          case maybeName of
354            Just name ->
355              return (Can.TVar name)
356
357            Nothing ->
358              do  name <- getFreshVarName
359                  liftIO $ UF.modify variable (\desc -> desc { _content = FlexVar (Just name) })
360                  return (Can.TVar name)
361
362        FlexSuper super maybeName ->
363          case maybeName of
364            Just name ->
365              return (Can.TVar name)
366
367            Nothing ->
368              do  name <- getFreshSuperName super
369                  liftIO $ UF.modify variable (\desc -> desc { _content = FlexSuper super (Just name) })
370                  return (Can.TVar name)
371
372        RigidVar name ->
373            return (Can.TVar name)
374
375        RigidSuper _ name ->
376            return (Can.TVar name)
377
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))
382
383        Error ->
384            error "cannot handle Error types in variableToCanType"
385
386
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
392
393    Fun1 a b ->
394      Can.TLambda
395        <$> variableToCanType a
396        <*> variableToCanType b
397
398    EmptyRecord1 ->
399      return $ Can.TRecord Map.empty Nothing
400
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
408
409                Can.TVar name ->
410                    Can.TRecord canFields (Just name)
411
412                _ ->
413                    error "Used toAnnotation on a type that is not well-formed"
414
415    Unit1 ->
416      return Can.TUnit
417
418    Tuple1 a b maybeC ->
419      Can.TTuple
420        <$> variableToCanType a
421        <*> variableToCanType b
422        <*> traverse variableToCanType maybeC
423
424
425fieldToCanType :: Variable -> StateT NameState IO Can.FieldType
426fieldToCanType variable =
427  do  tipe <- variableToCanType variable
428      return (Can.FieldType 0 tipe)
429
430
431
432-- TO ERROR TYPE
433
434
435toErrorType :: Variable -> IO ET.Type
436toErrorType variable =
437  do  userNames <- getVarNames variable Map.empty
438      State.evalStateT (variableToErrorType variable) (makeNameState userNames)
439
440
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
448
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
454
455
456contentToErrorType :: Variable -> Content -> StateT NameState IO ET.Type
457contentToErrorType variable content =
458  case content of
459    Structure term ->
460        termToErrorType term
461
462    FlexVar maybeName ->
463      case maybeName of
464        Just name ->
465          return (ET.FlexVar name)
466
467        Nothing ->
468          do  name <- getFreshVarName
469              liftIO $ UF.modify variable (\desc -> desc { _content = FlexVar (Just name) })
470              return (ET.FlexVar name)
471
472    FlexSuper super maybeName ->
473      case maybeName of
474        Just name ->
475          return (ET.FlexSuper (superToSuper super) name)
476
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)
481
482    RigidVar name ->
483        return (ET.RigidVar name)
484
485    RigidSuper super name ->
486        return (ET.RigidSuper (superToSuper super) name)
487
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)
492
493    Error ->
494        return ET.Error
495
496
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
504
505
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
511
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)
519
520              _ ->
521                ET.Lambda arg result []
522
523    EmptyRecord1 ->
524      return $ ET.Record Map.empty ET.Closed
525
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
533
534                ET.FlexVar ext ->
535                    ET.Record errFields (ET.FlexOpen ext)
536
537                ET.RigidVar ext ->
538                    ET.Record errFields (ET.RigidOpen ext)
539
540                _ ->
541                    error "Used toErrorType on a type that is not well-formed"
542
543    Unit1 ->
544      return ET.Unit
545
546    Tuple1 a b maybeC ->
547      ET.Tuple
548        <$> variableToErrorType a
549        <*> variableToErrorType b
550        <*> traverse variableToErrorType maybeC
551
552
553
554-- MANAGE FRESH VARIABLE NAMES
555
556
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    }
566
567
568makeNameState :: Map.Map Name.Name Variable -> NameState
569makeNameState taken =
570  NameState (Map.map (const ()) taken) 0 0 0 0 0
571
572
573
574-- FRESH VAR NAMES
575
576
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
584
585
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 )
596
597
598
599-- FRESH SUPER NAMES
600
601
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 })
607
608    Comparable ->
609      getFreshSuper "comparable" _comparables (\index state -> state { _comparables = index })
610
611    Appendable ->
612      getFreshSuper "appendable" _appendables (\index state -> state { _appendables = index })
613
614    CompAppend ->
615      getFreshSuper "compappend" _compAppends (\index state -> state { _compAppends = index })
616
617
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
625
626
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
635
636    else
637      ( name, index + 1, Map.insert name () taken )
638
639
640
641-- GET ALL VARIABLE NAMES
642
643
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
654
655              FlexVar maybeName ->
656                case maybeName of
657                  Nothing ->
658                    return takenNames
659
660                  Just name ->
661                    addName 0 name var (FlexVar . Just) takenNames
662
663              FlexSuper super maybeName ->
664                case maybeName of
665                  Nothing ->
666                    return takenNames
667
668                  Just name ->
669                    addName 0 name var (FlexSuper super . Just) takenNames
670
671              RigidVar name ->
672                addName 0 name var RigidVar takenNames
673
674              RigidSuper super name ->
675                addName 0 name var (RigidSuper super) takenNames
676
677              Alias _ _ args _ ->
678                foldrM getVarNames takenNames (map snd args)
679
680              Structure flatType ->
681                case flatType of
682                  App1 _ _ args ->
683                    foldrM getVarNames takenNames args
684
685                  Fun1 arg body ->
686                    getVarNames arg =<< getVarNames body takenNames
687
688                  EmptyRecord1 ->
689                    return takenNames
690
691                  Record1 fields extension ->
692                    getVarNames extension =<<
693                      foldrM getVarNames takenNames (Map.elems fields)
694
695                  Unit1 ->
696                    return takenNames
697
698                  Tuple1 a b Nothing ->
699                    getVarNames a =<< getVarNames b takenNames
700
701                  Tuple1 a b (Just c) ->
702                    getVarNames a =<< getVarNames b =<< getVarNames c takenNames
703
704
705
706-- REGISTER NAME / RENAME DUPLICATES
707
708
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
721
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
727