git.iko.soy/elk
on dc356df help sign in
elk/src/Type/Type.hs
601 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 qualified Data.Char as Char
33import Data.Foldable (foldrM)
34import qualified Data.Map.Strict as Map
35import qualified Data.Text as Text
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 Type.UnionFind as UF
46-- TYPE PRIMITIVES
49type Variable =
50 UF.Point Descriptor
53data FlatType
54 = App1 ModuleName.Canonical N.Name [Variable]
55 | Fun1 Variable Variable
56 | EmptyRecord1
57 | Record1 (Map.Map N.Name Variable) Variable
58 | Unit1
59 | Tuple1 Variable Variable (Maybe Variable)
62data Type
63 = PlaceHolder N.Name
64 | AliasN ModuleName.Canonical N.Name [(N.Name, Type)] Type
65 | VarN Variable
66 | AppN ModuleName.Canonical N.Name [Type]
67 | FunN Type Type
68 | EmptyRecordN
69 | RecordN (Map.Map N.Name Type) Type
70 | UnitN
71 | TupleN Type Type (Maybe Type)
75-- DESCRIPTORS
78data Descriptor =
79 Descriptor
80 { _content :: Content
81 , _rank :: Int
82 , _mark :: Mark
83 , _copy :: Maybe Variable
84 }
87data Content
88 = FlexVar (Maybe N.Name)
89 | FlexSuper SuperType (Maybe N.Name)
90 | RigidVar N.Name
91 | RigidSuper SuperType N.Name
92 | Structure FlatType
93 | Alias ModuleName.Canonical N.Name [(N.Name,Variable)] Variable
94 | Error N.Name
97data SuperType
98 = Number
99 | Comparable
100 | Appendable
101 | CompAppend
102 deriving (Eq)
105makeDescriptor :: Content -> Descriptor
106makeDescriptor content =
107 Descriptor content noRank noMark Nothing
111-- RANKS
114noRank :: Int
115noRank =
116 0
119outermostRank :: Int
120outermostRank =
121 1
125-- MARKS
128newtype Mark = Mark Word32
129 deriving (Eq, Ord)
132noMark :: Mark
133noMark =
134 Mark 2
137occursMark :: Mark
138occursMark =
139 Mark 1
142getVarNamesMark :: Mark
143getVarNamesMark =
144 Mark 0
147{-# INLINE nextMark #-}
148nextMark :: Mark -> Mark
149nextMark (Mark mark) =
150 Mark (mark + 1)
154-- FUNCTION TYPES
157infixr 9 ==>
160{-# INLINE (==>) #-}
161(==>) :: Type -> Type -> Type
162(==>) =
163 FunN
167-- PRIMITIVE TYPES
170{-# NOINLINE int #-}
171int :: Type
172int = AppN ModuleName.basics "Int" []
175{-# NOINLINE float #-}
176float :: Type
177float = AppN ModuleName.basics "Float" []
180{-# NOINLINE char #-}
181char :: Type
182char = AppN ModuleName.char "Char" []
185{-# NOINLINE string #-}
186string :: Type
187string = AppN ModuleName.string "String" []
190{-# NOINLINE bool #-}
191bool :: Type
192bool = AppN ModuleName.basics "Bool" []
195{-# NOINLINE never #-}
196never :: Type
197never = AppN ModuleName.basics "Never" []
201-- WEBGL TYPES
204{-# NOINLINE vec2 #-}
205vec2 :: Type
206vec2 = AppN ModuleName.vector2 "Vec2" []
209{-# NOINLINE vec3 #-}
210vec3 :: Type
211vec3 = AppN ModuleName.vector3 "Vec3" []
214{-# NOINLINE vec4 #-}
215vec4 :: Type
216vec4 = AppN ModuleName.vector4 "Vec4" []
219{-# NOINLINE mat4 #-}
220mat4 :: Type
221mat4 = AppN ModuleName.matrix4 "Mat4" []
224{-# NOINLINE texture #-}
225texture :: Type
226texture = AppN ModuleName.webgl "Texture" []
230-- MAKE FLEX VARIABLES
233mkFlexVar :: IO Variable
234mkFlexVar =
235 UF.fresh flexVarDescriptor
238{-# NOINLINE flexVarDescriptor #-}
239flexVarDescriptor :: Descriptor
240flexVarDescriptor =
241 makeDescriptor unnamedFlexVar
244{-# NOINLINE unnamedFlexVar #-}
245unnamedFlexVar :: Content
246unnamedFlexVar =
247 FlexVar Nothing
251-- MAKE FLEX NUMBERS
254mkFlexNumber :: IO Variable
255mkFlexNumber =
256 UF.fresh flexNumberDescriptor
259{-# NOINLINE flexNumberDescriptor #-}
260flexNumberDescriptor :: Descriptor
261flexNumberDescriptor =
262 makeDescriptor (unnamedFlexSuper Number)
265unnamedFlexSuper :: SuperType -> Content
266unnamedFlexSuper super =
267 FlexSuper super Nothing
271-- MAKE NAMED VARIABLES
274nameToFlex :: N.Name -> IO Variable
275nameToFlex name =
276 UF.fresh $ makeDescriptor $
277 maybe FlexVar FlexSuper (toSuper name) (Just name)
280nameToRigid :: N.Name -> IO Variable
281nameToRigid name =
282 UF.fresh $ makeDescriptor $
283 maybe RigidVar RigidSuper (toSuper name) name
286toSuper :: N.Name -> Maybe SuperType
287toSuper name =
288 if N.startsWith "number" name then
289 Just Number
291 else if N.startsWith "comparable" name then
292 Just Comparable
294 else if N.startsWith "appendable" name then
295 Just Appendable
297 else if N.startsWith "compappend" name then
298 Just CompAppend
300 else
301 Nothing
305-- TO SOURCE TYPES
308-- TODO: Attach resulting type to the descriptor so that you
309-- never have to do extra work, particularly nice for aliased types
310toAnnotation :: Variable -> IO Can.Annotation
311toAnnotation variable =
312 do userNames <- getVarNames variable Map.empty
313 (tipe, NameState allNames _ _ _ _ _) <-
314 State.runStateT (variableToSrcType variable) (makeNameState userNames)
315 return $ Can.Forall (Map.map (\_ -> ()) allNames) tipe
318toSrcType :: Variable -> IO Can.Type
319toSrcType variable =
320 do userNames <- getVarNames variable Map.empty
321 State.evalStateT (variableToSrcType variable) (makeNameState userNames)
324variableToSrcType :: Variable -> StateT NameState IO Can.Type
325variableToSrcType variable =
326 do descriptor <- liftIO $ UF.get variable
327 let mark = _mark descriptor
328 if mark == occursMark
329 then
330 return (Can.TVar "∞")
332 else
333 do liftIO $ UF.modify variable (\desc -> desc { _mark = occursMark })
334 srcType <- contentToSrcType variable (_content descriptor)
335 liftIO $ UF.modify variable (\desc -> desc { _mark = mark })
336 return srcType
339contentToSrcType :: Variable -> Content -> StateT NameState IO Can.Type
340contentToSrcType variable content =
341 case content of
342 Structure term ->
343 termToSrcType term
345 FlexVar maybeName ->
346 case maybeName of
347 Just name ->
348 return (Can.TVar name)
350 Nothing ->
351 do name <- getFreshVarName
352 liftIO $ UF.modify variable (\desc -> desc { _content = FlexVar (Just name) })
353 return (Can.TVar name)
355 FlexSuper super maybeName ->
356 case maybeName of
357 Just name ->
358 return (Can.TVar name)
360 Nothing ->
361 do name <- getFreshSuperName super
362 liftIO $ UF.modify variable (\desc -> desc { _content = FlexSuper super (Just name) })
363 return (Can.TVar name)
365 RigidVar name ->
366 return (Can.TVar name)
368 RigidSuper _ name ->
369 return (Can.TVar name)
371 Alias home name args realVariable ->
372 do srcArgs <- traverse (traverse variableToSrcType) args
373 srcType <- variableToSrcType realVariable
374 return (Can.TAlias home name srcArgs (Can.Filled srcType))
376 Error name ->
377 return (Can.TVar name)
380termToSrcType :: FlatType -> StateT NameState IO Can.Type
381termToSrcType term =
382 case term of
383 App1 home name args ->
384 Can.TType home name <$> traverse variableToSrcType args
386 Fun1 a b ->
387 Can.TLambda
388 <$> variableToSrcType a
389 <*> variableToSrcType b
391 EmptyRecord1 ->
392 return $ Can.TRecord Map.empty Nothing
394 Record1 fields extension ->
395 do srcFields <- traverse variableToSrcType fields
396 srcExt <- Type.iteratedDealias <$> variableToSrcType extension
397 return $
398 case srcExt of
399 Can.TRecord subFields subExt ->
400 Can.TRecord (Map.union subFields srcFields) subExt
402 Can.TVar _ ->
403 Can.TRecord srcFields (Just srcExt)
405 _ ->
406 error "Used toSrcType on a type that is not well-formed"
408 Unit1 ->
409 return Can.TUnit
411 Tuple1 a b maybeC ->
412 Can.TTuple
413 <$> variableToSrcType a
414 <*> variableToSrcType b
415 <*> traverse variableToSrcType maybeC
419-- MANAGE FRESH VARIABLE NAMES
422data NameState =
423 NameState
424 { _taken :: TakenNames
425 , _normals :: Int
426 , _numbers :: Int
427 , _comparables :: Int
428 , _appendables :: Int
429 , _compAppends :: Int
430 }
433type TakenNames = Map.Map N.Name Variable
436makeNameState :: TakenNames -> NameState
437makeNameState taken =
438 NameState taken 0 0 0 0 0
441getFreshVarName :: (Monad m) => StateT NameState m N.Name
442getFreshVarName =
443 do index <- State.gets _normals
444 taken <- State.gets _taken
445 let (uniqueName, newIndex) = getFreshNormal index taken
446 State.modify (\state -> state { _normals = newIndex })
447 return uniqueName
450getFreshSuperName :: (Monad m) => SuperType -> StateT NameState m N.Name
451getFreshSuperName super =
452 case super of
453 Number ->
454 getFreshSuper "number" _numbers (\index state -> state { _numbers = index })
456 Comparable ->
457 getFreshSuper "comparable" _comparables (\index state -> state { _comparables = index })
459 Appendable ->
460 getFreshSuper "appendable" _appendables (\index state -> state { _appendables = index })
462 CompAppend ->
463 getFreshSuper "compappend" _compAppends (\index state -> state { _compAppends = index })
466getFreshNormal :: Int -> TakenNames -> (N.Name, Int)
467getFreshNormal index taken =
468 let
469 (postfix, letter) =
470 quotRem index 26
472 character =
473 Char.chr (97 + letter)
475 name =
476 Text.pack (if postfix <= 0 then [character] else character : show postfix)
477 in
478 if Map.member name taken then
479 getFreshNormal (index + 1) taken
481 else
482 (name, index + 1)
485getFreshSuper
486 :: (Monad m)
487 => N.Name
488 -> (NameState -> Int)
489 -> (Int -> NameState -> NameState)
490 -> StateT NameState m N.Name
491getFreshSuper name getter setter =
492 do index <- State.gets getter
493 taken <- State.gets _taken
494 let (uniqueName, newIndex) = getFreshSuperHelp name index taken
495 State.modify (setter newIndex)
496 return uniqueName
499getFreshSuperHelp :: N.Name -> Int -> TakenNames -> (N.Name, Int)
500getFreshSuperHelp name index taken =
501 let
502 newName =
503 if index <= 0 then name else N.addIndex name index
504 in
505 if Map.member newName taken then
506 getFreshSuperHelp name (index + 1) taken
508 else
509 (newName, index + 1)
513-- GET ALL VARIABLE NAMES
516getVarNames :: Variable -> TakenNames -> IO TakenNames
517getVarNames var takenNames =
518 do (Descriptor content rank mark copy) <- UF.get var
519 if mark == getVarNamesMark
520 then return takenNames
521 else
522 do UF.set var (Descriptor content rank getVarNamesMark copy)
523 case content of
524 Error _ ->
525 return takenNames
527 FlexVar maybeName ->
528 case maybeName of
529 Nothing ->
530 return takenNames
532 Just name ->
533 addName 0 name var (FlexVar . Just) takenNames
535 FlexSuper super maybeName ->
536 case maybeName of
537 Nothing ->
538 return takenNames
540 Just name ->
541 addName 0 name var (FlexSuper super . Just) takenNames
543 RigidVar name ->
544 addName 0 name var RigidVar takenNames
546 RigidSuper super name ->
547 addName 0 name var (RigidSuper super) takenNames
549 Alias _ _ args _ ->
550 foldrM getVarNames takenNames (map snd args)
552 Structure flatType ->
553 case flatType of
554 App1 _ _ args ->
555 foldrM getVarNames takenNames args
557 Fun1 arg body ->
558 getVarNames arg =<< getVarNames body takenNames
560 EmptyRecord1 ->
561 return takenNames
563 Record1 fields extension ->
564 getVarNames extension =<<
565 foldrM getVarNames takenNames (Map.elems fields)
567 Unit1 ->
568 return takenNames
570 Tuple1 a b Nothing ->
571 getVarNames a =<< getVarNames b takenNames
573 Tuple1 a b (Just c) ->
574 getVarNames a =<< getVarNames b =<< getVarNames c takenNames
578-- REGISTER NAME / RENAME DUPLICATES
581addName :: Int -> N.Name -> Variable -> (N.Name -> Content) -> TakenNames -> IO TakenNames
582addName index givenName var makeContent takenNames =
583 let
584 indexedName =
585 if index <= 0 then
586 givenName
587 else
588 N.addSafeIndex givenName index
589 in
590 case Map.lookup indexedName takenNames of
591 Nothing ->
592 do if indexedName == givenName then return () else
593 UF.modify var $ \(Descriptor _ rank mark copy) ->
594 Descriptor (makeContent indexedName) rank mark copy
595 return $ Map.insert indexedName var takenNames
597 Just otherVar ->
598 do same <- UF.equivalent var otherVar
599 if same
600 then return takenNames
601 else addName (index + 1) givenName var makeContent takenNames