git.iko.soy/elk
on 64038dc help sign in
elk/src/Type/Type.hs
544 lines 12 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 )
23 where
25import Control.Monad.State.Strict (StateT, liftIO)
26import qualified Control.Monad.State.Strict as State
27import qualified Data.Char as Char
28import Data.Foldable (foldrM)
29import qualified Data.Map.Strict as Map
30import Data.Monoid ((<>))
31import qualified Data.Text as Text
32import Data.Text (Text)
33import Data.Word (Word32)
35import qualified AST.Module.Name as ModuleName
36import qualified AST.Type as T
37import qualified Elm.Name as N
38import qualified Type.UnionFind as UF
42-- TYPE PRIMITIVES
45type Variable =
46 UF.Point Descriptor
49data FlatType
50 = App1 ModuleName.Canonical N.Name [Variable]
51 | Fun1 Variable Variable
52 | EmptyRecord1
53 | Record1 (Map.Map N.Name Variable) Variable
54 | Unit1
55 | Tuple1 Variable Variable (Maybe Variable)
58data Type
59 = PlaceHolder N.Name
60 | AliasN ModuleName.Canonical N.Name [(N.Name, Type)] Type
61 | VarN Variable
62 | AppN ModuleName.Canonical N.Name [Type]
63 | FunN Type Type
64 | EmptyRecordN
65 | RecordN (Map.Map N.Name Type) Type
66 | UnitN
67 | TupleN Type Type (Maybe Type)
71-- DESCRIPTORS
74data Descriptor =
75 Descriptor
76 { _content :: Content
77 , _rank :: Int
78 , _mark :: Mark
79 , _copy :: Maybe Variable
80 }
83data Content
84 = FlexVar (Maybe N.Name)
85 | FlexSuper T.Super (Maybe N.Name)
86 | RigidVar N.Name
87 | RigidSuper T.Super N.Name
88 | Structure FlatType
89 | Alias ModuleName.Canonical N.Name [(N.Name,Variable)] Variable
90 | Error Text
93makeDescriptor :: Content -> Descriptor
94makeDescriptor content =
95 Descriptor content noRank noMark Nothing
99-- RANKS
102noRank :: Int
103noRank =
104 0
107outermostRank :: Int
108outermostRank =
109 1
113-- MARKS
116newtype Mark = Mark Word32
117 deriving (Eq, Ord)
120noMark :: Mark
121noMark =
122 Mark 2
125occursMark :: Mark
126occursMark =
127 Mark 1
130getVarNamesMark :: Mark
131getVarNamesMark =
132 Mark 0
135{-# INLINE nextMark #-}
136nextMark :: Mark -> Mark
137nextMark (Mark mark) =
138 Mark (mark + 1)
142-- TYPE HELPERS
145infixr 9 ==>
148{-# INLINE (==>) #-}
149(==>) :: Type -> Type -> Type
150(==>) =
151 FunN
154{-# NOINLINE float #-}
155float :: Type
156float =
157 AppN ModuleName.basics "Float" []
160{-# NOINLINE char #-}
161char :: Type
162char =
163 AppN ModuleName.basics "Char" []
166{-# NOINLINE string #-}
167string :: Type
168string =
169 AppN ModuleName.basics "String" []
172{-# NOINLINE bool #-}
173bool :: Type
174bool =
175 AppN ModuleName.basics "Bool" []
179-- MAKE FLEX VARIABLES
182mkFlexVar :: IO Variable
183mkFlexVar =
184 UF.fresh flexVarDescriptor
187{-# NOINLINE flexVarDescriptor #-}
188flexVarDescriptor :: Descriptor
189flexVarDescriptor =
190 makeDescriptor unnamedFlexVar
193{-# NOINLINE unnamedFlexVar #-}
194unnamedFlexVar :: Content
195unnamedFlexVar =
196 FlexVar Nothing
200-- MAKE FLEX NUMBERS
203mkFlexNumber :: IO Variable
204mkFlexNumber =
205 UF.fresh flexNumberDescriptor
208{-# NOINLINE flexNumberDescriptor #-}
209flexNumberDescriptor :: Descriptor
210flexNumberDescriptor =
211 makeDescriptor (unnamedFlexSuper T.Number)
214unnamedFlexSuper :: T.Super -> Content
215unnamedFlexSuper super =
216 FlexSuper super Nothing
220-- MAKE NAMED VARIABLES
223nameToFlex :: N.Name -> IO Variable
224nameToFlex name =
225 UF.fresh $ makeDescriptor $
226 maybe FlexVar FlexSuper (toSuper name) (Just name)
229nameToRigid :: N.Name -> IO Variable
230nameToRigid name =
231 UF.fresh $ makeDescriptor $
232 maybe RigidVar RigidSuper (toSuper name) name
235toSuper :: N.Name -> Maybe T.Super
236toSuper name =
237 if Text.isPrefixOf "number" name then
238 Just T.Number
240 else if Text.isPrefixOf "comparable" name then
241 Just T.Comparable
243 else if Text.isPrefixOf "appendable" name then
244 Just T.Appendable
246 else if Text.isPrefixOf "compappend" name then
247 Just T.CompAppend
249 else
250 Nothing
254-- TO SOURCE TYPES
257-- TODO: Attach resulting type to the descriptor so that you
258-- never have to do extra work, particularly nice for aliased types
259toSrcType :: Variable -> IO T.Canonical
260toSrcType variable =
261 do takenNames <- getVarNames variable Map.empty
262 State.evalStateT (variableToSrcType variable) (makeNameState takenNames)
265variableToSrcType :: Variable -> StateT NameState IO T.Canonical
266variableToSrcType variable =
267 do descriptor <- liftIO $ UF.descriptor variable
268 let mark = _mark descriptor
269 if mark == occursMark
270 then
271 return (T.Var "∞")
273 else
274 do liftIO $ UF.modifyDescriptor variable (\desc -> desc { _mark = occursMark })
275 srcType <- contentToSrcType variable (_content descriptor)
276 liftIO $ UF.modifyDescriptor variable (\desc -> desc { _mark = mark })
277 return srcType
280contentToSrcType :: Variable -> Content -> StateT NameState IO T.Canonical
281contentToSrcType variable content =
282 case content of
283 Structure term ->
284 termToSrcType term
286 FlexVar maybeName ->
287 case maybeName of
288 Just name ->
289 return (T.Var name)
291 Nothing ->
292 do name <- getFreshVarName
293 liftIO $ UF.modifyDescriptor variable (\desc -> desc { _content = FlexVar (Just name) })
294 return (T.Var name)
296 FlexSuper super maybeName ->
297 case maybeName of
298 Just name ->
299 return (T.Var name)
301 Nothing ->
302 do name <- getFreshSuperName super
303 liftIO $ UF.modifyDescriptor variable (\desc -> desc { _content = FlexSuper super (Just name) })
304 return (T.Var name)
306 RigidVar name ->
307 return (T.Var name)
309 RigidSuper _ name ->
310 return (T.Var name)
312 Alias home name args realVariable ->
313 do srcArgs <- traverse (traverse variableToSrcType) args
314 srcType <- variableToSrcType realVariable
315 return (T.Aliased home name srcArgs (T.Filled srcType))
317 Error name ->
318 return (T.Var name)
321termToSrcType :: FlatType -> StateT NameState IO T.Canonical
322termToSrcType term =
323 case term of
324 App1 home name args ->
325 T.Type home name <$> traverse variableToSrcType args
327 Fun1 a b ->
328 T.Lambda
329 <$> variableToSrcType a
330 <*> variableToSrcType b
332 EmptyRecord1 ->
333 return $ T.Record Map.empty Nothing
335 Record1 fields extension ->
336 do srcFields <- traverse variableToSrcType fields
337 srcExt <- T.iteratedDealias <$> variableToSrcType extension
338 return $
339 case srcExt of
340 T.Record subFields subExt ->
341 T.Record (Map.union subFields srcFields) subExt
343 T.Var _ ->
344 T.Record srcFields (Just srcExt)
346 _ ->
347 error "Used toSrcType on a type that is not well-formed"
349 Unit1 ->
350 return T.Unit
352 Tuple1 a b maybeC ->
353 T.Tuple
354 <$> variableToSrcType a
355 <*> variableToSrcType b
356 <*> traverse variableToSrcType maybeC
360-- MANAGE FRESH VARIABLE NAMES
363data NameState =
364 NameState
365 { _taken :: TakenNames
366 , _normals :: Int
367 , _numbers :: Int
368 , _comparables :: Int
369 , _appendables :: Int
370 , _compAppends :: Int
371 }
374type TakenNames = Map.Map Text Variable
377makeNameState :: TakenNames -> NameState
378makeNameState taken =
379 NameState taken 0 0 0 0 0
382getFreshVarName :: (Monad m) => StateT NameState m Text
383getFreshVarName =
384 do index <- State.gets _normals
385 taken <- State.gets _taken
386 let (uniqueName, newIndex) = getFreshNormal index taken
387 State.modify (\state -> state { _normals = newIndex })
388 return uniqueName
391getFreshSuperName :: (Monad m) => T.Super -> StateT NameState m Text
392getFreshSuperName super =
393 case super of
394 T.Number ->
395 getFreshSuper "number" _numbers (\index state -> state { _numbers = index })
397 T.Comparable ->
398 getFreshSuper "comparable" _comparables (\index state -> state { _comparables = index })
400 T.Appendable ->
401 getFreshSuper "appendable" _appendables (\index state -> state { _appendables = index })
403 T.CompAppend ->
404 getFreshSuper "compappend" _compAppends (\index state -> state { _compAppends = index })
407getFreshNormal :: Int -> TakenNames -> (Text, Int)
408getFreshNormal index taken =
409 let
410 (postfix, letter) =
411 quotRem index 26
413 character =
414 Char.chr (97 + letter)
416 name =
417 Text.pack (if postfix <= 0 then [character] else character : show postfix)
418 in
419 if Map.member name taken then
420 getFreshNormal (index + 1) taken
422 else
423 (name, index + 1)
426getFreshSuper
427 :: (Monad m)
428 => Text
429 -> (NameState -> Int)
430 -> (Int -> NameState -> NameState)
431 -> StateT NameState m Text
432getFreshSuper name getter setter =
433 do index <- State.gets getter
434 taken <- State.gets _taken
435 let (uniqueName, newIndex) = getFreshSuperHelp name index taken
436 State.modify (setter newIndex)
437 return uniqueName
440getFreshSuperHelp :: Text -> Int -> TakenNames -> (Text, Int)
441getFreshSuperHelp name index taken =
442 let
443 newName =
444 if index <= 0 then name else name <> Text.pack (show index)
445 in
446 if Map.member newName taken then
447 getFreshSuperHelp name (index + 1) taken
449 else
450 (newName, index + 1)
454-- GET ALL VARIABLE NAMES
457getVarNames :: Variable -> TakenNames -> IO TakenNames
458getVarNames var takenNames =
459 do (Descriptor content rank mark copy) <- UF.descriptor var
460 if mark == getVarNamesMark
461 then return takenNames
462 else
463 do UF.setDescriptor var (Descriptor content rank getVarNamesMark copy)
464 case content of
465 Error _ ->
466 return takenNames
468 FlexVar maybeName ->
469 case maybeName of
470 Nothing ->
471 return takenNames
473 Just name ->
474 addName 0 name var (FlexVar . Just) takenNames
476 FlexSuper super maybeName ->
477 case maybeName of
478 Nothing ->
479 return takenNames
481 Just name ->
482 addName 0 name var (FlexSuper super . Just) takenNames
484 RigidVar name ->
485 addName 0 name var RigidVar takenNames
487 RigidSuper super name ->
488 addName 0 name var (RigidSuper super) takenNames
490 Alias _ _ args _ ->
491 foldrM getVarNames takenNames (map snd args)
493 Structure flatType ->
494 case flatType of
495 App1 _ _ args ->
496 foldrM getVarNames takenNames args
498 Fun1 arg body ->
499 getVarNames arg =<< getVarNames body takenNames
501 EmptyRecord1 ->
502 return takenNames
504 Record1 fields extension ->
505 getVarNames extension =<<
506 foldrM getVarNames takenNames (Map.elems fields)
508 Unit1 ->
509 return takenNames
511 Tuple1 a b Nothing ->
512 getVarNames a =<< getVarNames b takenNames
514 Tuple1 a b (Just c) ->
515 getVarNames a =<< getVarNames b =<< getVarNames c takenNames
519-- REGISTER NAME / RENAME DUPLICATES
522addName :: Int -> N.Name -> Variable -> (N.Name -> Content) -> TakenNames -> IO TakenNames
523addName index givenName var makeContent takenNames =
524 let
525 indexedName =
526 if index <= 0 then
527 givenName
528 else if Char.isDigit (Text.last givenName) then
529 givenName <> Text.pack ('_' : show index)
530 else
531 givenName <> Text.pack (show index)
532 in
533 case Map.lookup indexedName takenNames of
534 Nothing ->
535 do if indexedName == givenName then return () else
536 UF.modifyDescriptor var $ \(Descriptor _ rank mark copy) ->
537 Descriptor (makeContent indexedName) rank mark copy
538 return $ Map.insert indexedName var takenNames
540 Just otherVar ->
541 do same <- UF.equivalent var otherVar
542 if same
543 then return takenNames
544 else addName (index + 1) givenName var makeContent takenNames