@@ -3,7 +3,7 @@ module Type.Type where
3import qualified Data.List as List
3import qualified Data.List as List
4import qualified Data.Map as Map
4import qualified Data.Map as Map
5import qualified Data.UnionFind.IO as UF
5import qualified Data.UnionFind.IO as UF
6−import SourceSyntax.PrettyPrint
6+import Type.PrettyPrint
7import Text.PrettyPrint as P
7import Text.PrettyPrint as P
8import System.IO.Unsafe
8import System.IO.Unsafe
9import Control.Applicative ((<$>),(<*>))
9import Control.Applicative ((<$>),(<*>))
@@ -30,6 +30,7 @@ type TypeName = String
31data Constraint a b
31data Constraint a b
33 | CEqual a a
34 | CEqual a a
34 | CAnd [Constraint a b]
35 | CAnd [Constraint a b]
35 | CLet [Scheme a b] (Constraint a b)
36 | CLet [Scheme a b] (Constraint a b)
@@ -72,6 +73,8 @@ type TypeScheme = Scheme Type Variable
72infixl 8 /\
73infixl 8 /\
74(/\) :: Constraint a b -> Constraint a b -> Constraint a b
75(/\) :: Constraint a b -> Constraint a b -> Constraint a b
75a /\ b = CAnd [a,b]
78a /\ b = CAnd [a,b]
77(===) :: Type -> Type -> TypeConstraint
80(===) :: Type -> Type -> TypeConstraint
@@ -87,10 +90,10 @@ a ==> b = TermN (Fun1 a b)
87f <| a = TermN (App1 f a)
90f <| a = TermN (App1 f a)
90−namedVar name = UF.fresh $ Descriptor {
93+namedVar flex name = UF.fresh $ Descriptor {
91 structure = Nothing,
94 structure = Nothing,
92 rank = noRank,
95 rank = noRank,
93− flex = Flexible,
96+ flex = flex,
94 name = Just name,
97 name = Just name,
95 copy = Nothing,
98 copy = Nothing,
96 mark = noMark
99 mark = noMark
@@ -131,50 +134,69 @@ exists f = do
131instance Show a => Show (UF.Point a) where
134instance Show a => Show (UF.Point a) where
132 show point = unsafePerformIO $ fmap show (UF.descriptor point)
135 show point = unsafePerformIO $ fmap show (UF.descriptor point)
134−instance Pretty a => Pretty (UF.Point a) where
135− pretty point = unsafePerformIO $ fmap pretty (UF.descriptor point)
137−instance Pretty a => Pretty (Term1 a) where
138+instance PrettyType a => PrettyType (UF.Point a) where
139+ pretty when point = unsafePerformIO $ fmap (pretty when) (UF.descriptor point)
142+instance PrettyType a => PrettyType (Term1 a) where
138− pretty term =
143+ pretty when term =
144+ let prty = pretty Never in
139 case term of
145 case term of
140− App1 f x -> pretty f <+> pretty x
146+ App1 f x ->
141− Fun1 arg body -> formattedArg <+> P.text "->" <+> pretty body
147+ parensIf needed (prty f <+> pretty App x)
143− prettyArg = pretty arg
149+ needed = case when of
144− formattedArg = parensIf ("->" `List.isInfixOf` P.render prettyArg) prettyArg
150+ App -> True
154+ parensIf needed (pretty Fn arg <+> P.text "->" <+> prty body)
156+ needed = case when of
145− Var1 x -> pretty x
160+ Var1 x -> prty x
146 EmptyRecord1 -> P.braces P.empty
162 EmptyRecord1 -> P.braces P.empty
147 Record1 fields ext ->
164 Record1 fields ext ->
148− P.braces (pretty ext <+> P.text "|" <+> P.sep (P.punctuate P.comma prettyFields))
165+ P.braces (prty ext <+> P.text "|" <+> commaSep prettyFields)
150− mkPretty f t = P.text f <+> P.text ":" <+> pretty t
167+ mkPretty f t = P.text f <+> P.text ":" <+> prty t
151 prettyFields = concatMap (\(f,ts) -> map (mkPretty f) ts) (Map.toList fields)
168 prettyFields = concatMap (\(f,ts) -> map (mkPretty f) ts) (Map.toList fields)
153−instance Pretty a => Pretty (TermN a) where
171+instance PrettyType a => PrettyType (TermN a) where
154− pretty term =
172+ pretty when term =
155 case term of
173 case term of
156− VarN x -> pretty x
174+ VarN x -> pretty when x
157− TermN t1 -> pretty t1
175+ TermN t1 -> pretty when t1
159−instance Pretty Descriptor where
178+instance PrettyType Descriptor where
160− pretty desc =
179+ pretty when desc =
161 case (structure desc, name desc) of
180 case (structure desc, name desc) of
162− (Just term, _) -> pretty term
181+ (Just term, _) -> pretty when term
163 (_, Just name) -> P.text name
182 (_, Just name) -> P.text name
164 _ -> P.text "?"
183 _ -> P.text "?"
166−instance (Pretty a, Pretty b) => Pretty (Constraint a b) where
186+instance (PrettyType a, PrettyType b) => PrettyType (Constraint a b) where
167− pretty constraint =
187+ pretty _ constraint =
188+ let prty = pretty Never in
168 case constraint of
189 case constraint of
169 CTrue -> P.text "True"
190 CTrue -> P.text "True"
191+ CSaveEnv -> P.text "SaveTheEnvironment!!!"
170− CEqual a b -> pretty a <+> P.text "=" <+> pretty b
192+ CEqual a b -> prty a <+> P.text "=" <+> prty b
171 CAnd [] -> P.text "True"
193 CAnd [] -> P.text "True"
173 CAnd cs ->
195 CAnd cs ->
174− P.parens . P.sep $ P.punctuate (P.text " and") (map pretty cs)
196+ P.parens . P.sep $ P.punctuate (P.text " and") (map (pretty Never) cs)
176 CLet [Scheme [] fqs constraint header] CTrue | Map.null header ->
198 CLet [Scheme [] fqs constraint header] CTrue | Map.null header ->
177− P.sep [ binder, pretty c ]
199+ P.sep [ binder, pretty Never c ]
179 mergeExists vs c =
201 mergeExists vs c =
180 case c of
202 case c of
@@ -184,44 +206,46 @@ instance (Pretty a, Pretty b) => Pretty (Constraint a b) where
184 (fqs', c) = mergeExists fqs constraint
206 (fqs', c) = mergeExists fqs constraint
186 binder = if null fqs' then P.empty else
208 binder = if null fqs' then P.empty else
187− P.text "exists" <+> P.hsep (map pretty fqs') <> P.text "."
209+ P.text "\x2203" <+> P.hsep (map (pretty Never) fqs') <> P.text "."
189 CLet schemes constraint ->
211 CLet schemes constraint ->
190− P.fsep [ P.hang (P.text "let") 4 (P.brackets . P.sep . P.punctuate P.comma $ map pretty schemes)
212+ P.fsep [ P.hang (P.text "let") 4 (P.brackets . commaSep $ map (pretty Never) schemes)
191− , P.text "in", pretty constraint ]
213+ , P.text "in", pretty Never constraint ]
193 CInstance name tipe ->
215 CInstance name tipe ->
194− P.text name <+> P.text "<" <+> pretty tipe
216+ P.text name <+> P.text "<" <+> prty tipe
196−instance (Pretty a, Pretty b) => Pretty (Scheme a b) where
218+instance (PrettyType a, PrettyType b) => PrettyType (Scheme a b) where
197− pretty (Scheme rqs fqs constraint headers) =
219+ pretty _ (Scheme rqs fqs constraint headers) =
198 P.sep [ forall, cs, headers' ]
220 P.sep [ forall, cs, headers' ]
200 forall = if null rqs && null fqs then P.empty else
224 forall = if null rqs && null fqs then P.empty else
201− P.text "forall" <+> frees <+> rigids
225+ P.text "\x2200" <+> frees <+> rigids
203− frees = P.hsep $ map pretty fqs
227+ frees = P.hsep $ map prty fqs
204− rigids = if null rqs then P.empty else P.braces . P.hsep $ map pretty rqs
228+ rigids = if null rqs then P.empty else P.braces . P.hsep $ map prty rqs
206 cs = case constraint of
230 cs = case constraint of
207 CTrue -> P.empty
231 CTrue -> P.empty
208 CAnd [] -> P.empty
232 CAnd [] -> P.empty
209− _ -> P.brackets (pretty constraint)
233+ _ -> P.brackets (pretty Never constraint)
211 headers' = if Map.size headers > 0 then dict else P.empty
235 headers' = if Map.size headers > 0 then dict else P.empty
212− dict = P.parens . P.sep . P.punctuate P.comma . map prettyPair $ Map.toList headers
236+ dict = P.parens . commaSep . map prettyPair $ Map.toList headers
213− prettyPair (n,t) = P.text n <+> P.text ":" <+> pretty t
237+ prettyPair (n,t) = P.text n <+> P.text ":" <+> pretty Never t
215−extraPretty :: (Pretty t, Crawl t) => t -> IO Doc
240+extraPretty :: (PrettyType t, Crawl t) => t -> IO Doc
216extraPretty value = do
241extraPretty value = do
217 (_, rawVars) <- runStateT (crawl getNames value) []
242 (_, rawVars) <- runStateT (crawl getNames value) []
218 let vars = map head . List.group $ List.sort rawVars
243 let vars = map head . List.group $ List.sort rawVars
219− letters = map (:[]) ['a'..'z']
244+ suffix s = map (++s) (map (:[]) ['a'..'z'])
220− suffix s = map (++s)
221− allVars = letters ++ suffix "'" letters ++ concatMap (\n -> suffix (show n) letters) [0..]
245+ allVars = concatMap suffix $ ["","'","_"] ++ map show [0..]
222 okayVars = filter (`notElem` vars) allVars
246 okayVars = filter (`notElem` vars) allVars
223 runStateT (crawl rename value) okayVars
247 runStateT (crawl rename value) okayVars
224− return (pretty value)
248+ return (pretty Never value)
226 getNames name vars =
250 getNames name vars =
227 case name of
251 case name of
@@ -232,7 +256,7 @@ extraPretty value = do
232 case name of
256 case name of
233 Just var -> (name, vars)
257 Just var -> (name, vars)
234 Nothing -> (Just (head vars), tail vars)
258 Nothing -> (Just (head vars), tail vars)
237-- Code for traversing all the type data-structures and giving
261-- Code for traversing all the type data-structures and giving
238-- names to the variables embedded deep in there.
262-- names to the variables embedded deep in there.
@@ -246,6 +270,7 @@ instance (Crawl t, Crawl v) => Crawl (Constraint t v) where
246 let rnm = crawl nextState in
270 let rnm = crawl nextState in
247 case constraint of
271 case constraint of
248 CTrue -> return CTrue
272 CTrue -> return CTrue
273+ CSaveEnv -> return CSaveEnv
249 CEqual a b -> CEqual <$> rnm a <*> rnm b
274 CEqual a b -> CEqual <$> rnm a <*> rnm b
250 CAnd cs -> CAnd <$> crawl nextState cs
275 CAnd cs -> CAnd <$> crawl nextState cs
251 CLet schemes c -> CLet <$> crawl nextState schemes <*> crawl nextState c
276 CLet schemes c -> CLet <$> crawl nextState schemes <*> crawl nextState c