git.iko.soy/elk
on a8bfb99 help sign in
elk/src/Type/Type.hs
650 lines 15 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 , (==>), float, char, string, bool
15 , mkFlexVar
16 , mkFlexNumber
17 , unnamedFlexVar
18 , unnamedFlexSuper
19 , nameToFlex
20 , nameToRigid
21 , toSrcType
22 , fromFlexSrcType
23 , fromRigidSrcType
24 )
25 where
27import Control.Monad.State.Strict (StateT, liftIO)
28import qualified Control.Monad.State.Strict as State
29import qualified Data.Char as Char
30import Data.Foldable (foldrM)
31import qualified Data.Map.Strict as Map
32import Data.Map.Strict ((!))
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 Text Variable) Variable
57 | Unit1
58 | Tuple1 Variable Variable (Maybe Variable)
61data Type
62 = PlaceHolder Text
63 | AliasN ModuleName.Canonical N.Name [(Text, Type)] Type
64 | VarN Variable
65 | AppN ModuleName.Canonical N.Name [Type]
66 | FunN Type Type
67 | EmptyRecordN
68 | RecordN (Map.Map Text 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 Text)
88 | FlexSuper T.Super (Maybe Text)
89 | RigidVar Text
90 | RigidSuper T.Super Text
91 | Structure FlatType
92 | Alias ModuleName.Canonical N.Name [(Text,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-- TYPE HELPERS
148infixr 9 ==>
151{-# INLINE (==>) #-}
152(==>) :: Type -> Type -> Type
153(==>) =
154 FunN
157{-# NOINLINE float #-}
158float :: Type
159float =
160 AppN ModuleName.basics "Float" []
163{-# NOINLINE char #-}
164char :: Type
165char =
166 AppN ModuleName.basics "Char" []
169{-# NOINLINE string #-}
170string :: Type
171string =
172 AppN ModuleName.basics "String" []
175{-# NOINLINE bool #-}
176bool :: Type
177bool =
178 AppN ModuleName.basics "Bool" []
182-- MAKE FLEX VARIABLES
185mkFlexVar :: IO Variable
186mkFlexVar =
187 UF.fresh flexVarDescriptor
190{-# NOINLINE flexVarDescriptor #-}
191flexVarDescriptor :: Descriptor
192flexVarDescriptor =
193 makeDescriptor unnamedFlexVar
196{-# NOINLINE unnamedFlexVar #-}
197unnamedFlexVar :: Content
198unnamedFlexVar =
199 FlexVar Nothing
203-- MAKE FLEX NUMBERS
206mkFlexNumber :: IO Variable
207mkFlexNumber =
208 UF.fresh flexNumberDescriptor
211{-# NOINLINE flexNumberDescriptor #-}
212flexNumberDescriptor :: Descriptor
213flexNumberDescriptor =
214 makeDescriptor (unnamedFlexSuper T.Number)
217unnamedFlexSuper :: T.Super -> Content
218unnamedFlexSuper super =
219 FlexSuper super Nothing
223-- MAKE NAMED VARIABLES
226nameToFlex :: N.Name -> IO Variable
227nameToFlex name =
228 UF.fresh $ makeDescriptor $
229 maybe FlexVar FlexSuper (toSuper name) (Just name)
232nameToRigid :: N.Name -> IO Variable
233nameToRigid name =
234 UF.fresh $ makeDescriptor $
235 maybe RigidVar RigidSuper (toSuper name) name
238toSuper :: N.Name -> Maybe T.Super
239toSuper name =
240 if Text.isPrefixOf "number" name then
241 Just T.Number
243 else if Text.isPrefixOf "comparable" name then
244 Just T.Comparable
246 else if Text.isPrefixOf "appendable" name then
247 Just T.Appendable
249 else if Text.isPrefixOf "compappend" name then
250 Just T.CompAppend
252 else
253 Nothing
257-- FROM SOURCE TYPES
260-- TODO should the freeFlexVars be ranked a certain way?
261-- How does this interact with `TS.flatten` exactly?
262fromFlexSrcType :: T.Canonical -> IO ( Type, Map.Map N.Name Variable )
263fromFlexSrcType srcType =
264 do let freeVars = gatherFreeVars srcType Map.empty
265 freeFlexVars <- Map.traverseWithKey (\name () -> nameToFlex name) freeVars
266 tipe <- fromSrcType (Map.map VarN freeFlexVars) srcType
267 return ( tipe, freeFlexVars )
270fromRigidSrcType :: T.Canonical -> IO ( Type, Map.Map N.Name Variable )
271fromRigidSrcType srcType =
272 do let freeVars = gatherFreeVars srcType Map.empty
273 freeRigidVars <- Map.traverseWithKey (\name () -> nameToRigid name) freeVars
274 tipe <- fromSrcType (Map.map VarN freeRigidVars) srcType
275 return ( tipe, freeRigidVars )
278gatherFreeVars :: T.Canonical -> Map.Map N.Name () -> Map.Map N.Name ()
279gatherFreeVars tipe dict =
280 case tipe of
281 T.Lambda arg result ->
282 gatherFreeVars result (gatherFreeVars arg dict)
284 T.Var name ->
285 Map.insert name () dict
287 T.Type _ _ args ->
288 foldr gatherFreeVars dict args
290 T.Aliased _ _ args _ ->
291 foldr gatherFreeVars dict (map snd args)
293 T.Tuple a b maybeC ->
294 gatherFreeVars a $ gatherFreeVars b $
295 case maybeC of
296 Nothing ->
297 dict
299 Just c ->
300 gatherFreeVars c dict
302 T.Unit ->
303 dict
305 T.Record fields maybeExt ->
306 case maybeExt of
307 Nothing ->
308 Map.foldr gatherFreeVars dict fields
310 Just ext ->
311 Map.foldr gatherFreeVars (gatherFreeVars ext dict) fields
314fromSrcType :: Map.Map N.Name Type -> T.Canonical -> IO Type
315fromSrcType freeVars sourceType =
316 case sourceType of
317 T.Lambda arg result ->
318 FunN
319 <$> fromSrcType freeVars arg
320 <*> fromSrcType freeVars result
322 T.Var name ->
323 return (freeVars ! name)
325 T.Type home name args ->
326 AppN home name <$> traverse (fromSrcType freeVars) args
328 T.Aliased home name args aliasedType ->
329 do targs <- traverse (traverse (fromSrcType freeVars)) args
330 AliasN home name targs <$>
331 case aliasedType of
332 T.Filled realType ->
333 fromSrcType freeVars realType
335 T.Holey realType ->
336 fromSrcType (Map.fromList targs) realType
338 T.Tuple a b maybeC ->
339 TupleN
340 <$> fromSrcType freeVars a
341 <*> fromSrcType freeVars b
342 <*> traverse (fromSrcType freeVars) maybeC
344 T.Unit ->
345 return UnitN
347 T.Record fields maybeExt ->
348 RecordN
349 <$> traverse (fromSrcType freeVars) fields
350 <*>
351 case maybeExt of
352 Nothing ->
353 return EmptyRecordN
355 Just ext ->
356 fromSrcType freeVars ext
360-- TO SOURCE TYPES
363-- TODO: Attach resulting type to the descriptor so that you
364-- never have to do extra work, particularly nice for aliased types
365toSrcType :: Variable -> IO T.Canonical
366toSrcType variable =
367 do takenNames <- getVarNames variable Map.empty
368 State.evalStateT (variableToSrcType variable) (makeNameState takenNames)
371variableToSrcType :: Variable -> StateT NameState IO T.Canonical
372variableToSrcType variable =
373 do descriptor <- liftIO $ UF.descriptor variable
374 let mark = _mark descriptor
375 if mark == occursMark
376 then
377 return (T.Var "∞")
379 else
380 do liftIO $ UF.modifyDescriptor variable (\desc -> desc { _mark = occursMark })
381 srcType <- contentToSrcType variable (_content descriptor)
382 liftIO $ UF.modifyDescriptor variable (\desc -> desc { _mark = mark })
383 return srcType
386contentToSrcType :: Variable -> Content -> StateT NameState IO T.Canonical
387contentToSrcType variable content =
388 case content of
389 Structure term ->
390 termToSrcType term
392 FlexVar maybeName ->
393 case maybeName of
394 Just name ->
395 return (T.Var name)
397 Nothing ->
398 do name <- getFreshVarName
399 liftIO $ UF.modifyDescriptor variable (\desc -> desc { _content = FlexVar (Just name) })
400 return (T.Var name)
402 FlexSuper super maybeName ->
403 case maybeName of
404 Just name ->
405 return (T.Var name)
407 Nothing ->
408 do name <- getFreshSuperName super
409 liftIO $ UF.modifyDescriptor variable (\desc -> desc { _content = FlexSuper super (Just name) })
410 return (T.Var name)
412 RigidVar name ->
413 return (T.Var name)
415 RigidSuper _ name ->
416 return (T.Var name)
418 Alias home name args realVariable ->
419 do srcArgs <- traverse (traverse variableToSrcType) args
420 srcType <- variableToSrcType realVariable
421 return (T.Aliased home name srcArgs (T.Filled srcType))
423 Error name ->
424 return (T.Var name)
427termToSrcType :: FlatType -> StateT NameState IO T.Canonical
428termToSrcType term =
429 case term of
430 App1 home name args ->
431 T.Type home name <$> traverse variableToSrcType args
433 Fun1 a b ->
434 T.Lambda
435 <$> variableToSrcType a
436 <*> variableToSrcType b
438 EmptyRecord1 ->
439 return $ T.Record Map.empty Nothing
441 Record1 fields extension ->
442 do srcFields <- traverse variableToSrcType fields
443 srcExt <- T.iteratedDealias <$> variableToSrcType extension
444 return $
445 case srcExt of
446 T.Record subFields subExt ->
447 T.Record (Map.union subFields srcFields) subExt
449 T.Var _ ->
450 T.Record srcFields (Just srcExt)
452 _ ->
453 error "Used toSrcType on a type that is not well-formed"
455 Unit1 ->
456 return T.Unit
458 Tuple1 a b maybeC ->
459 T.Tuple
460 <$> variableToSrcType a
461 <*> variableToSrcType b
462 <*> traverse variableToSrcType maybeC
466-- MANAGE FRESH VARIABLE NAMES
469data NameState =
470 NameState
471 { _taken :: TakenNames
472 , _normals :: Int
473 , _numbers :: Int
474 , _comparables :: Int
475 , _appendables :: Int
476 , _compAppends :: Int
477 }
480type TakenNames = Map.Map Text Variable
483makeNameState :: TakenNames -> NameState
484makeNameState taken =
485 NameState taken 0 0 0 0 0
488getFreshVarName :: (Monad m) => StateT NameState m Text
489getFreshVarName =
490 do index <- State.gets _normals
491 taken <- State.gets _taken
492 let (uniqueName, newIndex) = getFreshNormal index taken
493 State.modify (\state -> state { _normals = newIndex })
494 return uniqueName
497getFreshSuperName :: (Monad m) => T.Super -> StateT NameState m Text
498getFreshSuperName super =
499 case super of
500 T.Number ->
501 getFreshSuper "number" _numbers (\index state -> state { _numbers = index })
503 T.Comparable ->
504 getFreshSuper "comparable" _comparables (\index state -> state { _comparables = index })
506 T.Appendable ->
507 getFreshSuper "appendable" _appendables (\index state -> state { _appendables = index })
509 T.CompAppend ->
510 getFreshSuper "compappend" _compAppends (\index state -> state { _compAppends = index })
513getFreshNormal :: Int -> TakenNames -> (Text, Int)
514getFreshNormal index taken =
515 let
516 (postfix, letter) =
517 quotRem index 26
519 character =
520 Char.chr (97 + letter)
522 name =
523 Text.pack (if postfix <= 0 then [character] else character : show postfix)
524 in
525 if Map.member name taken then
526 getFreshNormal (index + 1) taken
528 else
529 (name, index + 1)
532getFreshSuper
533 :: (Monad m)
534 => Text
535 -> (NameState -> Int)
536 -> (Int -> NameState -> NameState)
537 -> StateT NameState m Text
538getFreshSuper name getter setter =
539 do index <- State.gets getter
540 taken <- State.gets _taken
541 let (uniqueName, newIndex) = getFreshSuperHelp name index taken
542 State.modify (setter newIndex)
543 return uniqueName
546getFreshSuperHelp :: Text -> Int -> TakenNames -> (Text, Int)
547getFreshSuperHelp name index taken =
548 let
549 newName =
550 if index <= 0 then name else name <> Text.pack (show index)
551 in
552 if Map.member newName taken then
553 getFreshSuperHelp name (index + 1) taken
555 else
556 (newName, index + 1)
560-- GET ALL VARIABLE NAMES
563getVarNames :: Variable -> TakenNames -> IO TakenNames
564getVarNames var takenNames =
565 do (Descriptor content rank mark copy) <- UF.descriptor var
566 if mark == getVarNamesMark
567 then return takenNames
568 else
569 do UF.setDescriptor var (Descriptor content rank getVarNamesMark copy)
570 case content of
571 Error _ ->
572 return takenNames
574 FlexVar maybeName ->
575 case maybeName of
576 Nothing ->
577 return takenNames
579 Just name ->
580 addName 0 name var (FlexVar . Just) takenNames
582 FlexSuper super maybeName ->
583 case maybeName of
584 Nothing ->
585 return takenNames
587 Just name ->
588 addName 0 name var (FlexSuper super . Just) takenNames
590 RigidVar name ->
591 addName 0 name var RigidVar takenNames
593 RigidSuper super name ->
594 addName 0 name var (RigidSuper super) takenNames
596 Alias _ _ args _ ->
597 foldrM getVarNames takenNames (map snd args)
599 Structure flatType ->
600 case flatType of
601 App1 _ _ args ->
602 foldrM getVarNames takenNames args
604 Fun1 arg body ->
605 getVarNames arg =<< getVarNames body takenNames
607 EmptyRecord1 ->
608 return takenNames
610 Record1 fields extension ->
611 getVarNames extension =<<
612 foldrM getVarNames takenNames (Map.elems fields)
614 Unit1 ->
615 return takenNames
617 Tuple1 a b Nothing ->
618 getVarNames a =<< getVarNames b takenNames
620 Tuple1 a b (Just c) ->
621 getVarNames a =<< getVarNames b =<< getVarNames c takenNames
625-- REGISTER NAME / RENAME DUPLICATES
628addName :: Int -> N.Name -> Variable -> (N.Name -> Content) -> TakenNames -> IO TakenNames
629addName index givenName var makeContent takenNames =
630 let
631 indexedName =
632 if index <= 0 then
633 givenName
634 else if Char.isDigit (Text.last givenName) then
635 givenName <> Text.pack ('_' : show index)
636 else
637 givenName <> Text.pack (show index)
638 in
639 case Map.lookup indexedName takenNames of
640 Nothing ->
641 do if indexedName == givenName then return () else
642 UF.modifyDescriptor var $ \(Descriptor _ rank mark copy) ->
643 Descriptor (makeContent indexedName) rank mark copy
644 return $ Map.insert indexedName var takenNames
646 Just otherVar ->
647 do same <- UF.equivalent var otherVar
648 if same
649 then return takenNames
650 else addName (index + 1) givenName var makeContent takenNames