git.iko.soy/elk
on 8a89c86 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 )
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" []
196{-# NOINLINE never #-}
197never :: Type
198never = AppN ModuleName.basics "Never" []
202-- WEBGL TYPES
205{-# NOINLINE vec2 #-}
206vec2 :: Type
207vec2 = AppN ModuleName.vector2 "Vec2" []
210{-# NOINLINE vec3 #-}
211vec3 :: Type
212vec3 = AppN ModuleName.vector3 "Vec3" []
215{-# NOINLINE vec4 #-}
216vec4 :: Type
217vec4 = AppN ModuleName.vector4 "Vec4" []
220{-# NOINLINE mat4 #-}
221mat4 :: Type
222mat4 = AppN ModuleName.matrix4 "Mat4" []
225{-# NOINLINE texture #-}
226texture :: Type
227texture = AppN ModuleName.webgl "Texture" []
231-- MAKE FLEX VARIABLES
234mkFlexVar :: IO Variable
235mkFlexVar =
236 UF.fresh flexVarDescriptor
239{-# NOINLINE flexVarDescriptor #-}
240flexVarDescriptor :: Descriptor
241flexVarDescriptor =
242 makeDescriptor unnamedFlexVar
245{-# NOINLINE unnamedFlexVar #-}
246unnamedFlexVar :: Content
247unnamedFlexVar =
248 FlexVar Nothing
252-- MAKE FLEX NUMBERS
255mkFlexNumber :: IO Variable
256mkFlexNumber =
257 UF.fresh flexNumberDescriptor
260{-# NOINLINE flexNumberDescriptor #-}
261flexNumberDescriptor :: Descriptor
262flexNumberDescriptor =
263 makeDescriptor (unnamedFlexSuper Number)
266unnamedFlexSuper :: SuperType -> Content
267unnamedFlexSuper super =
268 FlexSuper super Nothing
272-- MAKE NAMED VARIABLES
275nameToFlex :: N.Name -> IO Variable
276nameToFlex name =
277 UF.fresh $ makeDescriptor $
278 maybe FlexVar FlexSuper (toSuper name) (Just name)
281nameToRigid :: N.Name -> IO Variable
282nameToRigid name =
283 UF.fresh $ makeDescriptor $
284 maybe RigidVar RigidSuper (toSuper name) name
287toSuper :: N.Name -> Maybe SuperType
288toSuper name =
289 if Text.isPrefixOf "number" name then
290 Just Number
292 else if Text.isPrefixOf "comparable" name then
293 Just Comparable
295 else if Text.isPrefixOf "appendable" name then
296 Just Appendable
298 else if Text.isPrefixOf "compappend" name then
299 Just CompAppend
301 else
302 Nothing
306-- TO SOURCE TYPES
309-- TODO: Attach resulting type to the descriptor so that you
310-- never have to do extra work, particularly nice for aliased types
311toSrcType :: Variable -> IO Can.Type
312toSrcType variable =
313 do takenNames <- getVarNames variable Map.empty
314 State.evalStateT (variableToSrcType variable) (makeNameState takenNames)
317variableToSrcType :: Variable -> StateT NameState IO Can.Type
318variableToSrcType variable =
319 do descriptor <- liftIO $ UF.get variable
320 let mark = _mark descriptor
321 if mark == occursMark
322 then
323 return (Can.TVar "∞")
325 else
326 do liftIO $ UF.modify variable (\desc -> desc { _mark = occursMark })
327 srcType <- contentToSrcType variable (_content descriptor)
328 liftIO $ UF.modify variable (\desc -> desc { _mark = mark })
329 return srcType
332contentToSrcType :: Variable -> Content -> StateT NameState IO Can.Type
333contentToSrcType variable content =
334 case content of
335 Structure term ->
336 termToSrcType term
338 FlexVar maybeName ->
339 case maybeName of
340 Just name ->
341 return (Can.TVar name)
343 Nothing ->
344 do name <- getFreshVarName
345 liftIO $ UF.modify variable (\desc -> desc { _content = FlexVar (Just name) })
346 return (Can.TVar name)
348 FlexSuper super maybeName ->
349 case maybeName of
350 Just name ->
351 return (Can.TVar name)
353 Nothing ->
354 do name <- getFreshSuperName super
355 liftIO $ UF.modify variable (\desc -> desc { _content = FlexSuper super (Just name) })
356 return (Can.TVar name)
358 RigidVar name ->
359 return (Can.TVar name)
361 RigidSuper _ name ->
362 return (Can.TVar name)
364 Alias home name args realVariable ->
365 do srcArgs <- traverse (traverse variableToSrcType) args
366 srcType <- variableToSrcType realVariable
367 return (Can.TAlias home name srcArgs (Can.Filled srcType))
369 Error name ->
370 return (Can.TVar name)
373termToSrcType :: FlatType -> StateT NameState IO Can.Type
374termToSrcType term =
375 case term of
376 App1 home name args ->
377 Can.TType home name <$> traverse variableToSrcType args
379 Fun1 a b ->
380 Can.TLambda
381 <$> variableToSrcType a
382 <*> variableToSrcType b
384 EmptyRecord1 ->
385 return $ Can.TRecord Map.empty Nothing
387 Record1 fields extension ->
388 do srcFields <- traverse variableToSrcType fields
389 srcExt <- Type.iteratedDealias <$> variableToSrcType extension
390 return $
391 case srcExt of
392 Can.TRecord subFields subExt ->
393 Can.TRecord (Map.union subFields srcFields) subExt
395 Can.TVar _ ->
396 Can.TRecord srcFields (Just srcExt)
398 _ ->
399 error "Used toSrcType on a type that is not well-formed"
401 Unit1 ->
402 return Can.TUnit
404 Tuple1 a b maybeC ->
405 Can.TTuple
406 <$> variableToSrcType a
407 <*> variableToSrcType b
408 <*> traverse variableToSrcType maybeC
412-- MANAGE FRESH VARIABLE NAMES
415data NameState =
416 NameState
417 { _taken :: TakenNames
418 , _normals :: Int
419 , _numbers :: Int
420 , _comparables :: Int
421 , _appendables :: Int
422 , _compAppends :: Int
423 }
426type TakenNames = Map.Map Text Variable
429makeNameState :: TakenNames -> NameState
430makeNameState taken =
431 NameState taken 0 0 0 0 0
434getFreshVarName :: (Monad m) => StateT NameState m Text
435getFreshVarName =
436 do index <- State.gets _normals
437 taken <- State.gets _taken
438 let (uniqueName, newIndex) = getFreshNormal index taken
439 State.modify (\state -> state { _normals = newIndex })
440 return uniqueName
443getFreshSuperName :: (Monad m) => SuperType -> StateT NameState m Text
444getFreshSuperName super =
445 case super of
446 Number ->
447 getFreshSuper "number" _numbers (\index state -> state { _numbers = index })
449 Comparable ->
450 getFreshSuper "comparable" _comparables (\index state -> state { _comparables = index })
452 Appendable ->
453 getFreshSuper "appendable" _appendables (\index state -> state { _appendables = index })
455 CompAppend ->
456 getFreshSuper "compappend" _compAppends (\index state -> state { _compAppends = index })
459getFreshNormal :: Int -> TakenNames -> (Text, Int)
460getFreshNormal index taken =
461 let
462 (postfix, letter) =
463 quotRem index 26
465 character =
466 Char.chr (97 + letter)
468 name =
469 Text.pack (if postfix <= 0 then [character] else character : show postfix)
470 in
471 if Map.member name taken then
472 getFreshNormal (index + 1) taken
474 else
475 (name, index + 1)
478getFreshSuper
479 :: (Monad m)
480 => Text
481 -> (NameState -> Int)
482 -> (Int -> NameState -> NameState)
483 -> StateT NameState m Text
484getFreshSuper name getter setter =
485 do index <- State.gets getter
486 taken <- State.gets _taken
487 let (uniqueName, newIndex) = getFreshSuperHelp name index taken
488 State.modify (setter newIndex)
489 return uniqueName
492getFreshSuperHelp :: Text -> Int -> TakenNames -> (Text, Int)
493getFreshSuperHelp name index taken =
494 let
495 newName =
496 if index <= 0 then name else name <> Text.pack (show index)
497 in
498 if Map.member newName taken then
499 getFreshSuperHelp name (index + 1) taken
501 else
502 (newName, index + 1)
506-- GET ALL VARIABLE NAMES
509getVarNames :: Variable -> TakenNames -> IO TakenNames
510getVarNames var takenNames =
511 do (Descriptor content rank mark copy) <- UF.get var
512 if mark == getVarNamesMark
513 then return takenNames
514 else
515 do UF.set var (Descriptor content rank getVarNamesMark copy)
516 case content of
517 Error _ ->
518 return takenNames
520 FlexVar maybeName ->
521 case maybeName of
522 Nothing ->
523 return takenNames
525 Just name ->
526 addName 0 name var (FlexVar . Just) takenNames
528 FlexSuper super maybeName ->
529 case maybeName of
530 Nothing ->
531 return takenNames
533 Just name ->
534 addName 0 name var (FlexSuper super . Just) takenNames
536 RigidVar name ->
537 addName 0 name var RigidVar takenNames
539 RigidSuper super name ->
540 addName 0 name var (RigidSuper super) takenNames
542 Alias _ _ args _ ->
543 foldrM getVarNames takenNames (map snd args)
545 Structure flatType ->
546 case flatType of
547 App1 _ _ args ->
548 foldrM getVarNames takenNames args
550 Fun1 arg body ->
551 getVarNames arg =<< getVarNames body takenNames
553 EmptyRecord1 ->
554 return takenNames
556 Record1 fields extension ->
557 getVarNames extension =<<
558 foldrM getVarNames takenNames (Map.elems fields)
560 Unit1 ->
561 return takenNames
563 Tuple1 a b Nothing ->
564 getVarNames a =<< getVarNames b takenNames
566 Tuple1 a b (Just c) ->
567 getVarNames a =<< getVarNames b =<< getVarNames c takenNames
571-- REGISTER NAME / RENAME DUPLICATES
574addName :: Int -> N.Name -> Variable -> (N.Name -> Content) -> TakenNames -> IO TakenNames
575addName index givenName var makeContent takenNames =
576 let
577 indexedName =
578 if index <= 0 then
579 givenName
580 else if Char.isDigit (Text.last givenName) then
581 givenName <> Text.pack ('_' : show index)
582 else
583 givenName <> Text.pack (show 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