git.iko.soy/elk
on a0fccd5 help sign in
elk/src/Type/Type.hs
484 lines 10 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 , Flex(..)
10 , noRank
11 , outermostRank
12 , Mark
13 , noMark
14 , nextMark
15 , (==>), float, char, string, bool
16 , mkFlexVar
17 , mkFlexNumber
18 , mkNamedVar
19 , toSrcType
20 )
21 where
23import Control.Monad (when)
24import Control.Monad.State.Strict (StateT, liftIO)
25import qualified Control.Monad.State.Strict as State
26import qualified Data.Char as Char
27import qualified Data.Map as Map
28import Data.Monoid ((<>))
29import qualified Data.Text as Text
30import Data.Text (Text)
31import Data.Word (Word32)
33import qualified AST.Type as T
34import qualified AST.Variable as Var
35import qualified Type.UnionFind as UF
39-- TYPE PRIMITIVES
42type Variable =
43 UF.Point Descriptor
46data FlatType
47 = App1 Var.Canonical [Variable]
48 | Fun1 Variable Variable
49 | EmptyRecord1
50 | Record1 (Map.Map Text Variable) Variable
53data Type
54 = PlaceHolder Text
55 | AliasN Var.Canonical [(Text, Type)] Type
56 | VarN Variable
57 | AppN Var.Canonical [Type]
58 | FunN Type Type
59 | EmptyRecordN
60 | RecordN (Map.Map Text Type) Type
64-- DESCRIPTORS
67data Descriptor =
68 Descriptor
69 { _content :: Content
70 , _rank :: Int
71 , _mark :: Mark
72 , _copy :: Maybe Variable
73 }
76data Content
77 = Structure FlatType
78 | Var Flex (Maybe T.Super) (Maybe Text)
79 | Alias Var.Canonical [(Text,Variable)] Variable
80 | Error Text
83makeDescriptor :: Content -> Descriptor
84makeDescriptor content =
85 Descriptor content noRank noMark Nothing
88data Flex
89 = Rigid
90 | Flex
94-- RANKS
97noRank :: Int
98noRank = 0
101outermostRank :: Int
102outermostRank = 1
106-- MARKS
109newtype Mark = Mark Word32
110 deriving (Eq, Ord)
113noMark :: Mark
114noMark =
115 Mark 2
118occursMark :: Mark
119occursMark =
120 Mark 1
123getVarNamesMark :: Mark
124getVarNamesMark =
125 Mark 0
128{-# INLINE nextMark #-}
129nextMark :: Mark -> Mark
130nextMark (Mark mark) =
131 Mark (mark + 1)
135-- TYPE HELPERS
138infixr 9 ==>
141{-# INLINE (==>) #-}
142(==>) :: Type -> Type -> Type
143(==>) =
144 FunN
147{-# NOINLINE float #-}
148float :: Type
149float =
150 AppN Var.float []
153{-# NOINLINE char #-}
154char :: Type
155char =
156 AppN Var.char []
159{-# NOINLINE string #-}
160string :: Type
161string =
162 AppN Var.string []
165{-# NOINLINE bool #-}
166bool :: Type
167bool =
168 AppN Var.bool []
172-- MAKE FLEX VARIABLES
175mkFlexVar :: IO Variable
176mkFlexVar =
177 UF.fresh flexVarDescriptor
180{-# NOINLINE flexVarDescriptor #-}
181flexVarDescriptor :: Descriptor
182flexVarDescriptor =
183 makeDescriptor unnamedFlexVar
187{-# NOINLINE unnamedFlexVar #-}
188unnamedFlexVar :: Content
189unnamedFlexVar =
190 Var Flex Nothing 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 Var Flex (Just super) Nothing
214-- MAKE NAMED FLEX VARIABLES
217mkNamedVar :: Flex -> Text -> IO Variable
218mkNamedVar flex name =
219 UF.fresh $ makeDescriptor $ Var flex (toSuper name) (Just name)
222toSuper :: Text -> Maybe T.Super
223toSuper name =
224 if Text.isPrefixOf "number" name then
225 Just T.Number
227 else if Text.isPrefixOf "comparable" name then
228 Just T.Comparable
230 else if Text.isPrefixOf "appendable" name then
231 Just T.Appendable
233 else if Text.isPrefixOf "compappend" name then
234 Just T.CompAppend
236 else
237 Nothing
241-- CONVERT TO SOURCE TYPES
244-- TODO: Attach resulting type to the descriptor so that you
245-- never have to do extra work, particularly nice for aliased types
246toSrcType :: Variable -> IO T.Canonical
247toSrcType variable =
248 do takenNames <- State.execStateT (getVarNames variable) Map.empty
249 State.evalStateT (variableToSrcType variable) (makeNameState takenNames)
252variableToSrcType :: Variable -> StateT NameState IO T.Canonical
253variableToSrcType variable =
254 do descriptor <- liftIO $ UF.descriptor variable
255 let mark = _mark descriptor
256 if mark == occursMark
257 then
258 return (T.Var "∞")
260 else
261 do liftIO $ UF.modifyDescriptor variable (\desc -> desc { _mark = occursMark })
262 srcType <- contentToSrcType variable (_content descriptor)
263 liftIO $ UF.modifyDescriptor variable (\desc -> desc { _mark = mark })
264 return srcType
267contentToSrcType :: Variable -> Content -> StateT NameState IO T.Canonical
268contentToSrcType variable content =
269 case content of
270 Structure term ->
271 termToSrcType term
273 Var _ _ (Just name) ->
274 return (T.Var name)
276 Var flex maybeSuper Nothing ->
277 do freshName <- getFreshName maybeSuper
278 liftIO $ UF.modifyDescriptor variable $ \desc ->
279 desc { _content = Var flex maybeSuper (Just freshName) }
280 return (T.Var freshName)
282 Alias name args realVariable ->
283 do srcArgs <- traverse (traverse variableToSrcType) args
284 srcType <- variableToSrcType realVariable
285 return (T.Aliased name srcArgs (T.Filled srcType))
287 Error name ->
288 return (T.Var name)
291termToSrcType :: FlatType -> StateT NameState IO T.Canonical
292termToSrcType term =
293 case term of
294 App1 name args ->
295 T.Type name <$> traverse variableToSrcType args
297 Fun1 a b ->
298 T.Lambda
299 <$> variableToSrcType a
300 <*> variableToSrcType b
302 EmptyRecord1 ->
303 return $ T.Record [] Nothing
305 Record1 fields extension ->
306 do srcFields <- Map.toList <$> traverse variableToSrcType fields
307 srcExt <- T.iteratedDealias <$> variableToSrcType extension
308 return $
309 case srcExt of
310 T.Record subFields subExt ->
311 T.Record (subFields ++ srcFields) subExt
313 T.Var _ ->
314 T.Record srcFields (Just srcExt)
316 _ ->
317 error "Used toSrcType on a type that is not well-formed"
321-- MANAGE FRESH VARIABLE NAMES
324data NameState =
325 NameState
326 { _taken :: TakenNames
327 , _normals :: Int
328 , _numbers :: Int
329 , _comparables :: Int
330 , _appendables :: Int
331 , _compAppends :: Int
332 }
335type TakenNames = Map.Map Text Variable
338makeNameState :: TakenNames -> NameState
339makeNameState taken =
340 NameState taken 0 0 0 0 0
343getFreshName :: (Monad m) => Maybe T.Super -> StateT NameState m Text
344getFreshName maybeSuper =
345 case maybeSuper of
346 Nothing ->
347 do index <- State.gets _normals
348 taken <- State.gets _taken
349 let (uniqueName, newIndex) = getFreshNormal index taken
350 State.modify (\state -> state { _normals = newIndex })
351 return uniqueName
353 Just T.Number ->
354 getFreshSuper "number" _numbers (\index state -> state { _numbers = index })
356 Just T.Comparable ->
357 getFreshSuper "comparable" _comparables (\index state -> state { _comparables = index })
359 Just T.Appendable ->
360 getFreshSuper "appendable" _appendables (\index state -> state { _appendables = index })
362 Just T.CompAppend ->
363 getFreshSuper "compappend" _compAppends (\index state -> state { _compAppends = index })
366getFreshNormal :: Int -> TakenNames -> (Text, Int)
367getFreshNormal index taken =
368 let
369 (postfix, letter) =
370 quotRem index 26
372 character =
373 Char.chr (97 + letter)
375 name =
376 Text.pack (if postfix <= 0 then [character] else character : show postfix)
377 in
378 if Map.member name taken then
379 getFreshNormal (index + 1) taken
381 else
382 (name, index + 1)
385getFreshSuper
386 :: (Monad m)
387 => Text
388 -> (NameState -> Int)
389 -> (Int -> NameState -> NameState)
390 -> StateT NameState m Text
391getFreshSuper name getter setter =
392 do index <- State.gets getter
393 taken <- State.gets _taken
394 let (uniqueName, newIndex) = getFreshSuperHelp name index taken
395 State.modify (setter newIndex)
396 return uniqueName
399getFreshSuperHelp :: Text -> Int -> TakenNames -> (Text, Int)
400getFreshSuperHelp name index taken =
401 let
402 newName =
403 if index <= 0 then name else name <> Text.pack (show index)
404 in
405 if Map.member newName taken then
406 getFreshSuperHelp name (index + 1) taken
408 else
409 (newName, index + 1)
413-- GET ALL VARIABLE NAMES
416getVarNames :: Variable -> StateT TakenNames IO ()
417getVarNames var =
418 do desc <- liftIO $ UF.descriptor var
419 case _mark desc == getVarNamesMark of
420 True ->
421 return ()
423 False ->
424 do liftIO $ UF.setDescriptor var (desc { _mark = getVarNamesMark })
425 case _content desc of
426 Error _ ->
427 return ()
429 Var _ _ Nothing ->
430 return ()
432 Var flex maybeSuper (Just name) ->
433 do oldTaken <- State.get
434 newTaken <- liftIO $ addVarName 0 name var flex maybeSuper oldTaken
435 State.put newTaken
437 Alias _ args realVar ->
438 do mapM_ (getVarNames . snd) args
439 getVarNames realVar
441 Structure (App1 _ args) ->
442 mapM_ getVarNames args
444 Structure (Fun1 arg body) ->
445 do getVarNames arg
446 getVarNames body
448 Structure EmptyRecord1 ->
449 return ()
451 Structure (Record1 fields extension) ->
452 do mapM_ getVarNames fields
453 getVarNames extension
456addVarName :: Int -> Text -> Variable -> Flex -> Maybe T.Super -> TakenNames -> IO TakenNames
457addVarName index givenName var flex maybeSuper taken =
458 let
459 name =
460 makeIndexedName givenName index
461 in
462 case Map.lookup name taken of
463 Nothing ->
464 do when (name /= givenName) $ UF.modifyDescriptor var $ \desc ->
465 desc { _content = Var flex maybeSuper (Just name) }
466 return $ Map.insert name var taken
468 Just otherVar ->
469 do same <- UF.equivalent var otherVar
470 if same
471 then return taken
472 else addVarName (index + 1) givenName var flex maybeSuper taken
475makeIndexedName :: Text -> Int -> Text
476makeIndexedName name index =
477 if index <= 0 then
478 name
480 else if Char.isDigit (Text.last name) then
481 name <> Text.pack ('_' : show index)
483 else
484 name <> Text.pack (show index)