git.iko.soy/elk
on b02b4aa help sign in
elk/src/Type/Type.hs
416 lines 9.5 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 , (==>)
16 , mkVar
17 , mkNamedVar
18 , toSrcType
19 )
20 where
22import Control.Monad (when)
23import Control.Monad.State.Strict (StateT, liftIO)
24import qualified Control.Monad.State.Strict as State
25import qualified Data.Char as Char
26import qualified Data.Map as Map
27import Data.Monoid ((<>))
28import qualified Data.Text as Text
29import Data.Text (Text)
31import qualified AST.Type as T
32import qualified AST.Variable as Var
33import qualified Type.UnionFind as UF
37-- TYPE PRIMITIVES
40type Variable =
41 UF.Point Descriptor
44data FlatType
45 = App1 Var.Canonical [Variable]
46 | Fun1 Variable Variable
47 | EmptyRecord1
48 | Record1 (Map.Map Text Variable) Variable
51data Type
52 = PlaceHolder Text
53 | AliasN Var.Canonical [(Text, Type)] Type
54 | VarN Variable
55 | AppN Var.Canonical [Type]
56 | FunN Type Type
57 | EmptyRecordN
58 | RecordN (Map.Map Text Type) Type
62-- DESCRIPTORS
65data Descriptor =
66 Descriptor
67 { _content :: Content
68 , _rank :: Int
69 , _mark :: Int
70 , _copy :: Maybe Variable
71 }
74data Content
75 = Structure FlatType
76 | Var Flex (Maybe Super) (Maybe Text)
77 | Alias Var.Canonical [(Text,Variable)] Variable
78 | Error Text
81data Flex
82 = Rigid
83 | Flex
86data Super
87 = Number
88 | Comparable
89 | Appendable
90 | CompAppend
91 deriving (Eq)
94noRank :: Int
95noRank = 0
98outermostRank :: Int
99outermostRank = 1
102noMark :: Int
103noMark = 2
106initialMark :: Int
107initialMark = 3
110occursMark :: Int
111occursMark =
112 1
115getVarNamesMark :: Int
116getVarNamesMark =
117 0
121-- TYPE HELPERS
124infixr 9 ==>
127{-# INLINE (==>) #-}
128(==>) :: Type -> Type -> Type
129(==>) =
130 FunN
134-- VARIABLE CREATION
137mkDescriptor :: Content -> Descriptor
138mkDescriptor content =
139 Descriptor
140 { _content = content
141 , _rank = noRank
142 , _mark = noMark
143 , _copy = Nothing
144 }
147mkVar :: Maybe Super -> IO Variable
148mkVar maybeSuper =
149 UF.fresh $ mkDescriptor (Var Flex maybeSuper Nothing)
152mkNamedVar :: Flex -> Text -> IO Variable
153mkNamedVar flex name =
154 UF.fresh $ mkDescriptor $ Var flex (toSuper name) (Just name)
157toSuper :: Text -> Maybe Super
158toSuper name =
159 if Text.isPrefixOf "number" name then
160 Just Number
162 else if Text.isPrefixOf "comparable" name then
163 Just Comparable
165 else if Text.isPrefixOf "appendable" name then
166 Just Appendable
168 else
169 Nothing
173-- CONVERT TO SOURCE TYPES
176-- TODO: Attach resulting type to the descriptor so that you
177-- never have to do extra work, particularly nice for aliased types
178toSrcType :: Variable -> IO T.Canonical
179toSrcType variable =
180 do takenNames <- State.execStateT (getVarNames variable) Map.empty
181 State.evalStateT (variableToSrcType variable) (makeNameState takenNames)
184variableToSrcType :: Variable -> StateT NameState IO T.Canonical
185variableToSrcType variable =
186 do descriptor <- liftIO $ UF.descriptor variable
187 let mark = _mark descriptor
188 if mark == occursMark
189 then
190 return (T.Var "∞")
192 else
193 do liftIO $ UF.modifyDescriptor variable (\desc -> desc { _mark = occursMark })
194 srcType <- contentToSrcType variable (_content descriptor)
195 liftIO $ UF.modifyDescriptor variable (\desc -> desc { _mark = mark })
196 return srcType
199contentToSrcType :: Variable -> Content -> StateT NameState IO T.Canonical
200contentToSrcType variable content =
201 case content of
202 Structure term ->
203 termToSrcType term
205 Var _ _ (Just name) ->
206 return (T.Var name)
208 Var flex maybeSuper Nothing ->
209 do freshName <- getFreshName maybeSuper
210 liftIO $ UF.modifyDescriptor variable $ \desc ->
211 desc { _content = Var flex maybeSuper (Just freshName) }
212 return (T.Var freshName)
214 Alias name args realVariable ->
215 do srcArgs <- traverse (traverse variableToSrcType) args
216 srcType <- variableToSrcType realVariable
217 return (T.Aliased name srcArgs (T.Filled srcType))
219 Error name ->
220 return (T.Var name)
223termToSrcType :: FlatType -> StateT NameState IO T.Canonical
224termToSrcType term =
225 case term of
226 App1 name args ->
227 T.Type name <$> traverse variableToSrcType args
229 Fun1 a b ->
230 T.Lambda
231 <$> variableToSrcType a
232 <*> variableToSrcType b
234 EmptyRecord1 ->
235 return $ T.Record [] Nothing
237 Record1 fields extension ->
238 do srcFields <- Map.toList <$> traverse variableToSrcType fields
239 srcExt <- T.iteratedDealias <$> variableToSrcType extension
240 return $
241 case srcExt of
242 T.Record subFields subExt ->
243 T.Record (subFields ++ srcFields) subExt
245 T.Var _ ->
246 T.Record srcFields (Just srcExt)
248 _ ->
249 error "Used toSrcType on a type that is not well-formed"
253-- MANAGE FRESH VARIABLE NAMES
256data NameState =
257 NameState
258 { _taken :: TakenNames
259 , _normals :: Int
260 , _numbers :: Int
261 , _comparables :: Int
262 , _appendables :: Int
263 , _compAppends :: Int
264 }
267type TakenNames = Map.Map Text Variable
270makeNameState :: TakenNames -> NameState
271makeNameState taken =
272 NameState taken 0 0 0 0 0
275getFreshName :: (Monad m) => Maybe Super -> StateT NameState m Text
276getFreshName maybeSuper =
277 case maybeSuper of
278 Nothing ->
279 do index <- State.gets _normals
280 taken <- State.gets _taken
281 let (uniqueName, newIndex) = getFreshNormal index taken
282 State.modify (\state -> state { _normals = newIndex })
283 return uniqueName
285 Just Number ->
286 getFreshSuper "number" _numbers (\index state -> state { _numbers = index })
288 Just Comparable ->
289 getFreshSuper "comparable" _comparables (\index state -> state { _comparables = index })
291 Just Appendable ->
292 getFreshSuper "appendable" _appendables (\index state -> state { _appendables = index })
294 Just CompAppend ->
295 getFreshSuper "compappend" _compAppends (\index state -> state { _compAppends = index })
298getFreshNormal :: Int -> TakenNames -> (Text, Int)
299getFreshNormal index taken =
300 let
301 (postfix, letter) =
302 quotRem index 26
304 char =
305 Char.chr (97 + letter)
307 name =
308 Text.pack (if postfix <= 0 then [char] else char : show postfix)
309 in
310 if Map.member name taken then
311 getFreshNormal (index + 1) taken
313 else
314 (name, index + 1)
317getFreshSuper
318 :: (Monad m)
319 => Text
320 -> (NameState -> Int)
321 -> (Int -> NameState -> NameState)
322 -> StateT NameState m Text
323getFreshSuper name getter setter =
324 do index <- State.gets getter
325 taken <- State.gets _taken
326 let (uniqueName, newIndex) = getFreshSuperHelp name index taken
327 State.modify (setter newIndex)
328 return uniqueName
331getFreshSuperHelp :: Text -> Int -> TakenNames -> (Text, Int)
332getFreshSuperHelp name index taken =
333 let
334 newName =
335 if index <= 0 then name else name <> Text.pack (show index)
336 in
337 if Map.member newName taken then
338 getFreshSuperHelp name (index + 1) taken
340 else
341 (newName, index + 1)
345-- GET ALL VARIABLE NAMES
348getVarNames :: Variable -> StateT TakenNames IO ()
349getVarNames var =
350 do desc <- liftIO $ UF.descriptor var
351 case _mark desc == getVarNamesMark of
352 True ->
353 return ()
355 False ->
356 do liftIO $ UF.setDescriptor var (desc { _mark = getVarNamesMark })
357 case _content desc of
358 Error _ ->
359 return ()
361 Var _ _ Nothing ->
362 return ()
364 Var flex maybeSuper (Just name) ->
365 do oldTaken <- State.get
366 newTaken <- liftIO $ addVarName 0 name var flex maybeSuper oldTaken
367 State.put newTaken
369 Alias _ args realVar ->
370 do mapM_ (getVarNames . snd) args
371 getVarNames realVar
373 Structure (App1 _ args) ->
374 mapM_ getVarNames args
376 Structure (Fun1 arg body) ->
377 do getVarNames arg
378 getVarNames body
380 Structure EmptyRecord1 ->
381 return ()
383 Structure (Record1 fields extension) ->
384 do mapM_ getVarNames fields
385 getVarNames extension
388addVarName :: Int -> Text -> Variable -> Flex -> Maybe Super -> TakenNames -> IO TakenNames
389addVarName index givenName var flex maybeSuper taken =
390 let
391 name =
392 makeIndexedName givenName index
393 in
394 case Map.lookup name taken of
395 Nothing ->
396 do when (name /= givenName) $ UF.modifyDescriptor var $ \desc ->
397 desc { _content = Var flex maybeSuper (Just name) }
398 return $ Map.insert name var taken
400 Just otherVar ->
401 do same <- UF.equivalent var otherVar
402 if same
403 then return taken
404 else addVarName (index + 1) givenName var flex maybeSuper taken
407makeIndexedName :: Text -> Int -> Text
408makeIndexedName name index =
409 if index <= 0 then
410 name
412 else if Char.isDigit (Text.last name) then
413 name <> Text.pack ('_' : show index)
415 else
416 name <> Text.pack (show index)