git.iko.soy/elk
on master help sign in
Conform to modern style guide
ff9acf5Evan Czaplicki
src/Type/Type.hs+129−49
compare with master
unifiedsplit
@@ -16,6 +16,7 @@ import qualified AST.PrettyPrint as PP
16import qualified AST.Type as T
16import qualified AST.Type as T
17import qualified AST.Variable as Var
17import qualified AST.Variable as Var
18
18
19+
19data Term1 a
20data Term1 a
20 = App1 a a
21 = App1 a a
21 | Fun1 a a
22 | Fun1 a a
@@ -24,27 +25,40 @@ data Term1 a
24 | Record1 (Map.Map String [a]) a
25 | Record1 (Map.Map String [a]) a
25 deriving Show
26 deriving Show
26
27
28+
27data TermN a
29data TermN a
28 = VarN (Maybe Var.Canonical) a
30 = VarN (Maybe Var.Canonical) a
29 | TermN (Maybe Var.Canonical) (Term1 (TermN a))
31 | TermN (Maybe Var.Canonical) (Term1 (TermN a))
30 deriving Show
32 deriving Show
31
33
34+
32varN :: a -> TermN a
35varN :: a -> TermN a
33varN = VarN Nothing
36varN = VarN Nothing
34
37
38+
35termN :: (Term1 (TermN a)) -> TermN a
39termN :: (Term1 (TermN a)) -> TermN a
36termN = TermN Nothing
40termN = TermN Nothing
37
41
42+
38record :: Map.Map String [TermN a] -> TermN a -> TermN a
43record :: Map.Map String [TermN a] -> TermN a -> TermN a
39record fs rec = termN (Record1 fs rec)
44record fs rec = termN (Record1 fs rec)
40
45
46+
41type Type = TermN Variable
47type Type = TermN Variable
48+
49+
42type Variable = UF.Point Descriptor
50type Variable = UF.Point Descriptor
43
51
52+
44type SchemeName = String
53type SchemeName = String
54+
55+
45type TypeName = Var.Canonical
56type TypeName = Var.Canonical
46
57
58+
47type Constraint a b = Located (BasicConstraint a b)
59type Constraint a b = Located (BasicConstraint a b)
60+
61+
48data BasicConstraint a b
62data BasicConstraint a b
49 = CTrue
63 = CTrue
50 | CSaveEnv
64 | CSaveEnv
@@ -54,19 +68,25 @@ data BasicConstraint a b
54 | CInstance SchemeName a
68 | CInstance SchemeName a
55 deriving Show
69 deriving Show
56
70
71+
57−data Scheme a b = Scheme {
72+data Scheme a b = Scheme
58− rigidQuantifiers :: [b],
73+ { rigidQuantifiers :: [b]
59− flexibleQuantifiers :: [b],
74+ , flexibleQuantifiers :: [b]
60− constraint :: Constraint a b,
75+ , constraint :: Constraint a b
61− header :: Map.Map String a
76+ , header :: Map.Map String a
77+ }
62−} deriving Show
78+ deriving Show
79+
63
80
64type TypeConstraint = Constraint Type Variable
81type TypeConstraint = Constraint Type Variable
82+
65type TypeScheme = Scheme Type Variable
83type TypeScheme = Scheme Type Variable
66
84
85+
67monoscheme :: Map.Map String a -> Scheme a b
86monoscheme :: Map.Map String a -> Scheme a b
68monoscheme headers = Scheme [] [] (noneNoDocs CTrue) headers
87monoscheme headers = Scheme [] [] (noneNoDocs CTrue) headers
69
88
89+
70infixl 8 /\
90infixl 8 /\
71
91
72(/\) :: Constraint a b -> Constraint a b -> Constraint a b
92(/\) :: Constraint a b -> Constraint a b -> Constraint a b
@@ -76,13 +96,17 @@ a@(A _ c1) /\ b@(A _ c2) =
76 (_, CTrue) -> a
96 (_, CTrue) -> a
77 _ -> mergeOldDocs a b (CAnd [a,b])
97 _ -> mergeOldDocs a b (CAnd [a,b])
78
98
99+
79infixr 9 ==>
100infixr 9 ==>
101+
80(==>) :: Type -> Type -> Type
102(==>) :: Type -> Type -> Type
81a ==> b = termN (Fun1 a b)
103a ==> b = termN (Fun1 a b)
82
104
105+
83(<|) :: TermN a -> TermN a -> TermN a
106(<|) :: TermN a -> TermN a -> TermN a
84f <| a = termN (App1 f a)
107f <| a = termN (App1 f a)
85
108
109+
86data Descriptor = Descriptor
110data Descriptor = Descriptor
87 { structure :: Maybe (Term1 Variable)
111 { structure :: Maybe (Term1 Variable)
88 , rank :: Int
112 , rank :: Int
@@ -91,25 +115,40 @@ data Descriptor = Descriptor
91 , copy :: Maybe Variable
115 , copy :: Maybe Variable
92 , mark :: Int
116 , mark :: Int
93 , alias :: Maybe Var.Canonical
117 , alias :: Maybe Var.Canonical
118+ }
94− } deriving Show
119+ deriving Show
120+
95
121
96noRank :: Int
122noRank :: Int
97noRank = -1
123noRank = -1
98
124
125+
99outermostRank :: Int
126outermostRank :: Int
100outermostRank = 0
127outermostRank = 0
101
128
129+
102noMark :: Int
130noMark :: Int
103noMark = 0
131noMark = 0
104
132
133+
105initialMark :: Int
134initialMark :: Int
106initialMark = 1
135initialMark = 1
107
136
108−data Flex = Rigid | Flexible | Constant | Is SuperType
109− deriving (Show, Eq)
110
137
138+data Flex
139+ = Rigid
140+ | Flexible
141+ | Constant
142+ | Is SuperType
143+ deriving (Show, Eq)
144+
145+
146+data SuperType
147+ = Number
111−data SuperType = Number | Comparable | Appendable
148+ | Comparable
149+ | Appendable
112− deriving (Show, Eq)
150+ deriving (Show, Eq)
151+
113
152
114namedVar :: Flex -> Var.Canonical -> IO Variable
153namedVar :: Flex -> Var.Canonical -> IO Variable
115namedVar flex name = UF.fresh $ Descriptor
154namedVar flex name = UF.fresh $ Descriptor
@@ -122,6 +161,7 @@ namedVar flex name = UF.fresh $ Descriptor
122 , alias = Nothing
161 , alias = Nothing
123 }
162 }
124
163
164+
125variable :: Flex -> IO Variable
165variable :: Flex -> IO Variable
126variable flex = UF.fresh $ Descriptor
166variable flex = UF.fresh $ Descriptor
127 { structure = Nothing
167 { structure = Nothing
@@ -139,32 +179,40 @@ ex :: [Variable] -> TypeConstraint -> TypeConstraint
139ex fqs constraint@(A ann _) =
179ex fqs constraint@(A ann _) =
140 A ann $ CLet [Scheme [] fqs constraint Map.empty] (A ann CTrue)
180 A ann $ CLet [Scheme [] fqs constraint Map.empty] (A ann CTrue)
141
181
182+
142-- fl qs constraint == forall qs. constraint
183-- fl qs constraint == forall qs. constraint
143fl :: [Variable] -> TypeConstraint -> TypeConstraint
184fl :: [Variable] -> TypeConstraint -> TypeConstraint
144fl rqs constraint@(A ann _) =
185fl rqs constraint@(A ann _) =
145 A ann $ CLet [Scheme rqs [] constraint Map.empty] (A ann CTrue)
186 A ann $ CLet [Scheme rqs [] constraint Map.empty] (A ann CTrue)
146
187
188+
147exists :: Error e => (Type -> ErrorT e IO TypeConstraint) -> ErrorT e IO TypeConstraint
189exists :: Error e => (Type -> ErrorT e IO TypeConstraint) -> ErrorT e IO TypeConstraint
148−exists f = do
190+exists f =
149− v <- liftIO $ variable Flexible
191+ do v <- liftIO $ variable Flexible
150− ex [v] <$> f (varN v)
192+ ex [v] <$> f (varN v)
193+
151
194
152existsNumber :: Error e => (Type -> ErrorT e IO TypeConstraint) -> ErrorT e IO TypeConstraint
195existsNumber :: Error e => (Type -> ErrorT e IO TypeConstraint) -> ErrorT e IO TypeConstraint
153−existsNumber f = do
196+existsNumber f =
154− v <- liftIO $ variable (Is Number)
197+ do v <- liftIO $ variable (Is Number)
155− ex [v] <$> f (varN v)
198+ ex [v] <$> f (varN v)
199+
156
200
201+-- TYPES TO PRETTY STRINGS
157
202
158instance Show a => Show (UF.Point a) where
203instance Show a => Show (UF.Point a) where
204+ show point =
159− show point = unsafePerformIO $ fmap show (UF.descriptor point)
205+ unsafePerformIO $ fmap show (UF.descriptor point)
160
206
161
207
162instance PrettyType a => PrettyType (UF.Point a) where
208instance PrettyType a => PrettyType (UF.Point a) where
209+ pretty when point =
163− pretty when point = unsafePerformIO $ fmap (pretty when) (UF.descriptor point)
210+ unsafePerformIO $ fmap (pretty when) (UF.descriptor point)
164
211
165
212
166instance PrettyType t => PrettyType (Annotated a t) where
213instance PrettyType t => PrettyType (Annotated a t) where
167− pretty when (A _ e) = pretty when e
214+ pretty when (A _ e) =
215+ pretty when e
168
216
169
217
170instance PrettyType a => PrettyType (Term1 a) where
218instance PrettyType a => PrettyType (Term1 a) where
@@ -190,7 +238,8 @@ instance PrettyType a => PrettyType (Term1 a) where
190
238
191 EmptyRecord1 -> P.braces P.empty
239 EmptyRecord1 -> P.braces P.empty
192
240
241+ Record1 fields ext ->
193− Record1 fields ext -> P.braces (extend <+> commaSep prettyFields)
242+ P.braces (extend <+> commaSep prettyFields)
194 where
243 where
195 prettyExt = prty ext
244 prettyExt = prty ext
196 extend | P.render prettyExt == "{}" = P.empty
245 extend | P.render prettyExt == "{}" = P.empty
@@ -210,6 +259,7 @@ instance PrettyType a => PrettyType (TermN a) where
210 Just alias -> PP.pretty alias
259 Just alias -> PP.pretty alias
211 Nothing -> doc
260 Nothing -> doc
212
261
262+
213instance PrettyType Descriptor where
263instance PrettyType Descriptor where
214 pretty when desc = do
264 pretty when desc = do
215 case (alias desc, structure desc, name desc) of
265 case (alias desc, structure desc, name desc) of
@@ -256,6 +306,7 @@ instance (PrettyType a, PrettyType b) => PrettyType (BasicConstraint a b) where
256 CInstance name tipe ->
306 CInstance name tipe ->
257 P.text name <+> P.text "<" <+> prty tipe
307 P.text name <+> P.text "<" <+> prty tipe
258
308
309+
259instance (PrettyType a, PrettyType b) => PrettyType (Scheme a b) where
310instance (PrettyType a, PrettyType b) => PrettyType (Scheme a b) where
260 pretty _ (Scheme rqs fqs (A _ constraint) headers) =
311 pretty _ (Scheme rqs fqs (A _ constraint) headers) =
261 P.sep [ forall, cs, headers' ]
312 P.sep [ forall, cs, headers' ]
@@ -281,6 +332,9 @@ instance (PrettyType a, PrettyType b) => PrettyType (Scheme a b) where
281extraPretty :: (PrettyType t, Crawl t) => t -> IO Doc
332extraPretty :: (PrettyType t, Crawl t) => t -> IO Doc
282extraPretty t = pretty Never <$> addNames t
333extraPretty t = pretty Never <$> addNames t
283
334
335+
336+-- ADDING NAMES TO TYPES
337+
284addNames :: (Crawl t) => t -> IO t
338addNames :: (Crawl t) => t -> IO t
285addNames value = do
339addNames value = do
286 (rawVars, _, _, _) <- execStateT (crawl getNames value) ([], 0, 0, 0)
340 (rawVars, _, _, _) <- execStateT (crawl getNames value) ([], 0, 0, 0)
@@ -309,8 +363,12 @@ addNames value = do
309 where
363 where
310 local v = Just (Var.local v)
364 local v = Just (Var.local v)
311
365
366+
367+-- CRAWLING OVER TYPES
368+
312type CrawlState = ([String], Int, Int, Int)
369type CrawlState = ([String], Int, Int, Int)
313
370
371+
314-- Code for traversing all the type data-structures and giving
372-- Code for traversing all the type data-structures and giving
315-- names to the variables embedded deep in there.
373-- names to the variables embedded deep in there.
316class Crawl t where
374class Crawl t where
@@ -318,9 +376,11 @@ class Crawl t where
318 -> t
376 -> t
319 -> StateT CrawlState IO t
377 -> StateT CrawlState IO t
320
378
379+
321instance Crawl e => Crawl (Annotated a e) where
380instance Crawl e => Crawl (Annotated a e) where
322 crawl nextState (A ann e) = A ann <$> crawl nextState e
381 crawl nextState (A ann e) = A ann <$> crawl nextState e
323
382
383+
324instance (Crawl t, Crawl v) => Crawl (BasicConstraint t v) where
384instance (Crawl t, Crawl v) => Crawl (BasicConstraint t v) where
325 crawl nextState constraint =
385 crawl nextState constraint =
326 let rnm = crawl nextState in
386 let rnm = crawl nextState in
@@ -332,19 +392,31 @@ instance (Crawl t, Crawl v) => Crawl (BasicConstraint t v) where
332 CLet schemes c -> CLet <$> crawl nextState schemes <*> crawl nextState c
392 CLet schemes c -> CLet <$> crawl nextState schemes <*> crawl nextState c
333 CInstance name tipe -> CInstance name <$> rnm tipe
393 CInstance name tipe -> CInstance name <$> rnm tipe
334
394
395+
335instance Crawl a => Crawl [a] where
396instance Crawl a => Crawl [a] where
336 crawl nextState list = mapM (crawl nextState) list
397 crawl nextState list = mapM (crawl nextState) list
337
398
399+
338instance (Crawl t, Crawl v) => Crawl (Scheme t v) where
400instance (Crawl t, Crawl v) => Crawl (Scheme t v) where
339 crawl nextState (Scheme rqs fqs c headers) =
401 crawl nextState (Scheme rqs fqs c headers) =
340− let rnm = crawl nextState in
402+ let rnm = crawl nextState
403+ in
404+ Scheme
405+ <$> rnm rqs
406+ <*> rnm fqs
341− Scheme <$> rnm rqs <*> rnm fqs <*> crawl nextState c <*> return headers
407+ <*> crawl nextState c
408+ <*> return headers
409+
342
410
343instance Crawl t => Crawl (TermN t) where
411instance Crawl t => Crawl (TermN t) where
344 crawl nextState tipe =
412 crawl nextState tipe =
345 case tipe of
413 case tipe of
414+ VarN a x ->
346− VarN a x -> VarN a <$> crawl nextState x
415+ VarN a <$> crawl nextState x
416+
417+ TermN a term ->
347− TermN a term -> TermN a <$> crawl nextState term
418+ TermN a <$> crawl nextState term
419+
348
420
349instance Crawl t => Crawl (Term1 t) where
421instance Crawl t => Crawl (Term1 t) where
350 crawl nextState term =
422 crawl nextState term =
@@ -357,30 +429,32 @@ instance Crawl t => Crawl (Term1 t) where
357 Record1 fields ext ->
429 Record1 fields ext ->
358 Record1 <$> traverse (mapM rnm) fields <*> rnm ext
430 Record1 <$> traverse (mapM rnm) fields <*> rnm ext
359
431
432+
360instance Crawl a => Crawl (UF.Point a) where
433instance Crawl a => Crawl (UF.Point a) where
361− crawl nextState point = do
434+ crawl nextState point =
362− desc <- liftIO $ UF.descriptor point
435+ do desc <- liftIO $ UF.descriptor point
363− desc' <- crawl nextState desc
436+ desc' <- crawl nextState desc
364− liftIO $ UF.setDescriptor point desc'
437+ liftIO $ UF.setDescriptor point desc'
365− return point
438+ return point
439+
366
440
367instance Crawl Descriptor where
441instance Crawl Descriptor where
368− crawl nextState desc = do
442+ crawl nextState desc =
369− state <- get
443+ do state <- get
370− let (name', state') = nextState desc state
444+ let (name', state') = nextState desc state
371− structure' <- traverse (crawl nextState) (structure desc)
445+ structure' <- traverse (crawl nextState) (structure desc)
372− put state'
446+ put state'
373− return $ desc { name = name', structure = structure' }
447+ return $ desc { name = name', structure = structure' }
374
448
375
449
376toSrcType :: Variable -> IO T.CanonicalType
450toSrcType :: Variable -> IO T.CanonicalType
377toSrcType var =
451toSrcType var =
378 go =<< addNames var
452 go =<< addNames var
379 where
453 where
380− go v = do
454+ go v =
381− desc <- UF.descriptor v
455+ do desc <- UF.descriptor v
382− srcType <- maybe (backupSrcType desc) termToSrcType (structure desc)
456+ srcType <- maybe (backupSrcType desc) termToSrcType (structure desc)
383− return $ maybe srcType (\name -> T.Aliased name srcType) (alias desc)
457+ return $ maybe srcType (\name -> T.Aliased name srcType) (alias desc)
384
458
385 backupSrcType desc =
459 backupSrcType desc =
386 case name desc of
460 case name desc of
@@ -426,18 +500,24 @@ toSrcType var =
426
500
427data AppStructure = List Variable | Tuple [Variable] | Other
501data AppStructure = List Variable | Tuple [Variable] | Other
428
502
503+
429collectApps :: Variable -> IO AppStructure
504collectApps :: Variable -> IO AppStructure
430collectApps var = go [] var
505collectApps var = go [] var
431 where
506 where
432 go vars var = do
507 go vars var = do
433 desc <- UF.descriptor var
508 desc <- UF.descriptor var
434 case (structure desc, vars) of
509 case (structure desc, vars) of
510+ (Nothing, [v]) ->
435− (Nothing, [v]) -> case name desc of
511+ case name desc of
436− Just n | Var.isList n -> return (List v)
512+ Just n | Var.isList n -> return (List v)
437− _ -> return Other
513+ _ -> return Other
514+
515+ (Nothing, vs) ->
438− (Nothing, vs) -> case name desc of
516+ case name desc of
439− Just n | Var.isTuple n -> return (Tuple vs)
517+ Just n | Var.isTuple n -> return (Tuple vs)
440− _ -> return Other
518+ _ -> return Other
519+
520+ (Just term, _) ->
441− (Just term, _) -> case term of
521+ case term of
442− App1 a b -> go (vars ++ [b]) a
522+ App1 a b -> go (vars ++ [b]) a
443− _ -> return Other
523+ _ -> return Other