git.iko.soy/elk
on 9d6d260 help sign in
elk/src/Type/Type.hs
581 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 , noRank
10 , outermostRank
11 , Mark
12 , noMark
13 , nextMark
14 , (==>)
15 , int, float, char, string, bool
16 , vec2, vec3, vec4, mat4, texture
17 , mkFlexVar
18 , mkFlexNumber
19 , unnamedFlexVar
20 , unnamedFlexSuper
21 , nameToFlex
22 , nameToRigid
23 , toSrcType
24 )
25 where
28import Control.Monad.State.Strict (StateT, liftIO)
29import qualified Control.Monad.State.Strict as State
30import qualified Data.Char as Char
31import Data.Foldable (foldrM)
32import qualified Data.Map.Strict as Map
33import Data.Monoid ((<>))
34import qualified Data.Text as Text
35import Data.Text (Text)
36import Data.Word (Word32)
38import qualified AST.Module.Name as ModuleName
39import qualified AST.Type as T
40import qualified Elm.Name as N
41import qualified Type.UnionFind as UF
45-- TYPE PRIMITIVES
48type Variable =
49 UF.Point Descriptor
52data FlatType
53 = App1 ModuleName.Canonical N.Name [Variable]
54 | Fun1 Variable Variable
55 | EmptyRecord1
56 | Record1 (Map.Map N.Name Variable) Variable
57 | Unit1
58 | Tuple1 Variable Variable (Maybe Variable)
61data Type
62 = PlaceHolder N.Name
63 | AliasN ModuleName.Canonical N.Name [(N.Name, Type)] Type
64 | VarN Variable
65 | AppN ModuleName.Canonical N.Name [Type]
66 | FunN Type Type
67 | EmptyRecordN
68 | RecordN (Map.Map N.Name Type) Type
69 | UnitN
70 | TupleN Type Type (Maybe Type)
74-- DESCRIPTORS
77data Descriptor =
78 Descriptor
79 { _content :: Content
80 , _rank :: Int
81 , _mark :: Mark
82 , _copy :: Maybe Variable
83 }
86data Content
87 = FlexVar (Maybe N.Name)
88 | FlexSuper T.Super (Maybe N.Name)
89 | RigidVar N.Name
90 | RigidSuper T.Super N.Name
91 | Structure FlatType
92 | Alias ModuleName.Canonical N.Name [(N.Name,Variable)] Variable
93 | Error Text
96makeDescriptor :: Content -> Descriptor
97makeDescriptor content =
98 Descriptor content noRank noMark Nothing
102-- RANKS
105noRank :: Int
106noRank =
107 0
110outermostRank :: Int
111outermostRank =
112 1
116-- MARKS
119newtype Mark = Mark Word32
120 deriving (Eq, Ord)
123noMark :: Mark
124noMark =
125 Mark 2
128occursMark :: Mark
129occursMark =
130 Mark 1
133getVarNamesMark :: Mark
134getVarNamesMark =
135 Mark 0
138{-# INLINE nextMark #-}
139nextMark :: Mark -> Mark
140nextMark (Mark mark) =
141 Mark (mark + 1)
145-- FUNCTION TYPES
148infixr 9 ==>
151{-# INLINE (==>) #-}
152(==>) :: Type -> Type -> Type
153(==>) =
154 FunN
158-- PRIMITIVE TYPES
161{-# NOINLINE int #-}
162int :: Type
163int = AppN ModuleName.basics "Int" []
166{-# NOINLINE float #-}
167float :: Type
168float = AppN ModuleName.basics "Float" []
171{-# NOINLINE char #-}
172char :: Type
173char = AppN ModuleName.char "Char" []
176{-# NOINLINE string #-}
177string :: Type
178string = AppN ModuleName.string "String" []
181{-# NOINLINE bool #-}
182bool :: Type
183bool = AppN ModuleName.basics "Bool" []
187-- WEBGL TYPES
190{-# NOINLINE vec2 #-}
191vec2 :: Type
192vec2 = AppN ModuleName.vector2 "Vec2" []
195{-# NOINLINE vec3 #-}
196vec3 :: Type
197vec3 = AppN ModuleName.vector3 "Vec3" []
200{-# NOINLINE vec4 #-}
201vec4 :: Type
202vec4 = AppN ModuleName.vector4 "Vec4" []
205{-# NOINLINE mat4 #-}
206mat4 :: Type
207mat4 = AppN ModuleName.matrix4 "Mat4" []
210{-# NOINLINE texture #-}
211texture :: Type
212texture = AppN ModuleName.webgl "Texture" []
216-- MAKE FLEX VARIABLES
219mkFlexVar :: IO Variable
220mkFlexVar =
221 UF.fresh flexVarDescriptor
224{-# NOINLINE flexVarDescriptor #-}
225flexVarDescriptor :: Descriptor
226flexVarDescriptor =
227 makeDescriptor unnamedFlexVar
230{-# NOINLINE unnamedFlexVar #-}
231unnamedFlexVar :: Content
232unnamedFlexVar =
233 FlexVar Nothing
237-- MAKE FLEX NUMBERS
240mkFlexNumber :: IO Variable
241mkFlexNumber =
242 UF.fresh flexNumberDescriptor
245{-# NOINLINE flexNumberDescriptor #-}
246flexNumberDescriptor :: Descriptor
247flexNumberDescriptor =
248 makeDescriptor (unnamedFlexSuper T.Number)
251unnamedFlexSuper :: T.Super -> Content
252unnamedFlexSuper super =
253 FlexSuper super Nothing
257-- MAKE NAMED VARIABLES
260nameToFlex :: N.Name -> IO Variable
261nameToFlex name =
262 UF.fresh $ makeDescriptor $
263 maybe FlexVar FlexSuper (toSuper name) (Just name)
266nameToRigid :: N.Name -> IO Variable
267nameToRigid name =
268 UF.fresh $ makeDescriptor $
269 maybe RigidVar RigidSuper (toSuper name) name
272toSuper :: N.Name -> Maybe T.Super
273toSuper name =
274 if Text.isPrefixOf "number" name then
275 Just T.Number
277 else if Text.isPrefixOf "comparable" name then
278 Just T.Comparable
280 else if Text.isPrefixOf "appendable" name then
281 Just T.Appendable
283 else if Text.isPrefixOf "compappend" name then
284 Just T.CompAppend
286 else
287 Nothing
291-- TO SOURCE TYPES
294-- TODO: Attach resulting type to the descriptor so that you
295-- never have to do extra work, particularly nice for aliased types
296toSrcType :: Variable -> IO T.Canonical
297toSrcType variable =
298 do takenNames <- getVarNames variable Map.empty
299 State.evalStateT (variableToSrcType variable) (makeNameState takenNames)
302variableToSrcType :: Variable -> StateT NameState IO T.Canonical
303variableToSrcType variable =
304 do descriptor <- liftIO $ UF.descriptor variable
305 let mark = _mark descriptor
306 if mark == occursMark
307 then
308 return (T.Var "∞")
310 else
311 do liftIO $ UF.modifyDescriptor variable (\desc -> desc { _mark = occursMark })
312 srcType <- contentToSrcType variable (_content descriptor)
313 liftIO $ UF.modifyDescriptor variable (\desc -> desc { _mark = mark })
314 return srcType
317contentToSrcType :: Variable -> Content -> StateT NameState IO T.Canonical
318contentToSrcType variable content =
319 case content of
320 Structure term ->
321 termToSrcType term
323 FlexVar maybeName ->
324 case maybeName of
325 Just name ->
326 return (T.Var name)
328 Nothing ->
329 do name <- getFreshVarName
330 liftIO $ UF.modifyDescriptor variable (\desc -> desc { _content = FlexVar (Just name) })
331 return (T.Var name)
333 FlexSuper super maybeName ->
334 case maybeName of
335 Just name ->
336 return (T.Var name)
338 Nothing ->
339 do name <- getFreshSuperName super
340 liftIO $ UF.modifyDescriptor variable (\desc -> desc { _content = FlexSuper super (Just name) })
341 return (T.Var name)
343 RigidVar name ->
344 return (T.Var name)
346 RigidSuper _ name ->
347 return (T.Var name)
349 Alias home name args realVariable ->
350 do srcArgs <- traverse (traverse variableToSrcType) args
351 srcType <- variableToSrcType realVariable
352 return (T.Aliased home name srcArgs (T.Filled srcType))
354 Error name ->
355 return (T.Var name)
358termToSrcType :: FlatType -> StateT NameState IO T.Canonical
359termToSrcType term =
360 case term of
361 App1 home name args ->
362 T.Type home name <$> traverse variableToSrcType args
364 Fun1 a b ->
365 T.Lambda
366 <$> variableToSrcType a
367 <*> variableToSrcType b
369 EmptyRecord1 ->
370 return $ T.Record Map.empty Nothing
372 Record1 fields extension ->
373 do srcFields <- traverse variableToSrcType fields
374 srcExt <- T.iteratedDealias <$> variableToSrcType extension
375 return $
376 case srcExt of
377 T.Record subFields subExt ->
378 T.Record (Map.union subFields srcFields) subExt
380 T.Var _ ->
381 T.Record srcFields (Just srcExt)
383 _ ->
384 error "Used toSrcType on a type that is not well-formed"
386 Unit1 ->
387 return T.Unit
389 Tuple1 a b maybeC ->
390 T.Tuple
391 <$> variableToSrcType a
392 <*> variableToSrcType b
393 <*> traverse variableToSrcType maybeC
397-- MANAGE FRESH VARIABLE NAMES
400data NameState =
401 NameState
402 { _taken :: TakenNames
403 , _normals :: Int
404 , _numbers :: Int
405 , _comparables :: Int
406 , _appendables :: Int
407 , _compAppends :: Int
408 }
411type TakenNames = Map.Map Text Variable
414makeNameState :: TakenNames -> NameState
415makeNameState taken =
416 NameState taken 0 0 0 0 0
419getFreshVarName :: (Monad m) => StateT NameState m Text
420getFreshVarName =
421 do index <- State.gets _normals
422 taken <- State.gets _taken
423 let (uniqueName, newIndex) = getFreshNormal index taken
424 State.modify (\state -> state { _normals = newIndex })
425 return uniqueName
428getFreshSuperName :: (Monad m) => T.Super -> StateT NameState m Text
429getFreshSuperName super =
430 case super of
431 T.Number ->
432 getFreshSuper "number" _numbers (\index state -> state { _numbers = index })
434 T.Comparable ->
435 getFreshSuper "comparable" _comparables (\index state -> state { _comparables = index })
437 T.Appendable ->
438 getFreshSuper "appendable" _appendables (\index state -> state { _appendables = index })
440 T.CompAppend ->
441 getFreshSuper "compappend" _compAppends (\index state -> state { _compAppends = index })
444getFreshNormal :: Int -> TakenNames -> (Text, Int)
445getFreshNormal index taken =
446 let
447 (postfix, letter) =
448 quotRem index 26
450 character =
451 Char.chr (97 + letter)
453 name =
454 Text.pack (if postfix <= 0 then [character] else character : show postfix)
455 in
456 if Map.member name taken then
457 getFreshNormal (index + 1) taken
459 else
460 (name, index + 1)
463getFreshSuper
464 :: (Monad m)
465 => Text
466 -> (NameState -> Int)
467 -> (Int -> NameState -> NameState)
468 -> StateT NameState m Text
469getFreshSuper name getter setter =
470 do index <- State.gets getter
471 taken <- State.gets _taken
472 let (uniqueName, newIndex) = getFreshSuperHelp name index taken
473 State.modify (setter newIndex)
474 return uniqueName
477getFreshSuperHelp :: Text -> Int -> TakenNames -> (Text, Int)
478getFreshSuperHelp name index taken =
479 let
480 newName =
481 if index <= 0 then name else name <> Text.pack (show index)
482 in
483 if Map.member newName taken then
484 getFreshSuperHelp name (index + 1) taken
486 else
487 (newName, index + 1)
491-- GET ALL VARIABLE NAMES
494getVarNames :: Variable -> TakenNames -> IO TakenNames
495getVarNames var takenNames =
496 do (Descriptor content rank mark copy) <- UF.descriptor var
497 if mark == getVarNamesMark
498 then return takenNames
499 else
500 do UF.setDescriptor var (Descriptor content rank getVarNamesMark copy)
501 case content of
502 Error _ ->
503 return takenNames
505 FlexVar maybeName ->
506 case maybeName of
507 Nothing ->
508 return takenNames
510 Just name ->
511 addName 0 name var (FlexVar . Just) takenNames
513 FlexSuper super maybeName ->
514 case maybeName of
515 Nothing ->
516 return takenNames
518 Just name ->
519 addName 0 name var (FlexSuper super . Just) takenNames
521 RigidVar name ->
522 addName 0 name var RigidVar takenNames
524 RigidSuper super name ->
525 addName 0 name var (RigidSuper super) takenNames
527 Alias _ _ args _ ->
528 foldrM getVarNames takenNames (map snd args)
530 Structure flatType ->
531 case flatType of
532 App1 _ _ args ->
533 foldrM getVarNames takenNames args
535 Fun1 arg body ->
536 getVarNames arg =<< getVarNames body takenNames
538 EmptyRecord1 ->
539 return takenNames
541 Record1 fields extension ->
542 getVarNames extension =<<
543 foldrM getVarNames takenNames (Map.elems fields)
545 Unit1 ->
546 return takenNames
548 Tuple1 a b Nothing ->
549 getVarNames a =<< getVarNames b takenNames
551 Tuple1 a b (Just c) ->
552 getVarNames a =<< getVarNames b =<< getVarNames c takenNames
556-- REGISTER NAME / RENAME DUPLICATES
559addName :: Int -> N.Name -> Variable -> (N.Name -> Content) -> TakenNames -> IO TakenNames
560addName index givenName var makeContent takenNames =
561 let
562 indexedName =
563 if index <= 0 then
564 givenName
565 else if Char.isDigit (Text.last givenName) then
566 givenName <> Text.pack ('_' : show index)
567 else
568 givenName <> Text.pack (show index)
569 in
570 case Map.lookup indexedName takenNames of
571 Nothing ->
572 do if indexedName == givenName then return () else
573 UF.modifyDescriptor var $ \(Descriptor _ rank mark copy) ->
574 Descriptor (makeContent indexedName) rank mark copy
575 return $ Map.insert indexedName var takenNames
577 Just otherVar ->
578 do same <- UF.equivalent var otherVar
579 if same
580 then return takenNames
581 else addName (index + 1) givenName var makeContent takenNames