git.iko.soy/elk
on master help sign in
Refactor Type.Type: better style, flow, and comments
aeb02cdEvan Czaplicki
src/Type/Type.hs+205−141
compare with master
unifiedsplit
@@ -17,6 +17,19 @@ import qualified AST.Type as T
17import qualified AST.Variable as Var
17import qualified AST.Variable as Var
18
18
19
19
20+-- CONCRETE TYPES
21+
22+type Type = TermN Variable
23+
24+type Variable = UF.Point Descriptor
25+
26+type TypeConstraint = Constraint Type Variable
27+
28+type TypeScheme = Scheme Type Variable
29+
30+
31+-- TYPE PRIMITIVES
32+
20data Term1 a
33data Term1 a
21 = App1 a a
34 = App1 a a
22 | Fun1 a a
35 | Fun1 a a
@@ -26,82 +39,26 @@ data Term1 a
26
39
27
40
28data TermN a
41data TermN a
29− = VarN (Maybe Var.Canonical) a
42+ = VarN (Maybe Var.Canonical) a
30 | TermN (Maybe Var.Canonical) (Term1 (TermN a))
43 | TermN (Maybe Var.Canonical) (Term1 (TermN a))
31
44
32
45
33varN :: a -> TermN a
46varN :: a -> TermN a
47+varN =
34−varN = VarN Nothing
48+ VarN Nothing
35
49
36
50
37termN :: (Term1 (TermN a)) -> TermN a
51termN :: (Term1 (TermN a)) -> TermN a
52+termN =
38−termN = TermN Nothing
53+ TermN Nothing
39
54
40
55
41record :: Map.Map String [TermN a] -> TermN a -> TermN a
56record :: Map.Map String [TermN a] -> TermN a -> TermN a
57+record fs rec =
42−record fs rec = termN (Record1 fs rec)
58+ termN (Record1 fs rec)
43−
44−
45−type Type = TermN Variable
46−
47−
48−type Variable = UF.Point Descriptor
49−
50−
51−type SchemeName = String
52−
53−
54−type TypeName = Var.Canonical
55−
56−
57−type Constraint a b = Located (BasicConstraint a b)
58−
59−
60−data BasicConstraint a b
61− = CTrue
62− | CSaveEnv
63− | CEqual a a
64− | CAnd [Constraint a b]
65− | CLet [Scheme a b] (Constraint a b)
66− | CInstance SchemeName a
67−
68−
69−data Scheme a b = Scheme
70− { rigidQuantifiers :: [b]
71− , flexibleQuantifiers :: [b]
72− , constraint :: Constraint a b
73− , header :: Map.Map String a
74− }
75−
76−
77−type TypeConstraint = Constraint Type Variable
78−
79−type TypeScheme = Scheme Type Variable
80−
81−
82−monoscheme :: Map.Map String a -> Scheme a b
83−monoscheme headers = Scheme [] [] (noneNoDocs CTrue) headers
84−
85−
86−infixl 8 /\
87−
88−(/\) :: Constraint a b -> Constraint a b -> Constraint a b
89−a@(A _ c1) /\ b@(A _ c2) =
90− case (c1, c2) of
91− (CTrue, _) -> b
92− (_, CTrue) -> a
93− _ -> mergeOldDocs a b (CAnd [a,b])
94−
95−
96−infixr 9 ==>
97−
98−(==>) :: Type -> Type -> Type
99−a ==> b = termN (Fun1 a b)
100−
101
59
102−(<|) :: TermN a -> TermN a -> TermN a
103−f <| a = termN (App1 f a)
104
60
61+-- DESCRIPTORS
105
62
106data Descriptor = Descriptor
63data Descriptor = Descriptor
107 { structure :: Maybe (Term1 Variable)
64 { structure :: Maybe (Term1 Variable)
@@ -113,23 +70,18 @@ data Descriptor = Descriptor
113 , alias :: Maybe Var.Canonical
70 , alias :: Maybe Var.Canonical
114 }
71 }
115
72
116−
117noRank :: Int
73noRank :: Int
118noRank = -1
74noRank = -1
119
75
120−
121outermostRank :: Int
76outermostRank :: Int
122outermostRank = 0
77outermostRank = 0
123
78
124−
125noMark :: Int
79noMark :: Int
126noMark = 0
80noMark = 0
127
81
128−
129initialMark :: Int
82initialMark :: Int
130initialMark = 1
83initialMark = 1
131
84
132−
133data Flex
85data Flex
134 = Rigid
86 = Rigid
135 | Flexible
87 | Flexible
@@ -137,7 +89,6 @@ data Flex
137 | Is SuperType
89 | Is SuperType
138 deriving (Eq)
90 deriving (Eq)
139
91
140−
141data SuperType
92data SuperType
142 = Number
93 = Number
143 | Comparable
94 | Comparable
@@ -145,6 +96,47 @@ data SuperType
145 deriving (Eq)
96 deriving (Eq)
146
97
147
98
99+-- CONSTRAINTS
100+
101+type Constraint a b =
102+ Located (BasicConstraint a b)
103+
104+data BasicConstraint a b
105+ = CTrue
106+ | CSaveEnv
107+ | CEqual a a
108+ | CAnd [Constraint a b]
109+ | CLet [Scheme a b] (Constraint a b)
110+ | CInstance SchemeName a
111+
112+type SchemeName = String
113+
114+type TypeName = Var.Canonical
115+
116+data Scheme a b = Scheme
117+ { rigidQuantifiers :: [b]
118+ , flexibleQuantifiers :: [b]
119+ , constraint :: Constraint a b
120+ , header :: Map.Map String a
121+ }
122+
123+
124+-- TYPE HELPERS
125+
126+infixr 9 ==>
127+
128+(==>) :: Type -> Type -> Type
129+(==>) a b =
130+ termN (Fun1 a b)
131+
132+
133+(<|) :: TermN a -> TermN a -> TermN a
134+(<|) f a =
135+ termN (App1 f a)
136+
137+
138+-- VARIABLE HELPERS
139+
148namedVar :: Flex -> Var.Canonical -> IO Variable
140namedVar :: Flex -> Var.Canonical -> IO Variable
149namedVar flex name = UF.fresh $ Descriptor
141namedVar flex name = UF.fresh $ Descriptor
150 { structure = Nothing
142 { structure = Nothing
@@ -169,6 +161,23 @@ variable flex = UF.fresh $ Descriptor
169 }
161 }
170
162
171
163
164+-- CONSTRAINT HELPERS
165+
166+monoscheme :: Map.Map String a -> Scheme a b
167+monoscheme headers =
168+ Scheme [] [] (noneNoDocs CTrue) headers
169+
170+
171+infixl 8 /\
172+
173+(/\) :: Constraint a b -> Constraint a b -> Constraint a b
174+(/\) a@(A _ c1) b@(A _ c2) =
175+ case (c1, c2) of
176+ (CTrue, _) -> b
177+ (_, CTrue) -> a
178+ _ -> mergeOldDocs a b (CAnd [a,b])
179+
180+
172-- ex qs constraint == exists qs. constraint
181-- ex qs constraint == exists qs. constraint
173ex :: [Variable] -> TypeConstraint -> TypeConstraint
182ex :: [Variable] -> TypeConstraint -> TypeConstraint
174ex fqs constraint@(A ann _) =
183ex fqs constraint@(A ann _) =
@@ -213,36 +222,51 @@ instance PrettyType a => PrettyType (Term1 a) where
213 parensIf needed (px <+> pretty App x)
222 parensIf needed (px <+> pretty App x)
214 where
223 where
215 px = prty f
224 px = prty f
225+ needed =
216− needed = case when of
226+ case when of
217− App -> True
227+ App -> True
218− _ -> False
228+ _ -> False
219
229
220 Fun1 arg body ->
230 Fun1 arg body ->
221 parensIf needed (pretty Fn arg <+> P.text "->" <+> prty body)
231 parensIf needed (pretty Fn arg <+> P.text "->" <+> prty body)
222 where
232 where
233+ needed =
223− needed = case when of
234+ case when of
224− Never -> False
235+ Never -> False
225− _ -> True
236+ _ -> True
226
237
227− Var1 x -> prty x
238+ Var1 x ->
239+ prty x
228
240
241+ EmptyRecord1 ->
229− EmptyRecord1 -> P.braces P.empty
242+ P.braces P.empty
230
243
231 Record1 fields ext ->
244 Record1 fields ext ->
232 P.braces (extend <+> commaSep prettyFields)
245 P.braces (extend <+> commaSep prettyFields)
233 where
246 where
234 prettyExt = prty ext
247 prettyExt = prty ext
248+
249+ extend
235− extend | P.render prettyExt == "{}" = P.empty
250+ | P.render prettyExt == "{}" =
251+ P.empty
252+ | otherwise =
236− | otherwise = prettyExt <+> P.text "|"
253+ prettyExt <+> P.text "|"
254+
255+ mkPretty f t =
237− mkPretty f t = P.text f <+> P.text ":" <+> prty t
256+ P.text f <+> P.text ":" <+> prty t
257+
258+ prettyFields =
238− prettyFields = concatMap (\(f,ts) -> map (mkPretty f) ts) (Map.toList fields)
259+ concatMap (\(f,ts) -> map (mkPretty f) ts) (Map.toList fields)
239
260
240
261
241instance PrettyType a => PrettyType (TermN a) where
262instance PrettyType a => PrettyType (TermN a) where
242 pretty when term =
263 pretty when term =
243 case term of
264 case term of
265+ VarN alias x ->
244− VarN alias x -> either alias (pretty when x)
266+ either alias (pretty when x)
267+
268+ TermN alias t1 ->
245− TermN alias t1 -> either alias (pretty when t1)
269+ either alias (pretty when t1)
246 where
270 where
247 either maybeAlias doc =
271 either maybeAlias doc =
248 case maybeAlias of
272 case maybeAlias of
@@ -251,16 +275,20 @@ instance PrettyType a => PrettyType (TermN a) where
251
275
252
276
253instance PrettyType Descriptor where
277instance PrettyType Descriptor where
254− pretty when desc = do
278+ pretty when desc =
255 case (alias desc, structure desc, name desc) of
279 case (alias desc, structure desc, name desc) of
280+ (Just name, _, _) ->
256− (Just name, _, _) -> PP.pretty name
281+ PP.pretty name
282+
283+ (_, Just term, _) ->
257− (_, Just term, _) -> pretty when term
284+ pretty when term
285+
258 (_, _, Just name)
286 (_, _, Just name)
259 | Var.isTuple name ->
287 | Var.isTuple name ->
260 P.parens . P.text $ replicate (read (drop 6 (Var.toString name)) - 1) ','
288 P.parens . P.text $ replicate (read (drop 6 (Var.toString name)) - 1) ','
261 | otherwise ->
289 | otherwise ->
262 P.text (Var.toString name)
290 P.text (Var.toString name)
263−
291+
264 _ -> P.text "?"
292 _ -> P.text "?"
265
293
266
294
@@ -320,20 +348,27 @@ instance (PrettyType a, PrettyType b) => PrettyType (Scheme a b) where
320
348
321
349
322extraPretty :: (PrettyType t, Crawl t) => t -> IO Doc
350extraPretty :: (PrettyType t, Crawl t) => t -> IO Doc
351+extraPretty t =
323−extraPretty t = pretty Never <$> addNames t
352+ pretty Never <$> addNames t
324
353
325
354
326-- ADDING NAMES TO TYPES
355-- ADDING NAMES TO TYPES
327
356
328addNames :: (Crawl t) => t -> IO t
357addNames :: (Crawl t) => t -> IO t
329−addNames value = do
358+addNames value =
330− (rawVars, _, _, _) <- execStateT (crawl getNames value) ([], 0, 0, 0)
359+ do (rawVars, _, _, _) <- execStateT (crawl getNames value) ([], 0, 0, 0)
360+
331− let vars = map head . List.group $ List.sort rawVars
361+ let vars = map head . List.group $ List.sort rawVars
362+
332− suffix s = map (++s) (map (:[]) ['a'..'z'])
363+ let suffix s = map (++s) (map (:[]) ['a'..'z'])
364+
333− allVars = concatMap suffix $ ["","'","_"] ++ map show [ (0 :: Int) .. ]
365+ let allVars = concatMap suffix $ ["","'","_"] ++ map show [ (0 :: Int) .. ]
366+
334− okayVars = filter (`notElem` vars) allVars
367+ let okayVars = filter (`notElem` vars) allVars
368+
335− runStateT (crawl rename value) (okayVars, 0, 0, 0)
369+ runStateT (crawl rename value) (okayVars, 0, 0, 0)
370+
336− return value
371+ return value
337 where
372 where
338 getNames desc state@(vars, a, b, c) =
373 getNames desc state@(vars, a, b, c) =
339 let name' = name desc in
374 let name' = name desc in
@@ -368,23 +403,25 @@ class Crawl t where
368
403
369
404
370instance Crawl e => Crawl (Annotated a e) where
405instance Crawl e => Crawl (Annotated a e) where
371− crawl nextState (A ann e) = A ann <$> crawl nextState e
406+ crawl nextState (A ann e) =
407+ A ann <$> crawl nextState e
372
408
373
409
374instance (Crawl t, Crawl v) => Crawl (BasicConstraint t v) where
410instance (Crawl t, Crawl v) => Crawl (BasicConstraint t v) where
375− crawl nextState constraint =
411+ crawl nextState constraint =
376 let rnm = crawl nextState in
412 let rnm = crawl nextState in
377 case constraint of
413 case constraint of
378 CTrue -> return CTrue
414 CTrue -> return CTrue
379 CSaveEnv -> return CSaveEnv
415 CSaveEnv -> return CSaveEnv
380 CEqual a b -> CEqual <$> rnm a <*> rnm b
416 CEqual a b -> CEqual <$> rnm a <*> rnm b
381 CAnd cs -> CAnd <$> crawl nextState cs
417 CAnd cs -> CAnd <$> crawl nextState cs
382− CLet schemes c -> CLet <$> crawl nextState schemes <*> crawl nextState c
418+ CLet schemes c -> CLet <$> crawl nextState schemes <*> crawl nextState c
383 CInstance name tipe -> CInstance name <$> rnm tipe
419 CInstance name tipe -> CInstance name <$> rnm tipe
384
420
385
421
386instance Crawl a => Crawl [a] where
422instance Crawl a => Crawl [a] where
423+ crawl nextState list =
387− crawl nextState list = mapM (crawl nextState) list
424+ mapM (crawl nextState) list
388
425
389
426
390instance (Crawl t, Crawl v) => Crawl (Scheme t v) where
427instance (Crawl t, Crawl v) => Crawl (Scheme t v) where
@@ -410,14 +447,24 @@ instance Crawl t => Crawl (TermN t) where
410
447
411instance Crawl t => Crawl (Term1 t) where
448instance Crawl t => Crawl (Term1 t) where
412 crawl nextState term =
449 crawl nextState term =
413− let rnm = crawl nextState in
450+ let rnm = crawl nextState in
414− case term of
451+ case term of
452+ App1 a b ->
415− App1 a b -> App1 <$> rnm a <*> rnm b
453+ App1 <$> rnm a <*> rnm b
454+
455+ Fun1 a b ->
416− Fun1 a b -> Fun1 <$> rnm a <*> rnm b
456+ Fun1 <$> rnm a <*> rnm b
457+
458+ Var1 a ->
417− Var1 a -> Var1 <$> rnm a
459+ Var1 <$> rnm a
460+
461+ EmptyRecord1 ->
418− EmptyRecord1 -> return EmptyRecord1
462+ return EmptyRecord1
463+
419 Record1 fields ext ->
464 Record1 fields ext ->
465+ Record1
420− Record1 <$> traverse (mapM rnm) fields <*> rnm ext
466+ <$> traverse (mapM rnm) fields
467+ <*> rnm ext
421
468
422
469
423instance Crawl a => Crawl (UF.Point a) where
470instance Crawl a => Crawl (UF.Point a) where
@@ -436,7 +483,7 @@ instance Crawl Descriptor where
436 put state'
483 put state'
437 return $ desc { name = name', structure = structure' }
484 return $ desc { name = name', structure = structure' }
438
485
439−
486+
440toSrcType :: Variable -> IO T.CanonicalType
487toSrcType :: Variable -> IO T.CanonicalType
441toSrcType var =
488toSrcType var =
442 go =<< addNames var
489 go =<< addNames var
@@ -446,40 +493,53 @@ toSrcType var =
446 srcType <- maybe (backupSrcType desc) termToSrcType (structure desc)
493 srcType <- maybe (backupSrcType desc) termToSrcType (structure desc)
447 return $ maybe srcType (\name -> T.Aliased name srcType) (alias desc)
494 return $ maybe srcType (\name -> T.Aliased name srcType) (alias desc)
448
495
449− backupSrcType desc =
496+ backupSrcType :: Descriptor -> IO T.CanonicalType
497+ backupSrcType desc =
450 case name desc of
498 case name desc of
451 Just v@(Var.Canonical _ x@(c:_))
499 Just v@(Var.Canonical _ x@(c:_))
452− | Char.isLower c -> return (T.Var x)
500+ | Char.isLower c ->
501+ return (T.Var x)
502+ | otherwise ->
453− | otherwise -> return $ T.Type v
503+ return $ T.Type v
454−
504+
505+ _ ->
506+ error $
455− _ -> error $ concat
507+ concat
456− [ "Problem converting the following type "
508+ [ "Problem converting the following type "
457− , "from a type-checker type to a source-syntax type:"
509+ , "from a type-checker type to a source-syntax type:"
458− , P.render (pretty Never var) ]
510+ , P.render (pretty Never var)
459−
511+ ]
512+
513+ termToSrcType :: Term1 Variable -> IO T.CanonicalType
460 termToSrcType term =
514 termToSrcType term =
461 case term of
515 case term of
462− App1 a b -> do
516+ App1 a b ->
463− a' <- go a
517+ do a' <- go a
464− b' <- go b
518+ b' <- go b
465− case a' of
519+ case a' of
520+ T.App f args ->
466− T.App f args -> return $ T.App f (args ++ [b'])
521+ return $ T.App f (args ++ [b'])
522+ _ ->
467− _ -> return $ T.App a' [b']
523+ return $ T.App a' [b']
468−
524+
525+ Fun1 a b ->
469− Fun1 a b -> T.Lambda <$> go a <*> go b
526+ T.Lambda <$> go a <*> go b
470−
527+
471− Var1 a -> go a
528+ Var1 a ->
472−
529+ go a
530+
531+ EmptyRecord1 ->
473− EmptyRecord1 -> return $ T.Record [] Nothing
532+ return $ T.Record [] Nothing
474−
533+
475− Record1 tfields extension -> do
534+ Record1 tfields extension ->
476− fields' <- traverse (mapM go) tfields
535+ do fields' <- traverse (mapM go) tfields
477− let fields = concat [ map ((,) name) ts | (name,ts) <- Map.toList fields' ]
536+ let fields = concat [ map ((,) name) ts | (name,ts) <- Map.toList fields' ]
478− ext' <- dealias <$> go extension
537+ ext' <- dealias <$> go extension
538+ return $
479− return $ case ext' of
539+ case ext' of
480− T.Record fs ext -> T.Record (fs ++ fields) ext
540+ T.Record fs ext -> T.Record (fs ++ fields) ext
481− T.Var _ -> T.Record fields (Just ext')
541+ T.Var _ -> T.Record fields (Just ext')
482− _ -> error "Used toSrcType on a type that is not well-formed"
542+ _ -> error "Used toSrcType on a type that is not well-formed"
483
543
484 dealias :: T.CanonicalType -> T.CanonicalType
544 dealias :: T.CanonicalType -> T.CanonicalType
485 dealias t =
545 dealias t =
@@ -488,11 +548,15 @@ toSrcType var =
488 _ -> t
548 _ -> t
489
549
490
550
491−data AppStructure = List Variable | Tuple [Variable] | Other
551+data AppStructure
552+ = List Variable
553+ | Tuple [Variable]
554+ | Other
492
555
493
556
494collectApps :: Variable -> IO AppStructure
557collectApps :: Variable -> IO AppStructure
495−collectApps var = go [] var
558+collectApps var =
559+ go [] var
496 where
560 where
497 go vars var = do
561 go vars var = do
498 desc <- UF.descriptor var
562 desc <- UF.descriptor var