git.iko.soy/elk
on fcbda99 help sign in
elk/src/Type/Type.hs
527 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 qualified Data.Map.Strict as Map
29import Data.Monoid ((<>))
30import qualified Data.Text as Text
31import Data.Text (Text)
32import Data.Word (Word32)
34import qualified AST.Type as T
35import qualified AST.Variable as Var
36import qualified Type.UnionFind as UF
40-- TYPE PRIMITIVES
43type Variable =
44 UF.Point Descriptor
47data FlatType
48 = App1 Var.Canonical [Variable]
49 | Fun1 Variable Variable
50 | EmptyRecord1
51 | Record1 (Map.Map Text Variable) Variable
54data Type
55 = PlaceHolder Text
56 | AliasN Var.Canonical [(Text, Type)] Type
57 | VarN Variable
58 | AppN Var.Canonical [Type]
59 | FunN Type Type
60 | EmptyRecordN
61 | RecordN (Map.Map Text Type) Type
65-- DESCRIPTORS
68data Descriptor =
69 Descriptor
70 { _content :: Content
71 , _rank :: Int
72 , _mark :: Mark
73 , _copy :: Maybe Variable
74 }
77data Content
78 = FlexVar (Maybe Text)
79 | FlexSuper T.Super (Maybe Text)
80 | RigidVar Text
81 | RigidSuper T.Super Text
82 | Structure FlatType
83 | Alias Var.Canonical [(Text,Variable)] Variable
84 | Error Text
87makeDescriptor :: Content -> Descriptor
88makeDescriptor content =
89 Descriptor content noRank noMark Nothing
93-- RANKS
96noRank :: Int
97noRank =
98 0
101outermostRank :: Int
102outermostRank =
103 1
107-- MARKS
110newtype Mark = Mark Word32
111 deriving (Eq, Ord)
114noMark :: Mark
115noMark =
116 Mark 2
119occursMark :: Mark
120occursMark =
121 Mark 1
124getVarNamesMark :: Mark
125getVarNamesMark =
126 Mark 0
129{-# INLINE nextMark #-}
130nextMark :: Mark -> Mark
131nextMark (Mark mark) =
132 Mark (mark + 1)
136-- TYPE HELPERS
139infixr 9 ==>
142{-# INLINE (==>) #-}
143(==>) :: Type -> Type -> Type
144(==>) =
145 FunN
148{-# NOINLINE float #-}
149float :: Type
150float =
151 AppN Var.float []
154{-# NOINLINE char #-}
155char :: Type
156char =
157 AppN Var.char []
160{-# NOINLINE string #-}
161string :: Type
162string =
163 AppN Var.string []
166{-# NOINLINE bool #-}
167bool :: Type
168bool =
169 AppN Var.bool []
173-- MAKE FLEX VARIABLES
176mkFlexVar :: IO Variable
177mkFlexVar =
178 UF.fresh flexVarDescriptor
181{-# NOINLINE flexVarDescriptor #-}
182flexVarDescriptor :: Descriptor
183flexVarDescriptor =
184 makeDescriptor unnamedFlexVar
187{-# NOINLINE unnamedFlexVar #-}
188unnamedFlexVar :: Content
189unnamedFlexVar =
190 FlexVar Nothing
194-- MAKE FLEX NUMBERS
197mkFlexNumber :: IO Variable
198mkFlexNumber =
199 UF.fresh flexNumberDescriptor
202{-# NOINLINE flexNumberDescriptor #-}
203flexNumberDescriptor :: Descriptor
204flexNumberDescriptor =
205 makeDescriptor (unnamedFlexSuper T.Number)
208unnamedFlexSuper :: T.Super -> Content
209unnamedFlexSuper super =
210 FlexSuper super Nothing
214-- MAKE NAMED VARIABLES
217nameToFlex :: Text -> IO Variable
218nameToFlex name =
219 UF.fresh $ makeDescriptor $
220 maybe FlexVar FlexSuper (toSuper name) (Just name)
223nameToRigid :: Text -> IO Variable
224nameToRigid name =
225 UF.fresh $ makeDescriptor $
226 maybe RigidVar RigidSuper (toSuper name) name
229toSuper :: Text -> Maybe T.Super
230toSuper name =
231 if Text.isPrefixOf "number" name then
232 Just T.Number
234 else if Text.isPrefixOf "comparable" name then
235 Just T.Comparable
237 else if Text.isPrefixOf "appendable" name then
238 Just T.Appendable
240 else if Text.isPrefixOf "compappend" name then
241 Just T.CompAppend
243 else
244 Nothing
248-- CONVERT TO SOURCE TYPES
251-- TODO: Attach resulting type to the descriptor so that you
252-- never have to do extra work, particularly nice for aliased types
253toSrcType :: Variable -> IO T.Canonical
254toSrcType variable =
255 do takenNames <- State.execStateT (getVarNames variable) Map.empty
256 State.evalStateT (variableToSrcType variable) (makeNameState takenNames)
259variableToSrcType :: Variable -> StateT NameState IO T.Canonical
260variableToSrcType variable =
261 do descriptor <- liftIO $ UF.descriptor variable
262 let mark = _mark descriptor
263 if mark == occursMark
264 then
265 return (T.Var "∞")
267 else
268 do liftIO $ UF.modifyDescriptor variable (\desc -> desc { _mark = occursMark })
269 srcType <- contentToSrcType variable (_content descriptor)
270 liftIO $ UF.modifyDescriptor variable (\desc -> desc { _mark = mark })
271 return srcType
274contentToSrcType :: Variable -> Content -> StateT NameState IO T.Canonical
275contentToSrcType variable content =
276 case content of
277 Structure term ->
278 termToSrcType term
280 FlexVar maybeName ->
281 case maybeName of
282 Just name ->
283 return (T.Var name)
285 Nothing ->
286 do name <- getFreshVarName
287 liftIO $ UF.modifyDescriptor variable (\desc -> desc { _content = FlexVar (Just name) })
288 return (T.Var name)
290 FlexSuper super maybeName ->
291 case maybeName of
292 Just name ->
293 return (T.Var name)
295 Nothing ->
296 do name <- getFreshSuperName super
297 liftIO $ UF.modifyDescriptor variable (\desc -> desc { _content = FlexSuper super (Just name) })
298 return (T.Var name)
300 RigidVar name ->
301 return (T.Var name)
303 RigidSuper _ name ->
304 return (T.Var name)
306 Alias name args realVariable ->
307 do srcArgs <- traverse (traverse variableToSrcType) args
308 srcType <- variableToSrcType realVariable
309 return (T.Aliased name srcArgs (T.Filled srcType))
311 Error name ->
312 return (T.Var name)
315termToSrcType :: FlatType -> StateT NameState IO T.Canonical
316termToSrcType term =
317 case term of
318 App1 name args ->
319 T.Type name <$> traverse variableToSrcType args
321 Fun1 a b ->
322 T.Lambda
323 <$> variableToSrcType a
324 <*> variableToSrcType b
326 EmptyRecord1 ->
327 return $ T.Record [] Nothing
329 Record1 fields extension ->
330 do srcFields <- Map.toList <$> traverse variableToSrcType fields
331 srcExt <- T.iteratedDealias <$> variableToSrcType extension
332 return $
333 case srcExt of
334 T.Record subFields subExt ->
335 T.Record (subFields ++ srcFields) subExt
337 T.Var _ ->
338 T.Record srcFields (Just srcExt)
340 _ ->
341 error "Used toSrcType on a type that is not well-formed"
345-- MANAGE FRESH VARIABLE NAMES
348data NameState =
349 NameState
350 { _taken :: TakenNames
351 , _normals :: Int
352 , _numbers :: Int
353 , _comparables :: Int
354 , _appendables :: Int
355 , _compAppends :: Int
356 }
359type TakenNames = Map.Map Text Variable
362makeNameState :: TakenNames -> NameState
363makeNameState taken =
364 NameState taken 0 0 0 0 0
367getFreshVarName :: (Monad m) => StateT NameState m Text
368getFreshVarName =
369 do index <- State.gets _normals
370 taken <- State.gets _taken
371 let (uniqueName, newIndex) = getFreshNormal index taken
372 State.modify (\state -> state { _normals = newIndex })
373 return uniqueName
376getFreshSuperName :: (Monad m) => T.Super -> StateT NameState m Text
377getFreshSuperName super =
378 case super of
379 T.Number ->
380 getFreshSuper "number" _numbers (\index state -> state { _numbers = index })
382 T.Comparable ->
383 getFreshSuper "comparable" _comparables (\index state -> state { _comparables = index })
385 T.Appendable ->
386 getFreshSuper "appendable" _appendables (\index state -> state { _appendables = index })
388 T.CompAppend ->
389 getFreshSuper "compappend" _compAppends (\index state -> state { _compAppends = index })
392getFreshNormal :: Int -> TakenNames -> (Text, Int)
393getFreshNormal index taken =
394 let
395 (postfix, letter) =
396 quotRem index 26
398 character =
399 Char.chr (97 + letter)
401 name =
402 Text.pack (if postfix <= 0 then [character] else character : show postfix)
403 in
404 if Map.member name taken then
405 getFreshNormal (index + 1) taken
407 else
408 (name, index + 1)
411getFreshSuper
412 :: (Monad m)
413 => Text
414 -> (NameState -> Int)
415 -> (Int -> NameState -> NameState)
416 -> StateT NameState m Text
417getFreshSuper name getter setter =
418 do index <- State.gets getter
419 taken <- State.gets _taken
420 let (uniqueName, newIndex) = getFreshSuperHelp name index taken
421 State.modify (setter newIndex)
422 return uniqueName
425getFreshSuperHelp :: Text -> Int -> TakenNames -> (Text, Int)
426getFreshSuperHelp name index taken =
427 let
428 newName =
429 if index <= 0 then name else name <> Text.pack (show index)
430 in
431 if Map.member newName taken then
432 getFreshSuperHelp name (index + 1) taken
434 else
435 (newName, index + 1)
439-- GET ALL VARIABLE NAMES
442getVarNames :: Variable -> StateT TakenNames IO ()
443getVarNames var =
444 do (Descriptor content rank mark copy) <- liftIO $ UF.descriptor var
445 if mark == getVarNamesMark then return () else
446 do liftIO $ UF.setDescriptor var (Descriptor content rank getVarNamesMark copy)
447 case content of
448 Error _ ->
449 return ()
451 FlexVar maybeName ->
452 case maybeName of
453 Nothing ->
454 return ()
456 Just name ->
457 registerName name var (FlexVar . Just)
459 FlexSuper super maybeName ->
460 case maybeName of
461 Nothing ->
462 return ()
464 Just name ->
465 registerName name var (FlexSuper super . Just)
467 RigidVar name ->
468 registerName name var RigidVar
470 RigidSuper super name ->
471 registerName name var (RigidSuper super)
473 Alias _ args realVar ->
474 do mapM_ (getVarNames . snd) args
475 getVarNames realVar
477 Structure (App1 _ args) ->
478 mapM_ getVarNames args
480 Structure (Fun1 arg body) ->
481 do getVarNames arg
482 getVarNames body
484 Structure EmptyRecord1 ->
485 return ()
487 Structure (Record1 fields extension) ->
488 do mapM_ getVarNames fields
489 getVarNames extension
493-- REGISTER NAME / RENAME DUPLICATES
496registerName :: Text -> Variable -> (Text -> Content) -> StateT TakenNames IO ()
497registerName givenName var makeContent =
498 if Text.null givenName then
499 return ()
500 else
501 do takenNames <- State.get
502 State.put =<< liftIO (checkName 0 givenName var makeContent takenNames)
505checkName :: Int -> Text -> Variable -> (Text -> Content) -> TakenNames -> IO TakenNames
506checkName index givenName var makeContent takenNames =
507 let
508 indexedName =
509 if index <= 0 then
510 givenName
511 else if Char.isDigit (Text.last givenName) then
512 givenName <> Text.pack ('_' : show index)
513 else
514 givenName <> Text.pack (show index)
515 in
516 case Map.lookup indexedName takenNames of
517 Nothing ->
518 do if indexedName == givenName then return () else
519 UF.modifyDescriptor var $ \(Descriptor _ rank mark copy) ->
520 Descriptor (makeContent indexedName) rank mark copy
521 return $ Map.insert indexedName var takenNames
523 Just otherVar ->
524 do same <- UF.equivalent var otherVar
525 if same
526 then return takenNames
527 else checkName (index + 1) givenName var makeContent takenNames