@@ -3,7 +3,7 @@ module Type.Type where
33import qualified Data.List as List
44import qualified Data.Map as Map
55import qualified Data.UnionFind.IO as UF
6−import SourceSyntax.PrettyPrint
6+import Type.PrettyPrint
77import Text.PrettyPrint as P
88import System.IO.Unsafe
99import Control.Applicative ((<$>),(<*>))
@@ -30,6 +30,7 @@ type TypeName = String
3030
3131data Constraint a b
3232 = CTrue
33+ | CSaveEnv
3334 | CEqual a a
3435 | CAnd [Constraint a b]
3536 | CLet [Scheme a b] (Constraint a b)
@@ -72,6 +73,8 @@ type TypeScheme = Scheme Type Variable
7273infixl 8 /\
7374
7475(/\) :: Constraint a b -> Constraint a b -> Constraint a b
76+a /\ CTrue = a
77+CTrue /\ b = b
7578a /\ b = CAnd [a,b]
7679
7780(===) :: Type -> Type -> TypeConstraint
@@ -87,10 +90,10 @@ a ==> b = TermN (Fun1 a b)
8790f <| a = TermN (App1 f a)
8891
8992
90−namedVar name = UF.fresh $ Descriptor {
93+namedVar flex name = UF.fresh $ Descriptor {
9194 structure = Nothing,
9295 rank = noRank,
93− flex = Flexible,
96+ flex = flex,
9497 name = Just name,
9598 copy = Nothing,
9699 mark = noMark
@@ -131,50 +134,69 @@ exists f = do
131134instance Show a => Show (UF.Point a) where
132135 show point = unsafePerformIO $ fmap show (UF.descriptor point)
133136
134−instance Pretty a => Pretty (UF.Point a) where
135− pretty point = unsafePerformIO $ fmap pretty (UF.descriptor point)
136137
137−instance Pretty a => Pretty (Term1 a) where
138− pretty term =
138+instance PrettyType a => PrettyType (UF.Point a) where
139+ pretty when point = unsafePerformIO $ fmap (pretty when) (UF.descriptor point)
140+
141+
142+instance PrettyType a => PrettyType (Term1 a) where
143+ pretty when term =
144+ let prty = pretty Never in
139145 case term of
140− App1 f x -> pretty f <+> pretty x
141− Fun1 arg body -> formattedArg <+> P.text "->" <+> pretty body
146+ App1 f x ->
147+ parensIf needed (prty f <+> pretty App x)
142148 where
143− prettyArg = pretty arg
144− formattedArg = parensIf ("->" `List.isInfixOf` P.render prettyArg) prettyArg
145− Var1 x -> pretty x
149+ needed = case when of
150+ App -> True
151+ _ -> False
152+
153+ Fun1 arg body ->
154+ parensIf needed (pretty Fn arg <+> P.text "->" <+> prty body)
155+ where
156+ needed = case when of
157+ Never -> False
158+ _ -> True
159+
160+ Var1 x -> prty x
161+
146162 EmptyRecord1 -> P.braces P.empty
163+
147164 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)
149166 where
150− mkPretty f t = P.text f <+> P.text ":" <+> pretty t
167+ mkPretty f t = P.text f <+> P.text ":" <+> prty t
151168 prettyFields = concatMap (\(f,ts) -> map (mkPretty f) ts) (Map.toList fields)
152169
153−instance Pretty a => Pretty (TermN a) where
154− pretty term =
170+
171+instance PrettyType a => PrettyType (TermN a) where
172+ pretty when term =
155173 case term of
156− VarN x -> pretty x
157− TermN t1 -> pretty t1
174+ VarN x -> pretty when x
175+ TermN t1 -> pretty when t1
158176
159−instance Pretty Descriptor where
160− pretty desc =
177+
178+instance PrettyType Descriptor where
179+ pretty when desc =
161180 case (structure desc, name desc) of
162− (Just term, _) -> pretty term
181+ (Just term, _) -> pretty when term
163182 (_, Just name) -> P.text name
164183 _ -> P.text "?"
165184
166−instance (Pretty a, Pretty b) => Pretty (Constraint a b) where
167− pretty constraint =
185+
186+instance (PrettyType a, PrettyType b) => PrettyType (Constraint a b) where
187+ pretty _ constraint =
188+ let prty = pretty Never in
168189 case constraint of
169190 CTrue -> P.text "True"
170− CEqual a b -> pretty a <+> P.text "=" <+> pretty b
191+ CSaveEnv -> P.text "SaveTheEnvironment!!!"
192+ CEqual a b -> prty a <+> P.text "=" <+> prty b
171193 CAnd [] -> P.text "True"
172194
173195 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)
175197
176198 CLet [Scheme [] fqs constraint header] CTrue | Map.null header ->
177− P.sep [ binder, pretty c ]
199+ P.sep [ binder, pretty Never c ]
178200 where
179201 mergeExists vs c =
180202 case c of
@@ -184,44 +206,46 @@ instance (Pretty a, Pretty b) => Pretty (Constraint a b) where
184206 (fqs', c) = mergeExists fqs constraint
185207
186208 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 "."
188210
189211 CLet schemes constraint ->
190− P.fsep [ P.hang (P.text "let") 4 (P.brackets . P.sep . P.punctuate P.comma $ map pretty schemes)
191− , P.text "in", pretty constraint ]
212+ P.fsep [ P.hang (P.text "let") 4 (P.brackets . commaSep $ map (pretty Never) schemes)
213+ , P.text "in", pretty Never constraint ]
192214
193215 CInstance name tipe ->
194− P.text name <+> P.text "<" <+> pretty tipe
216+ P.text name <+> P.text "<" <+> prty tipe
195217
196−instance (Pretty a, Pretty b) => Pretty (Scheme a b) where
197− pretty (Scheme rqs fqs constraint headers) =
218+instance (PrettyType a, PrettyType b) => PrettyType (Scheme a b) where
219+ pretty _ (Scheme rqs fqs constraint headers) =
198220 P.sep [ forall, cs, headers' ]
199221 where
222+ prty = pretty Never
223+
200224 forall = if null rqs && null fqs then P.empty else
201− P.text "forall" <+> frees <+> rigids
225+ P.text "\x2200" <+> frees <+> rigids
202226
203− frees = P.hsep $ map pretty fqs
204− rigids = if null rqs then P.empty else P.braces . P.hsep $ map pretty rqs
227+ frees = P.hsep $ map prty fqs
228+ rigids = if null rqs then P.empty else P.braces . P.hsep $ map prty rqs
205229
206230 cs = case constraint of
207231 CTrue -> P.empty
208232 CAnd [] -> P.empty
209− _ -> P.brackets (pretty constraint)
233+ _ -> P.brackets (pretty Never constraint)
210234
211235 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
213− prettyPair (n,t) = P.text n <+> P.text ":" <+> pretty t
236+ dict = P.parens . commaSep . map prettyPair $ Map.toList headers
237+ prettyPair (n,t) = P.text n <+> P.text ":" <+> pretty Never t
238+
214239
215−extraPretty :: (Pretty t, Crawl t) => t -> IO Doc
240+extraPretty :: (PrettyType t, Crawl t) => t -> IO Doc
216241extraPretty value = do
217242 (_, rawVars) <- runStateT (crawl getNames value) []
218243 let vars = map head . List.group $ List.sort rawVars
219− letters = map (:[]) ['a'..'z']
220− suffix s = map (++s)
221− allVars = letters ++ suffix "'" letters ++ concatMap (\n -> suffix (show n) letters) [0..]
244+ suffix s = map (++s) (map (:[]) ['a'..'z'])
245+ allVars = concatMap suffix $ ["","'","_"] ++ map show [0..]
222246 okayVars = filter (`notElem` vars) allVars
223247 runStateT (crawl rename value) okayVars
224− return (pretty value)
248+ return (pretty Never value)
225249 where
226250 getNames name vars =
227251 case name of
@@ -232,7 +256,7 @@ extraPretty value = do
232256 case name of
233257 Just var -> (name, vars)
234258 Nothing -> (Just (head vars), tail vars)
235−
259+--}
236260
237261-- Code for traversing all the type data-structures and giving
238262-- names to the variables embedded deep in there.
@@ -246,6 +270,7 @@ instance (Crawl t, Crawl v) => Crawl (Constraint t v) where
246270 let rnm = crawl nextState in
247271 case constraint of
248272 CTrue -> return CTrue
273+ CSaveEnv -> return CSaveEnv
249274 CEqual a b -> CEqual <$> rnm a <*> rnm b
250275 CAnd cs -> CAnd <$> crawl nextState cs
251276 CLet schemes c -> CLet <$> crawl nextState schemes <*> crawl nextState c