git.iko.soy/elk
on 07f61dc help sign in
elk/src/Type/Type.hs
652 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 qualified Data.Map.Strict as Map
31import Data.Map.Strict ((!))
32import Data.Monoid ((<>))
33import qualified Data.Text as Text
34import Data.Text (Text)
35import Data.Word (Word32)
37import qualified AST.Module.Name as ModuleName
38import qualified AST.Type as T
39import qualified Elm.Name as N
40import qualified Type.UnionFind as UF
44-- TYPE PRIMITIVES
47type Variable =
48 UF.Point Descriptor
51data FlatType
52 = App1 ModuleName.Canonical N.Name [Variable]
53 | Fun1 Variable Variable
54 | EmptyRecord1
55 | Record1 (Map.Map Text Variable) Variable
56 | Unit1
57 | Tuple1 Variable Variable [Variable]
60data Type
61 = PlaceHolder Text
62 | AliasN ModuleName.Canonical N.Name [(Text, Type)] Type
63 | VarN Variable
64 | AppN ModuleName.Canonical N.Name [Type]
65 | FunN Type Type
66 | EmptyRecordN
67 | RecordN (Map.Map Text Type) Type
68 | UnitN
69 | TupleN Type Type [Type]
73-- DESCRIPTORS
76data Descriptor =
77 Descriptor
78 { _content :: Content
79 , _rank :: Int
80 , _mark :: Mark
81 , _copy :: Maybe Variable
82 }
85data Content
86 = FlexVar (Maybe Text)
87 | FlexSuper T.Super (Maybe Text)
88 | RigidVar Text
89 | RigidSuper T.Super Text
90 | Structure FlatType
91 | Alias ModuleName.Canonical N.Name [(Text,Variable)] Variable
92 | Error Text
95makeDescriptor :: Content -> Descriptor
96makeDescriptor content =
97 Descriptor content noRank noMark Nothing
101-- RANKS
104noRank :: Int
105noRank =
106 0
109outermostRank :: Int
110outermostRank =
111 1
115-- MARKS
118newtype Mark = Mark Word32
119 deriving (Eq, Ord)
122noMark :: Mark
123noMark =
124 Mark 2
127occursMark :: Mark
128occursMark =
129 Mark 1
132getVarNamesMark :: Mark
133getVarNamesMark =
134 Mark 0
137{-# INLINE nextMark #-}
138nextMark :: Mark -> Mark
139nextMark (Mark mark) =
140 Mark (mark + 1)
144-- TYPE HELPERS
147infixr 9 ==>
150{-# INLINE (==>) #-}
151(==>) :: Type -> Type -> Type
152(==>) =
153 FunN
156{-# NOINLINE float #-}
157float :: Type
158float =
159 AppN ModuleName.basics "Float" []
162{-# NOINLINE char #-}
163char :: Type
164char =
165 AppN ModuleName.basics "Char" []
168{-# NOINLINE string #-}
169string :: Type
170string =
171 AppN ModuleName.basics "String" []
174{-# NOINLINE bool #-}
175bool :: Type
176bool =
177 AppN ModuleName.basics "Bool" []
181-- MAKE FLEX VARIABLES
184mkFlexVar :: IO Variable
185mkFlexVar =
186 UF.fresh flexVarDescriptor
189{-# NOINLINE flexVarDescriptor #-}
190flexVarDescriptor :: Descriptor
191flexVarDescriptor =
192 makeDescriptor unnamedFlexVar
195{-# NOINLINE unnamedFlexVar #-}
196unnamedFlexVar :: Content
197unnamedFlexVar =
198 FlexVar Nothing
202-- MAKE FLEX NUMBERS
205mkFlexNumber :: IO Variable
206mkFlexNumber =
207 UF.fresh flexNumberDescriptor
210{-# NOINLINE flexNumberDescriptor #-}
211flexNumberDescriptor :: Descriptor
212flexNumberDescriptor =
213 makeDescriptor (unnamedFlexSuper T.Number)
216unnamedFlexSuper :: T.Super -> Content
217unnamedFlexSuper super =
218 FlexSuper super Nothing
222-- MAKE NAMED VARIABLES
225nameToFlex :: N.Name -> IO Variable
226nameToFlex name =
227 UF.fresh $ makeDescriptor $
228 maybe FlexVar FlexSuper (toSuper name) (Just name)
231nameToRigid :: N.Name -> IO Variable
232nameToRigid name =
233 UF.fresh $ makeDescriptor $
234 maybe RigidVar RigidSuper (toSuper name) name
237toSuper :: N.Name -> Maybe T.Super
238toSuper name =
239 if Text.isPrefixOf "number" name then
240 Just T.Number
242 else if Text.isPrefixOf "comparable" name then
243 Just T.Comparable
245 else if Text.isPrefixOf "appendable" name then
246 Just T.Appendable
248 else if Text.isPrefixOf "compappend" name then
249 Just T.CompAppend
251 else
252 Nothing
256-- FROM SOURCE TYPES
259-- TODO should the freeFlexVars be ranked a certain way?
260-- How does this interact with `TS.flatten` exactly?
261fromFlexSrcType :: T.Canonical -> IO ( Type, Map.Map N.Name Variable )
262fromFlexSrcType srcType =
263 do let freeVars = gatherFreeVars srcType Map.empty
264 freeFlexVars <- Map.traverseWithKey (\name () -> nameToFlex name) freeVars
265 tipe <- fromSrcType (Map.map VarN freeFlexVars) srcType
266 return ( tipe, freeFlexVars )
269fromRigidSrcType :: T.Canonical -> IO ( Type, Map.Map N.Name Variable )
270fromRigidSrcType srcType =
271 do let freeVars = gatherFreeVars srcType Map.empty
272 freeRigidVars <- Map.traverseWithKey (\name () -> nameToRigid name) freeVars
273 tipe <- fromSrcType (Map.map VarN freeRigidVars) srcType
274 return ( tipe, freeRigidVars )
277gatherFreeVars :: T.Canonical -> Map.Map N.Name () -> Map.Map N.Name ()
278gatherFreeVars tipe dict =
279 case tipe of
280 T.Lambda arg result ->
281 gatherFreeVars result (gatherFreeVars arg dict)
283 T.Var name ->
284 Map.insert name () dict
286 T.Type _ _ args ->
287 foldr gatherFreeVars dict args
289 T.Aliased _ _ args _ ->
290 foldr gatherFreeVars dict (map snd args)
292 T.Tuple a b cs ->
293 gatherFreeVars a $ gatherFreeVars b $
294 foldr gatherFreeVars dict cs
296 T.Unit ->
297 dict
299 T.Record fields maybeExt ->
300 case maybeExt of
301 Nothing ->
302 Map.foldr gatherFreeVars dict fields
304 Just ext ->
305 Map.foldr gatherFreeVars (gatherFreeVars ext dict) fields
308fromSrcType :: Map.Map N.Name Type -> T.Canonical -> IO Type
309fromSrcType freeVars sourceType =
310 case sourceType of
311 T.Lambda arg result ->
312 FunN
313 <$> fromSrcType freeVars arg
314 <*> fromSrcType freeVars result
316 T.Var name ->
317 return (freeVars ! name)
319 T.Type home name args ->
320 AppN home name <$> traverse (fromSrcType freeVars) args
322 T.Aliased home name args aliasedType ->
323 do targs <- traverse (traverse (fromSrcType freeVars)) args
324 AliasN home name targs <$>
325 case aliasedType of
326 T.Filled realType ->
327 fromSrcType freeVars realType
329 T.Holey realType ->
330 fromSrcType (Map.fromList targs) realType
332 T.Tuple a b cs ->
333 TupleN
334 <$> fromSrcType freeVars a
335 <*> fromSrcType freeVars b
336 <*> traverse (fromSrcType freeVars) cs
338 T.Unit ->
339 return UnitN
341 T.Record fields maybeExt ->
342 RecordN
343 <$> traverse (fromSrcType freeVars) fields
344 <*>
345 case maybeExt of
346 Nothing ->
347 return EmptyRecordN
349 Just ext ->
350 fromSrcType freeVars ext
354-- TO SOURCE TYPES
357-- TODO: Attach resulting type to the descriptor so that you
358-- never have to do extra work, particularly nice for aliased types
359toSrcType :: Variable -> IO T.Canonical
360toSrcType variable =
361 do takenNames <- State.execStateT (getVarNames variable) Map.empty
362 State.evalStateT (variableToSrcType variable) (makeNameState takenNames)
365variableToSrcType :: Variable -> StateT NameState IO T.Canonical
366variableToSrcType variable =
367 do descriptor <- liftIO $ UF.descriptor variable
368 let mark = _mark descriptor
369 if mark == occursMark
370 then
371 return (T.Var "∞")
373 else
374 do liftIO $ UF.modifyDescriptor variable (\desc -> desc { _mark = occursMark })
375 srcType <- contentToSrcType variable (_content descriptor)
376 liftIO $ UF.modifyDescriptor variable (\desc -> desc { _mark = mark })
377 return srcType
380contentToSrcType :: Variable -> Content -> StateT NameState IO T.Canonical
381contentToSrcType variable content =
382 case content of
383 Structure term ->
384 termToSrcType term
386 FlexVar maybeName ->
387 case maybeName of
388 Just name ->
389 return (T.Var name)
391 Nothing ->
392 do name <- getFreshVarName
393 liftIO $ UF.modifyDescriptor variable (\desc -> desc { _content = FlexVar (Just name) })
394 return (T.Var name)
396 FlexSuper super maybeName ->
397 case maybeName of
398 Just name ->
399 return (T.Var name)
401 Nothing ->
402 do name <- getFreshSuperName super
403 liftIO $ UF.modifyDescriptor variable (\desc -> desc { _content = FlexSuper super (Just name) })
404 return (T.Var name)
406 RigidVar name ->
407 return (T.Var name)
409 RigidSuper _ name ->
410 return (T.Var name)
412 Alias home name args realVariable ->
413 do srcArgs <- traverse (traverse variableToSrcType) args
414 srcType <- variableToSrcType realVariable
415 return (T.Aliased home name srcArgs (T.Filled srcType))
417 Error name ->
418 return (T.Var name)
421termToSrcType :: FlatType -> StateT NameState IO T.Canonical
422termToSrcType term =
423 case term of
424 App1 home name args ->
425 T.Type home name <$> traverse variableToSrcType args
427 Fun1 a b ->
428 T.Lambda
429 <$> variableToSrcType a
430 <*> variableToSrcType b
432 EmptyRecord1 ->
433 return $ T.Record Map.empty Nothing
435 Record1 fields extension ->
436 do srcFields <- traverse variableToSrcType fields
437 srcExt <- T.iteratedDealias <$> variableToSrcType extension
438 return $
439 case srcExt of
440 T.Record subFields subExt ->
441 T.Record (Map.union subFields srcFields) subExt
443 T.Var _ ->
444 T.Record srcFields (Just srcExt)
446 _ ->
447 error "Used toSrcType on a type that is not well-formed"
449 Unit1 ->
450 return T.Unit
452 Tuple1 a b cs ->
453 T.Tuple
454 <$> variableToSrcType a
455 <*> variableToSrcType b
456 <*> traverse variableToSrcType cs
460-- MANAGE FRESH VARIABLE NAMES
463data NameState =
464 NameState
465 { _taken :: TakenNames
466 , _normals :: Int
467 , _numbers :: Int
468 , _comparables :: Int
469 , _appendables :: Int
470 , _compAppends :: Int
471 }
474type TakenNames = Map.Map Text Variable
477makeNameState :: TakenNames -> NameState
478makeNameState taken =
479 NameState taken 0 0 0 0 0
482getFreshVarName :: (Monad m) => StateT NameState m Text
483getFreshVarName =
484 do index <- State.gets _normals
485 taken <- State.gets _taken
486 let (uniqueName, newIndex) = getFreshNormal index taken
487 State.modify (\state -> state { _normals = newIndex })
488 return uniqueName
491getFreshSuperName :: (Monad m) => T.Super -> StateT NameState m Text
492getFreshSuperName super =
493 case super of
494 T.Number ->
495 getFreshSuper "number" _numbers (\index state -> state { _numbers = index })
497 T.Comparable ->
498 getFreshSuper "comparable" _comparables (\index state -> state { _comparables = index })
500 T.Appendable ->
501 getFreshSuper "appendable" _appendables (\index state -> state { _appendables = index })
503 T.CompAppend ->
504 getFreshSuper "compappend" _compAppends (\index state -> state { _compAppends = index })
507getFreshNormal :: Int -> TakenNames -> (Text, Int)
508getFreshNormal index taken =
509 let
510 (postfix, letter) =
511 quotRem index 26
513 character =
514 Char.chr (97 + letter)
516 name =
517 Text.pack (if postfix <= 0 then [character] else character : show postfix)
518 in
519 if Map.member name taken then
520 getFreshNormal (index + 1) taken
522 else
523 (name, index + 1)
526getFreshSuper
527 :: (Monad m)
528 => Text
529 -> (NameState -> Int)
530 -> (Int -> NameState -> NameState)
531 -> StateT NameState m Text
532getFreshSuper name getter setter =
533 do index <- State.gets getter
534 taken <- State.gets _taken
535 let (uniqueName, newIndex) = getFreshSuperHelp name index taken
536 State.modify (setter newIndex)
537 return uniqueName
540getFreshSuperHelp :: Text -> Int -> TakenNames -> (Text, Int)
541getFreshSuperHelp name index taken =
542 let
543 newName =
544 if index <= 0 then name else name <> Text.pack (show index)
545 in
546 if Map.member newName taken then
547 getFreshSuperHelp name (index + 1) taken
549 else
550 (newName, index + 1)
554-- GET ALL VARIABLE NAMES
557getVarNames :: Variable -> StateT TakenNames IO ()
558getVarNames var =
559 do (Descriptor content rank mark copy) <- liftIO $ UF.descriptor var
560 if mark == getVarNamesMark then return () else
561 do liftIO $ UF.setDescriptor var (Descriptor content rank getVarNamesMark copy)
562 case content of
563 Error _ ->
564 return ()
566 FlexVar maybeName ->
567 case maybeName of
568 Nothing ->
569 return ()
571 Just name ->
572 registerName name var (FlexVar . Just)
574 FlexSuper super maybeName ->
575 case maybeName of
576 Nothing ->
577 return ()
579 Just name ->
580 registerName name var (FlexSuper super . Just)
582 RigidVar name ->
583 registerName name var RigidVar
585 RigidSuper super name ->
586 registerName name var (RigidSuper super)
588 Alias _ _ args realVar ->
589 do mapM_ (getVarNames . snd) args
590 getVarNames realVar
592 Structure flatType ->
593 case flatType of
594 App1 _ _ args ->
595 mapM_ getVarNames args
597 Fun1 arg body ->
598 do getVarNames arg
599 getVarNames body
601 EmptyRecord1 ->
602 return ()
604 Record1 fields extension ->
605 do mapM_ getVarNames fields
606 getVarNames extension
608 Unit1 ->
609 return ()
611 Tuple1 a b cs ->
612 do getVarNames a
613 getVarNames b
614 mapM_ getVarNames cs
618-- REGISTER NAME / RENAME DUPLICATES
621registerName :: Text -> Variable -> (Text -> Content) -> StateT TakenNames IO ()
622registerName givenName var makeContent =
623 if Text.null givenName then
624 return ()
625 else
626 do takenNames <- State.get
627 State.put =<< liftIO (checkName 0 givenName var makeContent takenNames)
630checkName :: Int -> Text -> Variable -> (Text -> Content) -> TakenNames -> IO TakenNames
631checkName index givenName var makeContent takenNames =
632 let
633 indexedName =
634 if index <= 0 then
635 givenName
636 else if Char.isDigit (Text.last givenName) then
637 givenName <> Text.pack ('_' : show index)
638 else
639 givenName <> Text.pack (show index)
640 in
641 case Map.lookup indexedName takenNames of
642 Nothing ->
643 do if indexedName == givenName then return () else
644 UF.modifyDescriptor var $ \(Descriptor _ rank mark copy) ->
645 Descriptor (makeContent indexedName) rank mark copy
646 return $ Map.insert indexedName var takenNames
648 Just otherVar ->
649 do same <- UF.equivalent var otherVar
650 if same
651 then return takenNames
652 else checkName (index + 1) givenName var makeContent takenNames