git.iko.soy/elk
on 42e0884 help sign in
elk/src/Type/Type.hs
596 lines 13 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Type.Type
4 ( Variable
5 , FlatType(..)
6 , Type(..)
7 , Descriptor(Descriptor)
8 , Content(..)
9 , SuperType(..)
10 , noRank
11 , outermostRank
12 , Mark
13 , noMark
14 , nextMark
15 , (==>)
16 , int, float, char, string, bool, never
17 , vec2, vec3, vec4, mat4, texture
18 , mkFlexVar
19 , mkFlexNumber
20 , unnamedFlexVar
21 , unnamedFlexSuper
22 , nameToFlex
23 , nameToRigid
24 , toSrcType
25 , toAnnotation
26 )
27 where
30import Control.Monad.State.Strict (StateT, liftIO)
31import qualified Control.Monad.State.Strict as State
32import Data.Foldable (foldrM)
33import qualified Data.Map.Strict as Map
34import Data.Word (Word32)
36import qualified AST.Canonical as Can
37import qualified AST.Module.Name as ModuleName
38import qualified AST.Utils.Type as Type
39import qualified Elm.Name as N
40import qualified Type.UnionFind as UF
44-- TYPE PRIMITIVES
47type Variable =
48 UF.Point Descriptor
51data FlatType
52 = App1 ModuleName.Canonical N.Name [Variable]
53 | Fun1 Variable Variable
54 | EmptyRecord1
55 | Record1 (Map.Map N.Name Variable) Variable
56 | Unit1
57 | Tuple1 Variable Variable (Maybe Variable)
60data Type
61 = PlaceHolder N.Name
62 | AliasN ModuleName.Canonical N.Name [(N.Name, Type)] Type
63 | VarN Variable
64 | AppN ModuleName.Canonical N.Name [Type]
65 | FunN Type Type
66 | EmptyRecordN
67 | RecordN (Map.Map N.Name Type) Type
68 | UnitN
69 | TupleN Type Type (Maybe Type)
73-- DESCRIPTORS
76data Descriptor =
77 Descriptor
78 { _content :: Content
79 , _rank :: Int
80 , _mark :: Mark
81 , _copy :: Maybe Variable
82 }
85data Content
86 = FlexVar (Maybe N.Name)
87 | FlexSuper SuperType (Maybe N.Name)
88 | RigidVar N.Name
89 | RigidSuper SuperType N.Name
90 | Structure FlatType
91 | Alias ModuleName.Canonical N.Name [(N.Name,Variable)] Variable
92 | Error N.Name
95data SuperType
96 = Number
97 | Comparable
98 | Appendable
99 | CompAppend
100 deriving (Eq)
103makeDescriptor :: Content -> Descriptor
104makeDescriptor content =
105 Descriptor content noRank noMark Nothing
109-- RANKS
112noRank :: Int
113noRank =
114 0
117outermostRank :: Int
118outermostRank =
119 1
123-- MARKS
126newtype Mark = Mark Word32
127 deriving (Eq, Ord)
130noMark :: Mark
131noMark =
132 Mark 2
135occursMark :: Mark
136occursMark =
137 Mark 1
140getVarNamesMark :: Mark
141getVarNamesMark =
142 Mark 0
145{-# INLINE nextMark #-}
146nextMark :: Mark -> Mark
147nextMark (Mark mark) =
148 Mark (mark + 1)
152-- FUNCTION TYPES
155infixr 9 ==>
158{-# INLINE (==>) #-}
159(==>) :: Type -> Type -> Type
160(==>) =
161 FunN
165-- PRIMITIVE TYPES
168{-# NOINLINE int #-}
169int :: Type
170int = AppN ModuleName.basics "Int" []
173{-# NOINLINE float #-}
174float :: Type
175float = AppN ModuleName.basics "Float" []
178{-# NOINLINE char #-}
179char :: Type
180char = AppN ModuleName.char "Char" []
183{-# NOINLINE string #-}
184string :: Type
185string = AppN ModuleName.string "String" []
188{-# NOINLINE bool #-}
189bool :: Type
190bool = AppN ModuleName.basics "Bool" []
193{-# NOINLINE never #-}
194never :: Type
195never = AppN ModuleName.basics "Never" []
199-- WEBGL TYPES
202{-# NOINLINE vec2 #-}
203vec2 :: Type
204vec2 = AppN ModuleName.vector2 "Vec2" []
207{-# NOINLINE vec3 #-}
208vec3 :: Type
209vec3 = AppN ModuleName.vector3 "Vec3" []
212{-# NOINLINE vec4 #-}
213vec4 :: Type
214vec4 = AppN ModuleName.vector4 "Vec4" []
217{-# NOINLINE mat4 #-}
218mat4 :: Type
219mat4 = AppN ModuleName.matrix4 "Mat4" []
222{-# NOINLINE texture #-}
223texture :: Type
224texture = AppN ModuleName.webgl "Texture" []
228-- MAKE FLEX VARIABLES
231mkFlexVar :: IO Variable
232mkFlexVar =
233 UF.fresh flexVarDescriptor
236{-# NOINLINE flexVarDescriptor #-}
237flexVarDescriptor :: Descriptor
238flexVarDescriptor =
239 makeDescriptor unnamedFlexVar
242{-# NOINLINE unnamedFlexVar #-}
243unnamedFlexVar :: Content
244unnamedFlexVar =
245 FlexVar Nothing
249-- MAKE FLEX NUMBERS
252mkFlexNumber :: IO Variable
253mkFlexNumber =
254 UF.fresh flexNumberDescriptor
257{-# NOINLINE flexNumberDescriptor #-}
258flexNumberDescriptor :: Descriptor
259flexNumberDescriptor =
260 makeDescriptor (unnamedFlexSuper Number)
263unnamedFlexSuper :: SuperType -> Content
264unnamedFlexSuper super =
265 FlexSuper super Nothing
269-- MAKE NAMED VARIABLES
272nameToFlex :: N.Name -> IO Variable
273nameToFlex name =
274 UF.fresh $ makeDescriptor $
275 maybe FlexVar FlexSuper (toSuper name) (Just name)
278nameToRigid :: N.Name -> IO Variable
279nameToRigid name =
280 UF.fresh $ makeDescriptor $
281 maybe RigidVar RigidSuper (toSuper name) name
284toSuper :: N.Name -> Maybe SuperType
285toSuper name =
286 if N.startsWith "number" name then
287 Just Number
289 else if N.startsWith "comparable" name then
290 Just Comparable
292 else if N.startsWith "appendable" name then
293 Just Appendable
295 else if N.startsWith "compappend" name then
296 Just CompAppend
298 else
299 Nothing
303-- TO SOURCE TYPES
306-- TODO: Attach resulting type to the descriptor so that you
307-- never have to do extra work, particularly nice for aliased types
308toAnnotation :: Variable -> IO Can.Annotation
309toAnnotation variable =
310 do userNames <- getVarNames variable Map.empty
311 (tipe, NameState allNames _ _ _ _ _) <-
312 State.runStateT (variableToSrcType variable) (makeNameState userNames)
313 return $ Can.Forall (Map.map (\_ -> ()) allNames) tipe
316toSrcType :: Variable -> IO Can.Type
317toSrcType variable =
318 do userNames <- getVarNames variable Map.empty
319 State.evalStateT (variableToSrcType variable) (makeNameState userNames)
322variableToSrcType :: Variable -> StateT NameState IO Can.Type
323variableToSrcType variable =
324 do descriptor <- liftIO $ UF.get variable
325 let mark = _mark descriptor
326 if mark == occursMark
327 then
328 return (Can.TVar "∞")
330 else
331 do liftIO $ UF.modify variable (\desc -> desc { _mark = occursMark })
332 srcType <- contentToSrcType variable (_content descriptor)
333 liftIO $ UF.modify variable (\desc -> desc { _mark = mark })
334 return srcType
337contentToSrcType :: Variable -> Content -> StateT NameState IO Can.Type
338contentToSrcType variable content =
339 case content of
340 Structure term ->
341 termToSrcType term
343 FlexVar maybeName ->
344 case maybeName of
345 Just name ->
346 return (Can.TVar name)
348 Nothing ->
349 do name <- getFreshVarName
350 liftIO $ UF.modify variable (\desc -> desc { _content = FlexVar (Just name) })
351 return (Can.TVar name)
353 FlexSuper super maybeName ->
354 case maybeName of
355 Just name ->
356 return (Can.TVar name)
358 Nothing ->
359 do name <- getFreshSuperName super
360 liftIO $ UF.modify variable (\desc -> desc { _content = FlexSuper super (Just name) })
361 return (Can.TVar name)
363 RigidVar name ->
364 return (Can.TVar name)
366 RigidSuper _ name ->
367 return (Can.TVar name)
369 Alias home name args realVariable ->
370 do srcArgs <- traverse (traverse variableToSrcType) args
371 srcType <- variableToSrcType realVariable
372 return (Can.TAlias home name srcArgs (Can.Filled srcType))
374 Error name ->
375 return (Can.TVar name)
378termToSrcType :: FlatType -> StateT NameState IO Can.Type
379termToSrcType term =
380 case term of
381 App1 home name args ->
382 Can.TType home name <$> traverse variableToSrcType args
384 Fun1 a b ->
385 Can.TLambda
386 <$> variableToSrcType a
387 <*> variableToSrcType b
389 EmptyRecord1 ->
390 return $ Can.TRecord Map.empty Nothing
392 Record1 fields extension ->
393 do srcFields <- traverse variableToSrcType fields
394 srcExt <- Type.iteratedDealias <$> variableToSrcType extension
395 return $
396 case srcExt of
397 Can.TRecord subFields subExt ->
398 Can.TRecord (Map.union subFields srcFields) subExt
400 Can.TVar _ ->
401 Can.TRecord srcFields (Just srcExt)
403 _ ->
404 error "Used toSrcType on a type that is not well-formed"
406 Unit1 ->
407 return Can.TUnit
409 Tuple1 a b maybeC ->
410 Can.TTuple
411 <$> variableToSrcType a
412 <*> variableToSrcType b
413 <*> traverse variableToSrcType maybeC
417-- MANAGE FRESH VARIABLE NAMES
420data NameState =
421 NameState
422 { _taken :: TakenNames
423 , _normals :: Int
424 , _numbers :: Int
425 , _comparables :: Int
426 , _appendables :: Int
427 , _compAppends :: Int
428 }
431type TakenNames = Map.Map N.Name Variable
434makeNameState :: TakenNames -> NameState
435makeNameState taken =
436 NameState taken 0 0 0 0 0
439getFreshVarName :: (Monad m) => StateT NameState m N.Name
440getFreshVarName =
441 do index <- State.gets _normals
442 taken <- State.gets _taken
443 let (uniqueName, newIndex) = getFreshNormal index taken
444 State.modify (\state -> state { _normals = newIndex })
445 return uniqueName
448getFreshSuperName :: (Monad m) => SuperType -> StateT NameState m N.Name
449getFreshSuperName super =
450 case super of
451 Number ->
452 getFreshSuper "number" _numbers (\index state -> state { _numbers = index })
454 Comparable ->
455 getFreshSuper "comparable" _comparables (\index state -> state { _comparables = index })
457 Appendable ->
458 getFreshSuper "appendable" _appendables (\index state -> state { _appendables = index })
460 CompAppend ->
461 getFreshSuper "compappend" _compAppends (\index state -> state { _compAppends = index })
464getFreshNormal :: Int -> TakenNames -> (N.Name, Int)
465getFreshNormal index taken =
466 let
467 (postfix, letter) =
468 quotRem index 26
470 chr = N.fromLetter letter
471 name = if postfix <= 0 then chr else N.addIndex chr postfix
472 in
473 if Map.member name taken then
474 getFreshNormal (index + 1) taken
476 else
477 (name, index + 1)
480getFreshSuper
481 :: (Monad m)
482 => N.Name
483 -> (NameState -> Int)
484 -> (Int -> NameState -> NameState)
485 -> StateT NameState m N.Name
486getFreshSuper name getter setter =
487 do index <- State.gets getter
488 taken <- State.gets _taken
489 let (uniqueName, newIndex) = getFreshSuperHelp name index taken
490 State.modify (setter newIndex)
491 return uniqueName
494getFreshSuperHelp :: N.Name -> Int -> TakenNames -> (N.Name, Int)
495getFreshSuperHelp name index taken =
496 let
497 newName =
498 if index <= 0 then name else N.addIndex name index
499 in
500 if Map.member newName taken then
501 getFreshSuperHelp name (index + 1) taken
503 else
504 (newName, index + 1)
508-- GET ALL VARIABLE NAMES
511getVarNames :: Variable -> TakenNames -> IO TakenNames
512getVarNames var takenNames =
513 do (Descriptor content rank mark copy) <- UF.get var
514 if mark == getVarNamesMark
515 then return takenNames
516 else
517 do UF.set var (Descriptor content rank getVarNamesMark copy)
518 case content of
519 Error _ ->
520 return takenNames
522 FlexVar maybeName ->
523 case maybeName of
524 Nothing ->
525 return takenNames
527 Just name ->
528 addName 0 name var (FlexVar . Just) takenNames
530 FlexSuper super maybeName ->
531 case maybeName of
532 Nothing ->
533 return takenNames
535 Just name ->
536 addName 0 name var (FlexSuper super . Just) takenNames
538 RigidVar name ->
539 addName 0 name var RigidVar takenNames
541 RigidSuper super name ->
542 addName 0 name var (RigidSuper super) takenNames
544 Alias _ _ args _ ->
545 foldrM getVarNames takenNames (map snd args)
547 Structure flatType ->
548 case flatType of
549 App1 _ _ args ->
550 foldrM getVarNames takenNames args
552 Fun1 arg body ->
553 getVarNames arg =<< getVarNames body takenNames
555 EmptyRecord1 ->
556 return takenNames
558 Record1 fields extension ->
559 getVarNames extension =<<
560 foldrM getVarNames takenNames (Map.elems fields)
562 Unit1 ->
563 return takenNames
565 Tuple1 a b Nothing ->
566 getVarNames a =<< getVarNames b takenNames
568 Tuple1 a b (Just c) ->
569 getVarNames a =<< getVarNames b =<< getVarNames c takenNames
573-- REGISTER NAME / RENAME DUPLICATES
576addName :: Int -> N.Name -> Variable -> (N.Name -> Content) -> TakenNames -> IO TakenNames
577addName index givenName var makeContent takenNames =
578 let
579 indexedName =
580 if index <= 0 then
581 givenName
582 else
583 N.addSafeIndex givenName index
584 in
585 case Map.lookup indexedName takenNames of
586 Nothing ->
587 do if indexedName == givenName then return () else
588 UF.modify var $ \(Descriptor _ rank mark copy) ->
589 Descriptor (makeContent indexedName) rank mark copy
590 return $ Map.insert indexedName var takenNames
592 Just otherVar ->
593 do same <- UF.equivalent var otherVar
594 if same
595 then return takenNames
596 else addName (index + 1) givenName var makeContent takenNames