git.iko.soy/elk
on 20fa5f2 help sign in
elk/src/Type/Type.hs
496 lines 11 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Type.Type where
5import Control.Monad (when)
6import Control.Monad.State.Strict (StateT, liftIO)
7import qualified Control.Monad.State.Strict as State
8import qualified Data.Char as Char
9import qualified Data.Map as Map
10import Data.Monoid ((<>))
11import qualified Data.Text as Text
12import Data.Text (Text)
14import qualified AST.Type as T
15import qualified AST.Variable as Var
16import qualified Reporting.Annotation as A
17import qualified Reporting.Error.Type as Error
18import qualified Reporting.Region as R
19import qualified Type.UnionFind as UF
23-- TYPE PRIMITIVES
26type Variable =
27 UF.Point Descriptor
30data FlatType
31 = App1 Variable Variable
32 | Fun1 Variable Variable
33 | EmptyRecord1
34 | Record1 (Map.Map Text Variable) Variable
37data Type
38 = PlaceHolder Text
39 | AliasN Var.Canonical [(Text, Type)] Type
40 | VarN Variable
41 | AppN Type Type
42 | FunN Type Type
43 | EmptyRecordN
44 | RecordN (Map.Map Text Type) Type
48-- DESCRIPTORS
51data Descriptor =
52 Descriptor
53 { _content :: Content
54 , _rank :: Int
55 , _mark :: Int
56 , _copy :: Maybe Variable
57 }
60data Content
61 = Structure FlatType
62 | Atom Var.Canonical
63 | Var Flex (Maybe Super) (Maybe Text)
64 | Alias Var.Canonical [(Text,Variable)] Variable
65 | Error
68data Flex
69 = Rigid
70 | Flex
73data Super
74 = Number
75 | Comparable
76 | Appendable
77 | CompAppend
78 deriving (Eq)
81noRank :: Int
82noRank = -1
85outermostRank :: Int
86outermostRank = 0
89noMark :: Int
90noMark = 0
93initialMark :: Int
94initialMark = 1
97occursMark :: Int
98occursMark =
99 -1
102getVarNamesMark :: Int
103getVarNamesMark =
104 -2
108-- CONSTRAINTS
111data Constraint
112 = CTrue
113 | CSaveEnv
114 | CEqual Error.Hint R.Region Type Type
115 | CAnd [Constraint]
116 | CLet [Scheme] Constraint
117 | CInstance R.Region SchemeName Type
120type SchemeName = Text
123data Scheme =
124 Scheme
125 { _rigidQuantifiers :: [Variable]
126 , _flexibleQuantifiers :: [Variable]
127 , _constraint :: Constraint
128 , _header :: Map.Map Text (A.Located Type)
129 }
133-- TYPE HELPERS
136infixr 9 ==>
139{-# INLINE (==>) #-}
140(==>) :: Type -> Type -> Type
141(==>) =
142 FunN
145{-# INLINE (<|) #-}
146(<|) :: Type -> Type -> Type
147(<|) =
148 AppN
152-- VARIABLE CREATION
155mkDescriptor :: Content -> Descriptor
156mkDescriptor content =
157 Descriptor
158 { _content = content
159 , _rank = noRank
160 , _mark = noMark
161 , _copy = Nothing
162 }
165mkAtom :: Var.Canonical -> IO Variable
166mkAtom name =
167 UF.fresh $ mkDescriptor (Atom name)
170mkVar :: Maybe Super -> IO Variable
171mkVar maybeSuper =
172 UF.fresh $ mkDescriptor (Var Flex maybeSuper Nothing)
175mkNamedVar :: Flex -> Text -> IO Variable
176mkNamedVar flex name =
177 UF.fresh $ mkDescriptor $ Var flex (toSuper name) (Just name)
180toSuper :: Text -> Maybe Super
181toSuper name =
182 if Text.isPrefixOf "number" name then
183 Just Number
185 else if Text.isPrefixOf "comparable" name then
186 Just Comparable
188 else if Text.isPrefixOf "appendable" name then
189 Just Appendable
191 else
192 Nothing
196-- CONSTRAINT HELPERS
199monoscheme :: Map.Map Text (A.Located Type) -> Scheme
200monoscheme headers =
201 Scheme [] [] CTrue headers
204infixl 8 /\
207(/\) :: Constraint -> Constraint -> Constraint
208(/\) c1 c2 =
209 case (c1, c2) of
210 (CTrue, _) -> c2
211 (_, CTrue) -> c1
212 _ -> CAnd [c1,c2]
215-- ex qs constraint == exists qs. constraint
216ex :: [Variable] -> Constraint -> Constraint
217ex fqs constraint =
218 CLet [Scheme [] fqs constraint Map.empty] CTrue
221forall :: [Variable] -> Constraint -> Constraint
222forall rqs constraint =
223 CLet [Scheme rqs [] constraint Map.empty] CTrue
226exists :: (Type -> IO Constraint) -> IO Constraint
227exists f =
228 do v <- mkVar Nothing
229 ex [v] <$> f (VarN v)
232existsNumber :: (Type -> IO Constraint) -> IO Constraint
233existsNumber f =
234 do v <- mkVar (Just Number)
235 ex [v] <$> f (VarN v)
239-- CONVERT TO SOURCE TYPES
242-- TODO: Attach resulting type to the descriptor so that you
243-- never have to do extra work, particularly nice for aliased types
244toSrcType :: Variable -> IO T.Canonical
245toSrcType variable =
246 do takenNames <- State.execStateT (getVarNames variable) Map.empty
247 State.evalStateT (variableToSrcType variable) (makeNameState takenNames)
250variableToSrcType :: Variable -> StateT NameState IO T.Canonical
251variableToSrcType variable =
252 do descriptor <- liftIO $ UF.descriptor variable
253 let mark = _mark descriptor
254 if mark == occursMark
255 then
256 return (T.Var "∞")
258 else
259 do liftIO $ UF.modifyDescriptor variable (\desc -> desc { _mark = occursMark })
260 srcType <- contentToSrcType variable (_content descriptor)
261 liftIO $ UF.modifyDescriptor variable (\desc -> desc { _mark = mark })
262 return srcType
265contentToSrcType :: Variable -> Content -> StateT NameState IO T.Canonical
266contentToSrcType variable content =
267 case content of
268 Structure term ->
269 termToSrcType term
271 Atom name ->
272 return (T.Type name)
274 Var _ _ (Just name) ->
275 return (T.Var name)
277 Var flex maybeSuper Nothing ->
278 do freshName <- getFreshName maybeSuper
279 liftIO $ UF.modifyDescriptor variable $ \desc ->
280 desc { _content = Var flex maybeSuper (Just freshName) }
281 return (T.Var freshName)
283 Alias name args realVariable ->
284 do srcArgs <- traverse (traverse variableToSrcType) args
285 srcType <- variableToSrcType realVariable
286 return (T.Aliased name srcArgs (T.Filled srcType))
288 Error ->
289 return (T.Var "?")
292termToSrcType :: FlatType -> StateT NameState IO T.Canonical
293termToSrcType term =
294 case term of
295 App1 func arg ->
296 do srcFunc <- variableToSrcType func
297 srcArg <- variableToSrcType arg
298 case srcFunc of
299 T.App f args ->
300 return (T.App f (args ++ [srcArg]))
302 _ ->
303 return (T.App srcFunc [srcArg])
305 Fun1 a b ->
306 T.Lambda
307 <$> variableToSrcType a
308 <*> variableToSrcType b
310 EmptyRecord1 ->
311 return $ T.Record [] Nothing
313 Record1 fields extension ->
314 do srcFields <- Map.toList <$> traverse variableToSrcType fields
315 srcExt <- T.iteratedDealias <$> variableToSrcType extension
316 return $
317 case srcExt of
318 T.Record subFields subExt ->
319 T.Record (subFields ++ srcFields) subExt
321 T.Var _ ->
322 T.Record srcFields (Just srcExt)
324 _ ->
325 error "Used toSrcType on a type that is not well-formed"
329-- MANAGE FRESH VARIABLE NAMES
332data NameState =
333 NameState
334 { _taken :: TakenNames
335 , _normals :: Int
336 , _numbers :: Int
337 , _comparables :: Int
338 , _appendables :: Int
339 , _compAppends :: Int
340 }
343type TakenNames = Map.Map Text Variable
346makeNameState :: TakenNames -> NameState
347makeNameState taken =
348 NameState taken 0 0 0 0 0
351getFreshName :: (Monad m) => Maybe Super -> StateT NameState m Text
352getFreshName maybeSuper =
353 case maybeSuper of
354 Nothing ->
355 do index <- State.gets _normals
356 taken <- State.gets _taken
357 let (uniqueName, newIndex) = getFreshNormal index taken
358 State.modify (\state -> state { _normals = newIndex })
359 return uniqueName
361 Just Number ->
362 getFreshSuper "number" _numbers (\index state -> state { _numbers = index })
364 Just Comparable ->
365 getFreshSuper "comparable" _comparables (\index state -> state { _comparables = index })
367 Just Appendable ->
368 getFreshSuper "appendable" _appendables (\index state -> state { _appendables = index })
370 Just CompAppend ->
371 getFreshSuper "compappend" _compAppends (\index state -> state { _compAppends = index })
374getFreshNormal :: Int -> TakenNames -> (Text, Int)
375getFreshNormal index taken =
376 let
377 (postfix, letter) =
378 quotRem index 26
380 char =
381 Char.chr (97 + letter)
383 name =
384 Text.pack (if postfix <= 0 then [char] else char : show postfix)
385 in
386 if Map.member name taken then
387 getFreshNormal (index + 1) taken
389 else
390 (name, index + 1)
393getFreshSuper
394 :: (Monad m)
395 => Text
396 -> (NameState -> Int)
397 -> (Int -> NameState -> NameState)
398 -> StateT NameState m Text
399getFreshSuper name getter setter =
400 do index <- State.gets getter
401 taken <- State.gets _taken
402 let (uniqueName, newIndex) = getFreshSuperHelp name index taken
403 State.modify (setter newIndex)
404 return uniqueName
407getFreshSuperHelp :: Text -> Int -> TakenNames -> (Text, Int)
408getFreshSuperHelp name index taken =
409 let
410 newName =
411 if index <= 0 then name else name <> Text.pack (show index)
412 in
413 if Map.member newName taken then
414 getFreshSuperHelp name (index + 1) taken
416 else
417 (newName, index + 1)
421-- GET ALL VARIABLE NAMES
424getVarNames :: Variable -> StateT TakenNames IO ()
425getVarNames var =
426 do desc <- liftIO $ UF.descriptor var
427 case _mark desc == getVarNamesMark of
428 True ->
429 return ()
431 False ->
432 do liftIO $ UF.setDescriptor var (desc { _mark = getVarNamesMark })
433 case _content desc of
434 Atom _ ->
435 return ()
437 Error ->
438 return ()
440 Var _ _ Nothing ->
441 return ()
443 Var flex maybeSuper (Just name) ->
444 do oldTaken <- State.get
445 newTaken <- liftIO $ addVarName 0 name var flex maybeSuper oldTaken
446 State.put newTaken
448 Alias _ args realVar ->
449 do mapM_ (getVarNames . snd) args
450 getVarNames realVar
452 Structure (App1 func arg) ->
453 do getVarNames func
454 getVarNames arg
456 Structure (Fun1 arg body) ->
457 do getVarNames arg
458 getVarNames body
460 Structure EmptyRecord1 ->
461 return ()
463 Structure (Record1 fields extension) ->
464 do mapM_ getVarNames fields
465 getVarNames extension
468addVarName :: Int -> Text -> Variable -> Flex -> Maybe Super -> TakenNames -> IO TakenNames
469addVarName index givenName var flex maybeSuper taken =
470 let
471 name =
472 makeIndexedName givenName index
473 in
474 case Map.lookup name taken of
475 Nothing ->
476 do when (name /= givenName) $ UF.modifyDescriptor var $ \desc ->
477 desc { _content = Var flex maybeSuper (Just name) }
478 return $ Map.insert name var taken
480 Just otherVar ->
481 do same <- UF.equivalent var otherVar
482 if same
483 then return taken
484 else addVarName (index + 1) givenName var flex maybeSuper taken
487makeIndexedName :: Text -> Int -> Text
488makeIndexedName name index =
489 if index <= 0 then
490 name
492 else if Char.isDigit (Text.last name) then
493 name <> Text.pack ('_' : show index)
495 else
496 name <> Text.pack (show index)