git.iko.soy/elk
on 7dfbc30 help sign in
elk/src/Type/Type.hs
605 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 Data.Monoid ((<>))
36import qualified Data.Text as Text
37import Data.Text (Text)
38import Data.Word (Word32)
40import qualified AST.Canonical as Can
41import qualified AST.Module.Name as ModuleName
42import qualified AST.Utils.Type as Type
43import qualified Elm.Name as N
44import qualified Type.UnionFind as UF
48-- TYPE PRIMITIVES
51type Variable =
52 UF.Point Descriptor
55data FlatType
56 = App1 ModuleName.Canonical N.Name [Variable]
57 | Fun1 Variable Variable
58 | EmptyRecord1
59 | Record1 (Map.Map N.Name Variable) Variable
60 | Unit1
61 | Tuple1 Variable Variable (Maybe Variable)
64data Type
65 = PlaceHolder N.Name
66 | AliasN ModuleName.Canonical N.Name [(N.Name, Type)] Type
67 | VarN Variable
68 | AppN ModuleName.Canonical N.Name [Type]
69 | FunN Type Type
70 | EmptyRecordN
71 | RecordN (Map.Map N.Name Type) Type
72 | UnitN
73 | TupleN Type Type (Maybe Type)
77-- DESCRIPTORS
80data Descriptor =
81 Descriptor
82 { _content :: Content
83 , _rank :: Int
84 , _mark :: Mark
85 , _copy :: Maybe Variable
86 }
89data Content
90 = FlexVar (Maybe N.Name)
91 | FlexSuper SuperType (Maybe N.Name)
92 | RigidVar N.Name
93 | RigidSuper SuperType N.Name
94 | Structure FlatType
95 | Alias ModuleName.Canonical N.Name [(N.Name,Variable)] Variable
96 | Error Text
99data SuperType
100 = Number
101 | Comparable
102 | Appendable
103 | CompAppend
104 deriving (Eq)
107makeDescriptor :: Content -> Descriptor
108makeDescriptor content =
109 Descriptor content noRank noMark Nothing
113-- RANKS
116noRank :: Int
117noRank =
118 0
121outermostRank :: Int
122outermostRank =
123 1
127-- MARKS
130newtype Mark = Mark Word32
131 deriving (Eq, Ord)
134noMark :: Mark
135noMark =
136 Mark 2
139occursMark :: Mark
140occursMark =
141 Mark 1
144getVarNamesMark :: Mark
145getVarNamesMark =
146 Mark 0
149{-# INLINE nextMark #-}
150nextMark :: Mark -> Mark
151nextMark (Mark mark) =
152 Mark (mark + 1)
156-- FUNCTION TYPES
159infixr 9 ==>
162{-# INLINE (==>) #-}
163(==>) :: Type -> Type -> Type
164(==>) =
165 FunN
169-- PRIMITIVE TYPES
172{-# NOINLINE int #-}
173int :: Type
174int = AppN ModuleName.basics "Int" []
177{-# NOINLINE float #-}
178float :: Type
179float = AppN ModuleName.basics "Float" []
182{-# NOINLINE char #-}
183char :: Type
184char = AppN ModuleName.char "Char" []
187{-# NOINLINE string #-}
188string :: Type
189string = AppN ModuleName.string "String" []
192{-# NOINLINE bool #-}
193bool :: Type
194bool = AppN ModuleName.basics "Bool" []
197{-# NOINLINE never #-}
198never :: Type
199never = AppN ModuleName.basics "Never" []
203-- WEBGL TYPES
206{-# NOINLINE vec2 #-}
207vec2 :: Type
208vec2 = AppN ModuleName.vector2 "Vec2" []
211{-# NOINLINE vec3 #-}
212vec3 :: Type
213vec3 = AppN ModuleName.vector3 "Vec3" []
216{-# NOINLINE vec4 #-}
217vec4 :: Type
218vec4 = AppN ModuleName.vector4 "Vec4" []
221{-# NOINLINE mat4 #-}
222mat4 :: Type
223mat4 = AppN ModuleName.matrix4 "Mat4" []
226{-# NOINLINE texture #-}
227texture :: Type
228texture = AppN ModuleName.webgl "Texture" []
232-- MAKE FLEX VARIABLES
235mkFlexVar :: IO Variable
236mkFlexVar =
237 UF.fresh flexVarDescriptor
240{-# NOINLINE flexVarDescriptor #-}
241flexVarDescriptor :: Descriptor
242flexVarDescriptor =
243 makeDescriptor unnamedFlexVar
246{-# NOINLINE unnamedFlexVar #-}
247unnamedFlexVar :: Content
248unnamedFlexVar =
249 FlexVar Nothing
253-- MAKE FLEX NUMBERS
256mkFlexNumber :: IO Variable
257mkFlexNumber =
258 UF.fresh flexNumberDescriptor
261{-# NOINLINE flexNumberDescriptor #-}
262flexNumberDescriptor :: Descriptor
263flexNumberDescriptor =
264 makeDescriptor (unnamedFlexSuper Number)
267unnamedFlexSuper :: SuperType -> Content
268unnamedFlexSuper super =
269 FlexSuper super Nothing
273-- MAKE NAMED VARIABLES
276nameToFlex :: N.Name -> IO Variable
277nameToFlex name =
278 UF.fresh $ makeDescriptor $
279 maybe FlexVar FlexSuper (toSuper name) (Just name)
282nameToRigid :: N.Name -> IO Variable
283nameToRigid name =
284 UF.fresh $ makeDescriptor $
285 maybe RigidVar RigidSuper (toSuper name) name
288toSuper :: N.Name -> Maybe SuperType
289toSuper name =
290 if Text.isPrefixOf "number" name then
291 Just Number
293 else if Text.isPrefixOf "comparable" name then
294 Just Comparable
296 else if Text.isPrefixOf "appendable" name then
297 Just Appendable
299 else if Text.isPrefixOf "compappend" name then
300 Just CompAppend
302 else
303 Nothing
307-- TO SOURCE TYPES
310-- TODO: Attach resulting type to the descriptor so that you
311-- never have to do extra work, particularly nice for aliased types
312toAnnotation :: Variable -> IO Can.Annotation
313toAnnotation variable =
314 do userNames <- getVarNames variable Map.empty
315 (tipe, NameState allNames _ _ _ _ _) <-
316 State.runStateT (variableToSrcType variable) (makeNameState userNames)
317 return $ Can.Forall (Map.map (\_ -> ()) allNames) tipe
320toSrcType :: Variable -> IO Can.Type
321toSrcType variable =
322 do userNames <- getVarNames variable Map.empty
323 State.evalStateT (variableToSrcType variable) (makeNameState userNames)
326variableToSrcType :: Variable -> StateT NameState IO Can.Type
327variableToSrcType variable =
328 do descriptor <- liftIO $ UF.get variable
329 let mark = _mark descriptor
330 if mark == occursMark
331 then
332 return (Can.TVar "∞")
334 else
335 do liftIO $ UF.modify variable (\desc -> desc { _mark = occursMark })
336 srcType <- contentToSrcType variable (_content descriptor)
337 liftIO $ UF.modify variable (\desc -> desc { _mark = mark })
338 return srcType
341contentToSrcType :: Variable -> Content -> StateT NameState IO Can.Type
342contentToSrcType variable content =
343 case content of
344 Structure term ->
345 termToSrcType term
347 FlexVar maybeName ->
348 case maybeName of
349 Just name ->
350 return (Can.TVar name)
352 Nothing ->
353 do name <- getFreshVarName
354 liftIO $ UF.modify variable (\desc -> desc { _content = FlexVar (Just name) })
355 return (Can.TVar name)
357 FlexSuper super maybeName ->
358 case maybeName of
359 Just name ->
360 return (Can.TVar name)
362 Nothing ->
363 do name <- getFreshSuperName super
364 liftIO $ UF.modify variable (\desc -> desc { _content = FlexSuper super (Just name) })
365 return (Can.TVar name)
367 RigidVar name ->
368 return (Can.TVar name)
370 RigidSuper _ name ->
371 return (Can.TVar name)
373 Alias home name args realVariable ->
374 do srcArgs <- traverse (traverse variableToSrcType) args
375 srcType <- variableToSrcType realVariable
376 return (Can.TAlias home name srcArgs (Can.Filled srcType))
378 Error name ->
379 return (Can.TVar name)
382termToSrcType :: FlatType -> StateT NameState IO Can.Type
383termToSrcType term =
384 case term of
385 App1 home name args ->
386 Can.TType home name <$> traverse variableToSrcType args
388 Fun1 a b ->
389 Can.TLambda
390 <$> variableToSrcType a
391 <*> variableToSrcType b
393 EmptyRecord1 ->
394 return $ Can.TRecord Map.empty Nothing
396 Record1 fields extension ->
397 do srcFields <- traverse variableToSrcType fields
398 srcExt <- Type.iteratedDealias <$> variableToSrcType extension
399 return $
400 case srcExt of
401 Can.TRecord subFields subExt ->
402 Can.TRecord (Map.union subFields srcFields) subExt
404 Can.TVar _ ->
405 Can.TRecord srcFields (Just srcExt)
407 _ ->
408 error "Used toSrcType on a type that is not well-formed"
410 Unit1 ->
411 return Can.TUnit
413 Tuple1 a b maybeC ->
414 Can.TTuple
415 <$> variableToSrcType a
416 <*> variableToSrcType b
417 <*> traverse variableToSrcType maybeC
421-- MANAGE FRESH VARIABLE NAMES
424data NameState =
425 NameState
426 { _taken :: TakenNames
427 , _normals :: Int
428 , _numbers :: Int
429 , _comparables :: Int
430 , _appendables :: Int
431 , _compAppends :: Int
432 }
435type TakenNames = Map.Map N.Name Variable
438makeNameState :: TakenNames -> NameState
439makeNameState taken =
440 NameState taken 0 0 0 0 0
443getFreshVarName :: (Monad m) => StateT NameState m N.Name
444getFreshVarName =
445 do index <- State.gets _normals
446 taken <- State.gets _taken
447 let (uniqueName, newIndex) = getFreshNormal index taken
448 State.modify (\state -> state { _normals = newIndex })
449 return uniqueName
452getFreshSuperName :: (Monad m) => SuperType -> StateT NameState m N.Name
453getFreshSuperName super =
454 case super of
455 Number ->
456 getFreshSuper "number" _numbers (\index state -> state { _numbers = index })
458 Comparable ->
459 getFreshSuper "comparable" _comparables (\index state -> state { _comparables = index })
461 Appendable ->
462 getFreshSuper "appendable" _appendables (\index state -> state { _appendables = index })
464 CompAppend ->
465 getFreshSuper "compappend" _compAppends (\index state -> state { _compAppends = index })
468getFreshNormal :: Int -> TakenNames -> (N.Name, Int)
469getFreshNormal index taken =
470 let
471 (postfix, letter) =
472 quotRem index 26
474 character =
475 Char.chr (97 + letter)
477 name =
478 Text.pack (if postfix <= 0 then [character] else character : show postfix)
479 in
480 if Map.member name taken then
481 getFreshNormal (index + 1) taken
483 else
484 (name, index + 1)
487getFreshSuper
488 :: (Monad m)
489 => N.Name
490 -> (NameState -> Int)
491 -> (Int -> NameState -> NameState)
492 -> StateT NameState m N.Name
493getFreshSuper name getter setter =
494 do index <- State.gets getter
495 taken <- State.gets _taken
496 let (uniqueName, newIndex) = getFreshSuperHelp name index taken
497 State.modify (setter newIndex)
498 return uniqueName
501getFreshSuperHelp :: N.Name -> Int -> TakenNames -> (N.Name, Int)
502getFreshSuperHelp name index taken =
503 let
504 newName =
505 if index <= 0 then name else name <> Text.pack (show index)
506 in
507 if Map.member newName taken then
508 getFreshSuperHelp name (index + 1) taken
510 else
511 (newName, index + 1)
515-- GET ALL VARIABLE NAMES
518getVarNames :: Variable -> TakenNames -> IO TakenNames
519getVarNames var takenNames =
520 do (Descriptor content rank mark copy) <- UF.get var
521 if mark == getVarNamesMark
522 then return takenNames
523 else
524 do UF.set var (Descriptor content rank getVarNamesMark copy)
525 case content of
526 Error _ ->
527 return takenNames
529 FlexVar maybeName ->
530 case maybeName of
531 Nothing ->
532 return takenNames
534 Just name ->
535 addName 0 name var (FlexVar . Just) takenNames
537 FlexSuper super maybeName ->
538 case maybeName of
539 Nothing ->
540 return takenNames
542 Just name ->
543 addName 0 name var (FlexSuper super . Just) takenNames
545 RigidVar name ->
546 addName 0 name var RigidVar takenNames
548 RigidSuper super name ->
549 addName 0 name var (RigidSuper super) takenNames
551 Alias _ _ args _ ->
552 foldrM getVarNames takenNames (map snd args)
554 Structure flatType ->
555 case flatType of
556 App1 _ _ args ->
557 foldrM getVarNames takenNames args
559 Fun1 arg body ->
560 getVarNames arg =<< getVarNames body takenNames
562 EmptyRecord1 ->
563 return takenNames
565 Record1 fields extension ->
566 getVarNames extension =<<
567 foldrM getVarNames takenNames (Map.elems fields)
569 Unit1 ->
570 return takenNames
572 Tuple1 a b Nothing ->
573 getVarNames a =<< getVarNames b takenNames
575 Tuple1 a b (Just c) ->
576 getVarNames a =<< getVarNames b =<< getVarNames c takenNames
580-- REGISTER NAME / RENAME DUPLICATES
583addName :: Int -> N.Name -> Variable -> (N.Name -> Content) -> TakenNames -> IO TakenNames
584addName index givenName var makeContent takenNames =
585 let
586 indexedName =
587 if index <= 0 then
588 givenName
589 else if Char.isDigit (Text.last givenName) then
590 givenName <> Text.pack ('_' : show index)
591 else
592 givenName <> Text.pack (show index)
593 in
594 case Map.lookup indexedName takenNames of
595 Nothing ->
596 do if indexedName == givenName then return () else
597 UF.modify var $ \(Descriptor _ rank mark copy) ->
598 Descriptor (makeContent indexedName) rank mark copy
599 return $ Map.insert indexedName var takenNames
601 Just otherVar ->
602 do same <- UF.equivalent var otherVar
603 if same
604 then return takenNames
605 else addName (index + 1) givenName var makeContent takenNames