git.iko.soy/elk
on 3e23ef2 help sign in
elk/src/Type/Type.hs
476 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 , Super(..)
11 , noRank
12 , outermostRank
13 , noMark
14 , initialMark
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)
32import qualified AST.Type as T
33import qualified AST.Variable as Var
34import qualified Type.UnionFind as UF
38-- TYPE PRIMITIVES
41type Variable =
42 UF.Point Descriptor
45data FlatType
46 = App1 Var.Canonical [Variable]
47 | Fun1 Variable Variable
48 | EmptyRecord1
49 | Record1 (Map.Map Text Variable) Variable
52data Type
53 = PlaceHolder Text
54 | AliasN Var.Canonical [(Text, Type)] Type
55 | VarN Variable
56 | AppN Var.Canonical [Type]
57 | FunN Type Type
58 | EmptyRecordN
59 | RecordN (Map.Map Text Type) Type
63-- DESCRIPTORS
66data Descriptor =
67 Descriptor
68 { _content :: Content
69 , _rank :: Int
70 , _mark :: Int
71 , _copy :: Maybe Variable
72 }
75data Content
76 = Structure FlatType
77 | Var Flex (Maybe Super) (Maybe Text)
78 | Alias Var.Canonical [(Text,Variable)] Variable
79 | Error Text
82makeDescriptor :: Content -> Descriptor
83makeDescriptor content =
84 Descriptor content noRank noMark Nothing
87data Flex
88 = Rigid
89 | Flex
92data Super
93 = Number
94 | Comparable
95 | Appendable
96 | CompAppend
97 deriving (Eq)
100noRank :: Int
101noRank = 0
104outermostRank :: Int
105outermostRank = 1
108noMark :: Int
109noMark = 2
112initialMark :: Int
113initialMark = 3
116occursMark :: Int
117occursMark =
118 1
121getVarNamesMark :: Int
122getVarNamesMark =
123 0
127-- TYPE HELPERS
130infixr 9 ==>
133{-# INLINE (==>) #-}
134(==>) :: Type -> Type -> Type
135(==>) =
136 FunN
139{-# NOINLINE float #-}
140float :: Type
141float =
142 AppN Var.float []
145{-# NOINLINE char #-}
146char :: Type
147char =
148 AppN Var.char []
151{-# NOINLINE string #-}
152string :: Type
153string =
154 AppN Var.string []
157{-# NOINLINE bool #-}
158bool :: Type
159bool =
160 AppN Var.bool []
164-- MAKE FLEX VARIABLES
167mkFlexVar :: IO Variable
168mkFlexVar =
169 UF.fresh flexVarDescriptor
172{-# NOINLINE flexVarDescriptor #-}
173flexVarDescriptor :: Descriptor
174flexVarDescriptor =
175 makeDescriptor unnamedFlexVar
179{-# NOINLINE unnamedFlexVar #-}
180unnamedFlexVar :: Content
181unnamedFlexVar =
182 Var Flex Nothing Nothing
186-- MAKE FLEX NUMBERS
189mkFlexNumber :: IO Variable
190mkFlexNumber =
191 UF.fresh flexNumberDescriptor
194{-# NOINLINE flexNumberDescriptor #-}
195flexNumberDescriptor :: Descriptor
196flexNumberDescriptor =
197 makeDescriptor (unnamedFlexSuper Number)
200unnamedFlexSuper :: Super -> Content
201unnamedFlexSuper super =
202 Var Flex (Just super) Nothing
206-- MAKE NAMED FLEX VARIABLES
209mkNamedVar :: Flex -> Text -> IO Variable
210mkNamedVar flex name =
211 UF.fresh $ makeDescriptor $ Var flex (toSuper name) (Just name)
214toSuper :: Text -> Maybe Super
215toSuper name =
216 if Text.isPrefixOf "number" name then
217 Just Number
219 else if Text.isPrefixOf "comparable" name then
220 Just Comparable
222 else if Text.isPrefixOf "appendable" name then
223 Just Appendable
225 else if Text.isPrefixOf "compappend" name then
226 Just CompAppend
228 else
229 Nothing
233-- CONVERT TO SOURCE TYPES
236-- TODO: Attach resulting type to the descriptor so that you
237-- never have to do extra work, particularly nice for aliased types
238toSrcType :: Variable -> IO T.Canonical
239toSrcType variable =
240 do takenNames <- State.execStateT (getVarNames variable) Map.empty
241 State.evalStateT (variableToSrcType variable) (makeNameState takenNames)
244variableToSrcType :: Variable -> StateT NameState IO T.Canonical
245variableToSrcType variable =
246 do descriptor <- liftIO $ UF.descriptor variable
247 let mark = _mark descriptor
248 if mark == occursMark
249 then
250 return (T.Var "∞")
252 else
253 do liftIO $ UF.modifyDescriptor variable (\desc -> desc { _mark = occursMark })
254 srcType <- contentToSrcType variable (_content descriptor)
255 liftIO $ UF.modifyDescriptor variable (\desc -> desc { _mark = mark })
256 return srcType
259contentToSrcType :: Variable -> Content -> StateT NameState IO T.Canonical
260contentToSrcType variable content =
261 case content of
262 Structure term ->
263 termToSrcType term
265 Var _ _ (Just name) ->
266 return (T.Var name)
268 Var flex maybeSuper Nothing ->
269 do freshName <- getFreshName maybeSuper
270 liftIO $ UF.modifyDescriptor variable $ \desc ->
271 desc { _content = Var flex maybeSuper (Just freshName) }
272 return (T.Var freshName)
274 Alias name args realVariable ->
275 do srcArgs <- traverse (traverse variableToSrcType) args
276 srcType <- variableToSrcType realVariable
277 return (T.Aliased name srcArgs (T.Filled srcType))
279 Error name ->
280 return (T.Var name)
283termToSrcType :: FlatType -> StateT NameState IO T.Canonical
284termToSrcType term =
285 case term of
286 App1 name args ->
287 T.Type name <$> traverse variableToSrcType args
289 Fun1 a b ->
290 T.Lambda
291 <$> variableToSrcType a
292 <*> variableToSrcType b
294 EmptyRecord1 ->
295 return $ T.Record [] Nothing
297 Record1 fields extension ->
298 do srcFields <- Map.toList <$> traverse variableToSrcType fields
299 srcExt <- T.iteratedDealias <$> variableToSrcType extension
300 return $
301 case srcExt of
302 T.Record subFields subExt ->
303 T.Record (subFields ++ srcFields) subExt
305 T.Var _ ->
306 T.Record srcFields (Just srcExt)
308 _ ->
309 error "Used toSrcType on a type that is not well-formed"
313-- MANAGE FRESH VARIABLE NAMES
316data NameState =
317 NameState
318 { _taken :: TakenNames
319 , _normals :: Int
320 , _numbers :: Int
321 , _comparables :: Int
322 , _appendables :: Int
323 , _compAppends :: Int
324 }
327type TakenNames = Map.Map Text Variable
330makeNameState :: TakenNames -> NameState
331makeNameState taken =
332 NameState taken 0 0 0 0 0
335getFreshName :: (Monad m) => Maybe Super -> StateT NameState m Text
336getFreshName maybeSuper =
337 case maybeSuper of
338 Nothing ->
339 do index <- State.gets _normals
340 taken <- State.gets _taken
341 let (uniqueName, newIndex) = getFreshNormal index taken
342 State.modify (\state -> state { _normals = newIndex })
343 return uniqueName
345 Just Number ->
346 getFreshSuper "number" _numbers (\index state -> state { _numbers = index })
348 Just Comparable ->
349 getFreshSuper "comparable" _comparables (\index state -> state { _comparables = index })
351 Just Appendable ->
352 getFreshSuper "appendable" _appendables (\index state -> state { _appendables = index })
354 Just CompAppend ->
355 getFreshSuper "compappend" _compAppends (\index state -> state { _compAppends = index })
358getFreshNormal :: Int -> TakenNames -> (Text, Int)
359getFreshNormal index taken =
360 let
361 (postfix, letter) =
362 quotRem index 26
364 character =
365 Char.chr (97 + letter)
367 name =
368 Text.pack (if postfix <= 0 then [character] else character : show postfix)
369 in
370 if Map.member name taken then
371 getFreshNormal (index + 1) taken
373 else
374 (name, index + 1)
377getFreshSuper
378 :: (Monad m)
379 => Text
380 -> (NameState -> Int)
381 -> (Int -> NameState -> NameState)
382 -> StateT NameState m Text
383getFreshSuper name getter setter =
384 do index <- State.gets getter
385 taken <- State.gets _taken
386 let (uniqueName, newIndex) = getFreshSuperHelp name index taken
387 State.modify (setter newIndex)
388 return uniqueName
391getFreshSuperHelp :: Text -> Int -> TakenNames -> (Text, Int)
392getFreshSuperHelp name index taken =
393 let
394 newName =
395 if index <= 0 then name else name <> Text.pack (show index)
396 in
397 if Map.member newName taken then
398 getFreshSuperHelp name (index + 1) taken
400 else
401 (newName, index + 1)
405-- GET ALL VARIABLE NAMES
408getVarNames :: Variable -> StateT TakenNames IO ()
409getVarNames var =
410 do desc <- liftIO $ UF.descriptor var
411 case _mark desc == getVarNamesMark of
412 True ->
413 return ()
415 False ->
416 do liftIO $ UF.setDescriptor var (desc { _mark = getVarNamesMark })
417 case _content desc of
418 Error _ ->
419 return ()
421 Var _ _ Nothing ->
422 return ()
424 Var flex maybeSuper (Just name) ->
425 do oldTaken <- State.get
426 newTaken <- liftIO $ addVarName 0 name var flex maybeSuper oldTaken
427 State.put newTaken
429 Alias _ args realVar ->
430 do mapM_ (getVarNames . snd) args
431 getVarNames realVar
433 Structure (App1 _ args) ->
434 mapM_ getVarNames args
436 Structure (Fun1 arg body) ->
437 do getVarNames arg
438 getVarNames body
440 Structure EmptyRecord1 ->
441 return ()
443 Structure (Record1 fields extension) ->
444 do mapM_ getVarNames fields
445 getVarNames extension
448addVarName :: Int -> Text -> Variable -> Flex -> Maybe Super -> TakenNames -> IO TakenNames
449addVarName index givenName var flex maybeSuper taken =
450 let
451 name =
452 makeIndexedName givenName index
453 in
454 case Map.lookup name taken of
455 Nothing ->
456 do when (name /= givenName) $ UF.modifyDescriptor var $ \desc ->
457 desc { _content = Var flex maybeSuper (Just name) }
458 return $ Map.insert name var taken
460 Just otherVar ->
461 do same <- UF.equivalent var otherVar
462 if same
463 then return taken
464 else addVarName (index + 1) givenName var flex maybeSuper taken
467makeIndexedName :: Text -> Int -> Text
468makeIndexedName name index =
469 if index <= 0 then
470 name
472 else if Char.isDigit (Text.last name) then
473 name <> Text.pack ('_' : show index)
475 else
476 name <> Text.pack (show index)