git.iko.soy/elk
on d9985bc help sign in
elk/src/Type/Type.hs
589 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.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 Text
97data SuperType
98 = Number
99 | Comparable
100 | Appendable
101 | CompAppend
104makeDescriptor :: Content -> Descriptor
105makeDescriptor content =
106 Descriptor content noRank noMark Nothing
110-- RANKS
113noRank :: Int
114noRank =
115 0
118outermostRank :: Int
119outermostRank =
120 1
124-- MARKS
127newtype Mark = Mark Word32
128 deriving (Eq, Ord)
131noMark :: Mark
132noMark =
133 Mark 2
136occursMark :: Mark
137occursMark =
138 Mark 1
141getVarNamesMark :: Mark
142getVarNamesMark =
143 Mark 0
146{-# INLINE nextMark #-}
147nextMark :: Mark -> Mark
148nextMark (Mark mark) =
149 Mark (mark + 1)
153-- FUNCTION TYPES
156infixr 9 ==>
159{-# INLINE (==>) #-}
160(==>) :: Type -> Type -> Type
161(==>) =
162 FunN
166-- PRIMITIVE TYPES
169{-# NOINLINE int #-}
170int :: Type
171int = AppN ModuleName.basics "Int" []
174{-# NOINLINE float #-}
175float :: Type
176float = AppN ModuleName.basics "Float" []
179{-# NOINLINE char #-}
180char :: Type
181char = AppN ModuleName.char "Char" []
184{-# NOINLINE string #-}
185string :: Type
186string = AppN ModuleName.string "String" []
189{-# NOINLINE bool #-}
190bool :: Type
191bool = AppN ModuleName.basics "Bool" []
195-- WEBGL TYPES
198{-# NOINLINE vec2 #-}
199vec2 :: Type
200vec2 = AppN ModuleName.vector2 "Vec2" []
203{-# NOINLINE vec3 #-}
204vec3 :: Type
205vec3 = AppN ModuleName.vector3 "Vec3" []
208{-# NOINLINE vec4 #-}
209vec4 :: Type
210vec4 = AppN ModuleName.vector4 "Vec4" []
213{-# NOINLINE mat4 #-}
214mat4 :: Type
215mat4 = AppN ModuleName.matrix4 "Mat4" []
218{-# NOINLINE texture #-}
219texture :: Type
220texture = AppN ModuleName.webgl "Texture" []
224-- MAKE FLEX VARIABLES
227mkFlexVar :: IO Variable
228mkFlexVar =
229 UF.fresh flexVarDescriptor
232{-# NOINLINE flexVarDescriptor #-}
233flexVarDescriptor :: Descriptor
234flexVarDescriptor =
235 makeDescriptor unnamedFlexVar
238{-# NOINLINE unnamedFlexVar #-}
239unnamedFlexVar :: Content
240unnamedFlexVar =
241 FlexVar Nothing
245-- MAKE FLEX NUMBERS
248mkFlexNumber :: IO Variable
249mkFlexNumber =
250 UF.fresh flexNumberDescriptor
253{-# NOINLINE flexNumberDescriptor #-}
254flexNumberDescriptor :: Descriptor
255flexNumberDescriptor =
256 makeDescriptor (unnamedFlexSuper Number)
259unnamedFlexSuper :: SuperType -> Content
260unnamedFlexSuper super =
261 FlexSuper super Nothing
265-- MAKE NAMED VARIABLES
268nameToFlex :: N.Name -> IO Variable
269nameToFlex name =
270 UF.fresh $ makeDescriptor $
271 maybe FlexVar FlexSuper (toSuper name) (Just name)
274nameToRigid :: N.Name -> IO Variable
275nameToRigid name =
276 UF.fresh $ makeDescriptor $
277 maybe RigidVar RigidSuper (toSuper name) name
280toSuper :: N.Name -> Maybe SuperType
281toSuper name =
282 if Text.isPrefixOf "number" name then
283 Just Number
285 else if Text.isPrefixOf "comparable" name then
286 Just Comparable
288 else if Text.isPrefixOf "appendable" name then
289 Just Appendable
291 else if Text.isPrefixOf "compappend" name then
292 Just CompAppend
294 else
295 Nothing
299-- TO SOURCE TYPES
302-- TODO: Attach resulting type to the descriptor so that you
303-- never have to do extra work, particularly nice for aliased types
304toSrcType :: Variable -> IO Can.Type
305toSrcType variable =
306 do takenNames <- getVarNames variable Map.empty
307 State.evalStateT (variableToSrcType variable) (makeNameState takenNames)
310variableToSrcType :: Variable -> StateT NameState IO Can.Type
311variableToSrcType variable =
312 do descriptor <- liftIO $ UF.descriptor variable
313 let mark = _mark descriptor
314 if mark == occursMark
315 then
316 return (Can.TVar "∞")
318 else
319 do liftIO $ UF.modifyDescriptor variable (\desc -> desc { _mark = occursMark })
320 srcType <- contentToSrcType variable (_content descriptor)
321 liftIO $ UF.modifyDescriptor variable (\desc -> desc { _mark = mark })
322 return srcType
325contentToSrcType :: Variable -> Content -> StateT NameState IO Can.Type
326contentToSrcType variable content =
327 case content of
328 Structure term ->
329 termToSrcType term
331 FlexVar maybeName ->
332 case maybeName of
333 Just name ->
334 return (Can.TVar name)
336 Nothing ->
337 do name <- getFreshVarName
338 liftIO $ UF.modifyDescriptor variable (\desc -> desc { _content = FlexVar (Just name) })
339 return (Can.TVar name)
341 FlexSuper super maybeName ->
342 case maybeName of
343 Just name ->
344 return (Can.TVar name)
346 Nothing ->
347 do name <- getFreshSuperName super
348 liftIO $ UF.modifyDescriptor variable (\desc -> desc { _content = FlexSuper super (Just name) })
349 return (Can.TVar name)
351 RigidVar name ->
352 return (Can.TVar name)
354 RigidSuper _ name ->
355 return (Can.TVar name)
357 Alias home name args realVariable ->
358 do srcArgs <- traverse (traverse variableToSrcType) args
359 srcType <- variableToSrcType realVariable
360 return (Can.TAlias home name srcArgs (Can.Filled srcType))
362 Error name ->
363 return (Can.TVar name)
366termToSrcType :: FlatType -> StateT NameState IO Can.Type
367termToSrcType term =
368 case term of
369 App1 home name args ->
370 Can.TType home name <$> traverse variableToSrcType args
372 Fun1 a b ->
373 Can.TLambda
374 <$> variableToSrcType a
375 <*> variableToSrcType b
377 EmptyRecord1 ->
378 return $ Can.TRecord Map.empty Nothing
380 Record1 fields extension ->
381 do srcFields <- traverse variableToSrcType fields
382 srcExt <- Type.iteratedDealias <$> variableToSrcType extension
383 return $
384 case srcExt of
385 Can.TRecord subFields subExt ->
386 Can.TRecord (Map.union subFields srcFields) subExt
388 Can.TVar _ ->
389 Can.TRecord srcFields (Just srcExt)
391 _ ->
392 error "Used toSrcType on a type that is not well-formed"
394 Unit1 ->
395 return Can.TUnit
397 Tuple1 a b maybeC ->
398 Can.TTuple
399 <$> variableToSrcType a
400 <*> variableToSrcType b
401 <*> traverse variableToSrcType maybeC
405-- MANAGE FRESH VARIABLE NAMES
408data NameState =
409 NameState
410 { _taken :: TakenNames
411 , _normals :: Int
412 , _numbers :: Int
413 , _comparables :: Int
414 , _appendables :: Int
415 , _compAppends :: Int
416 }
419type TakenNames = Map.Map Text Variable
422makeNameState :: TakenNames -> NameState
423makeNameState taken =
424 NameState taken 0 0 0 0 0
427getFreshVarName :: (Monad m) => StateT NameState m Text
428getFreshVarName =
429 do index <- State.gets _normals
430 taken <- State.gets _taken
431 let (uniqueName, newIndex) = getFreshNormal index taken
432 State.modify (\state -> state { _normals = newIndex })
433 return uniqueName
436getFreshSuperName :: (Monad m) => SuperType -> StateT NameState m Text
437getFreshSuperName super =
438 case super of
439 Number ->
440 getFreshSuper "number" _numbers (\index state -> state { _numbers = index })
442 Comparable ->
443 getFreshSuper "comparable" _comparables (\index state -> state { _comparables = index })
445 Appendable ->
446 getFreshSuper "appendable" _appendables (\index state -> state { _appendables = index })
448 CompAppend ->
449 getFreshSuper "compappend" _compAppends (\index state -> state { _compAppends = index })
452getFreshNormal :: Int -> TakenNames -> (Text, Int)
453getFreshNormal index taken =
454 let
455 (postfix, letter) =
456 quotRem index 26
458 character =
459 Char.chr (97 + letter)
461 name =
462 Text.pack (if postfix <= 0 then [character] else character : show postfix)
463 in
464 if Map.member name taken then
465 getFreshNormal (index + 1) taken
467 else
468 (name, index + 1)
471getFreshSuper
472 :: (Monad m)
473 => Text
474 -> (NameState -> Int)
475 -> (Int -> NameState -> NameState)
476 -> StateT NameState m Text
477getFreshSuper name getter setter =
478 do index <- State.gets getter
479 taken <- State.gets _taken
480 let (uniqueName, newIndex) = getFreshSuperHelp name index taken
481 State.modify (setter newIndex)
482 return uniqueName
485getFreshSuperHelp :: Text -> Int -> TakenNames -> (Text, Int)
486getFreshSuperHelp name index taken =
487 let
488 newName =
489 if index <= 0 then name else name <> Text.pack (show index)
490 in
491 if Map.member newName taken then
492 getFreshSuperHelp name (index + 1) taken
494 else
495 (newName, index + 1)
499-- GET ALL VARIABLE NAMES
502getVarNames :: Variable -> TakenNames -> IO TakenNames
503getVarNames var takenNames =
504 do (Descriptor content rank mark copy) <- UF.descriptor var
505 if mark == getVarNamesMark
506 then return takenNames
507 else
508 do UF.setDescriptor var (Descriptor content rank getVarNamesMark copy)
509 case content of
510 Error _ ->
511 return takenNames
513 FlexVar maybeName ->
514 case maybeName of
515 Nothing ->
516 return takenNames
518 Just name ->
519 addName 0 name var (FlexVar . Just) takenNames
521 FlexSuper super maybeName ->
522 case maybeName of
523 Nothing ->
524 return takenNames
526 Just name ->
527 addName 0 name var (FlexSuper super . Just) takenNames
529 RigidVar name ->
530 addName 0 name var RigidVar takenNames
532 RigidSuper super name ->
533 addName 0 name var (RigidSuper super) takenNames
535 Alias _ _ args _ ->
536 foldrM getVarNames takenNames (map snd args)
538 Structure flatType ->
539 case flatType of
540 App1 _ _ args ->
541 foldrM getVarNames takenNames args
543 Fun1 arg body ->
544 getVarNames arg =<< getVarNames body takenNames
546 EmptyRecord1 ->
547 return takenNames
549 Record1 fields extension ->
550 getVarNames extension =<<
551 foldrM getVarNames takenNames (Map.elems fields)
553 Unit1 ->
554 return takenNames
556 Tuple1 a b Nothing ->
557 getVarNames a =<< getVarNames b takenNames
559 Tuple1 a b (Just c) ->
560 getVarNames a =<< getVarNames b =<< getVarNames c takenNames
564-- REGISTER NAME / RENAME DUPLICATES
567addName :: Int -> N.Name -> Variable -> (N.Name -> Content) -> TakenNames -> IO TakenNames
568addName index givenName var makeContent takenNames =
569 let
570 indexedName =
571 if index <= 0 then
572 givenName
573 else if Char.isDigit (Text.last givenName) then
574 givenName <> Text.pack ('_' : show index)
575 else
576 givenName <> Text.pack (show index)
577 in
578 case Map.lookup indexedName takenNames of
579 Nothing ->
580 do if indexedName == givenName then return () else
581 UF.modifyDescriptor var $ \(Descriptor _ rank mark copy) ->
582 Descriptor (makeContent indexedName) rank mark copy
583 return $ Map.insert indexedName var takenNames
585 Just otherVar ->
586 do same <- UF.equivalent var otherVar
587 if same
588 then return takenNames
589 else addName (index + 1) givenName var makeContent takenNames