git.iko.soy/elk
on d3fa290 help sign in
elk/src/Type/Type.hs
591 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
17 , vec2, vec3, vec4, mat4, texture
18 , mkFlexVar
19 , mkFlexNumber
20 , unnamedFlexVar
21 , unnamedFlexSuper
22 , nameToFlex
23 , nameToRigid
24 , toSrcType
25 )
26 where
29import Control.Monad.State.Strict (StateT, liftIO)
30import qualified Control.Monad.State.Strict as State
31import qualified Data.Char as Char
32import Data.Foldable (foldrM)
33import qualified Data.Map.Strict as Map
34import Data.Monoid ((<>))
35import qualified Data.Text as Text
36import Data.Text (Text)
37import Data.Word (Word32)
39import qualified AST.Canonical as Can
40import qualified AST.Module.Name as ModuleName
41import qualified AST.Utils.Type as Type
42import qualified Elm.Name as N
43import qualified Type.UnionFind as UF
47-- TYPE PRIMITIVES
50type Variable =
51 UF.Point Descriptor
54data FlatType
55 = App1 ModuleName.Canonical N.Name [Variable]
56 | Fun1 Variable Variable
57 | EmptyRecord1
58 | Record1 (Map.Map N.Name Variable) Variable
59 | Unit1
60 | Tuple1 Variable Variable (Maybe Variable)
63data Type
64 = PlaceHolder N.Name
65 | AliasN ModuleName.Canonical N.Name [(N.Name, Type)] Type
66 | VarN Variable
67 | AppN ModuleName.Canonical N.Name [Type]
68 | FunN Type Type
69 | EmptyRecordN
70 | RecordN (Map.Map N.Name Type) Type
71 | UnitN
72 | TupleN Type Type (Maybe Type)
76-- DESCRIPTORS
79data Descriptor =
80 Descriptor
81 { _content :: Content
82 , _rank :: Int
83 , _mark :: Mark
84 , _copy :: Maybe Variable
85 }
88data Content
89 = FlexVar (Maybe N.Name)
90 | FlexSuper SuperType (Maybe N.Name)
91 | RigidVar N.Name
92 | RigidSuper SuperType N.Name
93 | Structure FlatType
94 | Alias ModuleName.Canonical N.Name [(N.Name,Variable)] Variable
95 | Error Text
98data SuperType
99 = Number
100 | Comparable
101 | Appendable
102 | CompAppend
103 deriving (Eq)
106makeDescriptor :: Content -> Descriptor
107makeDescriptor content =
108 Descriptor content noRank noMark Nothing
112-- RANKS
115noRank :: Int
116noRank =
117 0
120outermostRank :: Int
121outermostRank =
122 1
126-- MARKS
129newtype Mark = Mark Word32
130 deriving (Eq, Ord)
133noMark :: Mark
134noMark =
135 Mark 2
138occursMark :: Mark
139occursMark =
140 Mark 1
143getVarNamesMark :: Mark
144getVarNamesMark =
145 Mark 0
148{-# INLINE nextMark #-}
149nextMark :: Mark -> Mark
150nextMark (Mark mark) =
151 Mark (mark + 1)
155-- FUNCTION TYPES
158infixr 9 ==>
161{-# INLINE (==>) #-}
162(==>) :: Type -> Type -> Type
163(==>) =
164 FunN
168-- PRIMITIVE TYPES
171{-# NOINLINE int #-}
172int :: Type
173int = AppN ModuleName.basics "Int" []
176{-# NOINLINE float #-}
177float :: Type
178float = AppN ModuleName.basics "Float" []
181{-# NOINLINE char #-}
182char :: Type
183char = AppN ModuleName.char "Char" []
186{-# NOINLINE string #-}
187string :: Type
188string = AppN ModuleName.string "String" []
191{-# NOINLINE bool #-}
192bool :: Type
193bool = AppN ModuleName.basics "Bool" []
197-- WEBGL TYPES
200{-# NOINLINE vec2 #-}
201vec2 :: Type
202vec2 = AppN ModuleName.vector2 "Vec2" []
205{-# NOINLINE vec3 #-}
206vec3 :: Type
207vec3 = AppN ModuleName.vector3 "Vec3" []
210{-# NOINLINE vec4 #-}
211vec4 :: Type
212vec4 = AppN ModuleName.vector4 "Vec4" []
215{-# NOINLINE mat4 #-}
216mat4 :: Type
217mat4 = AppN ModuleName.matrix4 "Mat4" []
220{-# NOINLINE texture #-}
221texture :: Type
222texture = AppN ModuleName.webgl "Texture" []
226-- MAKE FLEX VARIABLES
229mkFlexVar :: IO Variable
230mkFlexVar =
231 UF.fresh flexVarDescriptor
234{-# NOINLINE flexVarDescriptor #-}
235flexVarDescriptor :: Descriptor
236flexVarDescriptor =
237 makeDescriptor unnamedFlexVar
240{-# NOINLINE unnamedFlexVar #-}
241unnamedFlexVar :: Content
242unnamedFlexVar =
243 FlexVar Nothing
247-- MAKE FLEX NUMBERS
250mkFlexNumber :: IO Variable
251mkFlexNumber =
252 UF.fresh flexNumberDescriptor
255{-# NOINLINE flexNumberDescriptor #-}
256flexNumberDescriptor :: Descriptor
257flexNumberDescriptor =
258 makeDescriptor (unnamedFlexSuper Number)
261unnamedFlexSuper :: SuperType -> Content
262unnamedFlexSuper super =
263 FlexSuper super Nothing
267-- MAKE NAMED VARIABLES
270nameToFlex :: N.Name -> IO Variable
271nameToFlex name =
272 UF.fresh $ makeDescriptor $
273 maybe FlexVar FlexSuper (toSuper name) (Just name)
276nameToRigid :: N.Name -> IO Variable
277nameToRigid name =
278 UF.fresh $ makeDescriptor $
279 maybe RigidVar RigidSuper (toSuper name) name
282toSuper :: N.Name -> Maybe SuperType
283toSuper name =
284 if Text.isPrefixOf "number" name then
285 Just Number
287 else if Text.isPrefixOf "comparable" name then
288 Just Comparable
290 else if Text.isPrefixOf "appendable" name then
291 Just Appendable
293 else if Text.isPrefixOf "compappend" name then
294 Just CompAppend
296 else
297 Nothing
301-- TO SOURCE TYPES
304-- TODO: Attach resulting type to the descriptor so that you
305-- never have to do extra work, particularly nice for aliased types
306toSrcType :: Variable -> IO Can.Type
307toSrcType variable =
308 do takenNames <- getVarNames variable Map.empty
309 State.evalStateT (variableToSrcType variable) (makeNameState takenNames)
312variableToSrcType :: Variable -> StateT NameState IO Can.Type
313variableToSrcType variable =
314 do descriptor <- liftIO $ UF.get variable
315 let mark = _mark descriptor
316 if mark == occursMark
317 then
318 return (Can.TVar "∞")
320 else
321 do liftIO $ UF.modify variable (\desc -> desc { _mark = occursMark })
322 srcType <- contentToSrcType variable (_content descriptor)
323 liftIO $ UF.modify variable (\desc -> desc { _mark = mark })
324 return srcType
327contentToSrcType :: Variable -> Content -> StateT NameState IO Can.Type
328contentToSrcType variable content =
329 case content of
330 Structure term ->
331 termToSrcType term
333 FlexVar maybeName ->
334 case maybeName of
335 Just name ->
336 return (Can.TVar name)
338 Nothing ->
339 do name <- getFreshVarName
340 liftIO $ UF.modify variable (\desc -> desc { _content = FlexVar (Just name) })
341 return (Can.TVar name)
343 FlexSuper super maybeName ->
344 case maybeName of
345 Just name ->
346 return (Can.TVar name)
348 Nothing ->
349 do name <- getFreshSuperName super
350 liftIO $ UF.modify variable (\desc -> desc { _content = FlexSuper super (Just name) })
351 return (Can.TVar name)
353 RigidVar name ->
354 return (Can.TVar name)
356 RigidSuper _ name ->
357 return (Can.TVar name)
359 Alias home name args realVariable ->
360 do srcArgs <- traverse (traverse variableToSrcType) args
361 srcType <- variableToSrcType realVariable
362 return (Can.TAlias home name srcArgs (Can.Filled srcType))
364 Error name ->
365 return (Can.TVar name)
368termToSrcType :: FlatType -> StateT NameState IO Can.Type
369termToSrcType term =
370 case term of
371 App1 home name args ->
372 Can.TType home name <$> traverse variableToSrcType args
374 Fun1 a b ->
375 Can.TLambda
376 <$> variableToSrcType a
377 <*> variableToSrcType b
379 EmptyRecord1 ->
380 return $ Can.TRecord Map.empty Nothing
382 Record1 fields extension ->
383 do srcFields <- traverse variableToSrcType fields
384 srcExt <- Type.iteratedDealias <$> variableToSrcType extension
385 return $
386 case srcExt of
387 Can.TRecord subFields subExt ->
388 Can.TRecord (Map.union subFields srcFields) subExt
390 Can.TVar _ ->
391 Can.TRecord srcFields (Just srcExt)
393 _ ->
394 error "Used toSrcType on a type that is not well-formed"
396 Unit1 ->
397 return Can.TUnit
399 Tuple1 a b maybeC ->
400 Can.TTuple
401 <$> variableToSrcType a
402 <*> variableToSrcType b
403 <*> traverse variableToSrcType maybeC
407-- MANAGE FRESH VARIABLE NAMES
410data NameState =
411 NameState
412 { _taken :: TakenNames
413 , _normals :: Int
414 , _numbers :: Int
415 , _comparables :: Int
416 , _appendables :: Int
417 , _compAppends :: Int
418 }
421type TakenNames = Map.Map Text Variable
424makeNameState :: TakenNames -> NameState
425makeNameState taken =
426 NameState taken 0 0 0 0 0
429getFreshVarName :: (Monad m) => StateT NameState m Text
430getFreshVarName =
431 do index <- State.gets _normals
432 taken <- State.gets _taken
433 let (uniqueName, newIndex) = getFreshNormal index taken
434 State.modify (\state -> state { _normals = newIndex })
435 return uniqueName
438getFreshSuperName :: (Monad m) => SuperType -> StateT NameState m Text
439getFreshSuperName super =
440 case super of
441 Number ->
442 getFreshSuper "number" _numbers (\index state -> state { _numbers = index })
444 Comparable ->
445 getFreshSuper "comparable" _comparables (\index state -> state { _comparables = index })
447 Appendable ->
448 getFreshSuper "appendable" _appendables (\index state -> state { _appendables = index })
450 CompAppend ->
451 getFreshSuper "compappend" _compAppends (\index state -> state { _compAppends = index })
454getFreshNormal :: Int -> TakenNames -> (Text, Int)
455getFreshNormal index taken =
456 let
457 (postfix, letter) =
458 quotRem index 26
460 character =
461 Char.chr (97 + letter)
463 name =
464 Text.pack (if postfix <= 0 then [character] else character : show postfix)
465 in
466 if Map.member name taken then
467 getFreshNormal (index + 1) taken
469 else
470 (name, index + 1)
473getFreshSuper
474 :: (Monad m)
475 => Text
476 -> (NameState -> Int)
477 -> (Int -> NameState -> NameState)
478 -> StateT NameState m Text
479getFreshSuper name getter setter =
480 do index <- State.gets getter
481 taken <- State.gets _taken
482 let (uniqueName, newIndex) = getFreshSuperHelp name index taken
483 State.modify (setter newIndex)
484 return uniqueName
487getFreshSuperHelp :: Text -> Int -> TakenNames -> (Text, Int)
488getFreshSuperHelp name index taken =
489 let
490 newName =
491 if index <= 0 then name else name <> Text.pack (show index)
492 in
493 if Map.member newName taken then
494 getFreshSuperHelp name (index + 1) taken
496 else
497 (newName, index + 1)
501-- GET ALL VARIABLE NAMES
504getVarNames :: Variable -> TakenNames -> IO TakenNames
505getVarNames var takenNames =
506 do (Descriptor content rank mark copy) <- UF.get var
507 if mark == getVarNamesMark
508 then return takenNames
509 else
510 do UF.set var (Descriptor content rank getVarNamesMark copy)
511 case content of
512 Error _ ->
513 return takenNames
515 FlexVar maybeName ->
516 case maybeName of
517 Nothing ->
518 return takenNames
520 Just name ->
521 addName 0 name var (FlexVar . Just) takenNames
523 FlexSuper super maybeName ->
524 case maybeName of
525 Nothing ->
526 return takenNames
528 Just name ->
529 addName 0 name var (FlexSuper super . Just) takenNames
531 RigidVar name ->
532 addName 0 name var RigidVar takenNames
534 RigidSuper super name ->
535 addName 0 name var (RigidSuper super) takenNames
537 Alias _ _ args _ ->
538 foldrM getVarNames takenNames (map snd args)
540 Structure flatType ->
541 case flatType of
542 App1 _ _ args ->
543 foldrM getVarNames takenNames args
545 Fun1 arg body ->
546 getVarNames arg =<< getVarNames body takenNames
548 EmptyRecord1 ->
549 return takenNames
551 Record1 fields extension ->
552 getVarNames extension =<<
553 foldrM getVarNames takenNames (Map.elems fields)
555 Unit1 ->
556 return takenNames
558 Tuple1 a b Nothing ->
559 getVarNames a =<< getVarNames b takenNames
561 Tuple1 a b (Just c) ->
562 getVarNames a =<< getVarNames b =<< getVarNames c takenNames
566-- REGISTER NAME / RENAME DUPLICATES
569addName :: Int -> N.Name -> Variable -> (N.Name -> Content) -> TakenNames -> IO TakenNames
570addName index givenName var makeContent takenNames =
571 let
572 indexedName =
573 if index <= 0 then
574 givenName
575 else if Char.isDigit (Text.last givenName) then
576 givenName <> Text.pack ('_' : show index)
577 else
578 givenName <> Text.pack (show index)
579 in
580 case Map.lookup indexedName takenNames of
581 Nothing ->
582 do if indexedName == givenName then return () else
583 UF.modify var $ \(Descriptor _ rank mark copy) ->
584 Descriptor (makeContent indexedName) rank mark copy
585 return $ Map.insert indexedName var takenNames
587 Just otherVar ->
588 do same <- UF.equivalent var otherVar
589 if same
590 then return takenNames
591 else addName (index + 1) givenName var makeContent takenNames