@@ -197,15 +197,16 @@ instance (Pretty a, Pretty b) => Pretty (Scheme a b) where
197197 dict = P.parens . P.sep . P.punctuate P.comma . map prettyPair $ Map.toList headers
198198 prettyPair (n,t) = P.text n <+> P.text ":" <+> pretty t
199199
200−
201−prettyNames constraint = do
202− (_, rawVars) <- fold constraint [] getNames
200+extraPretty :: (Pretty t, Crawl t) => t -> IO Doc
201+extraPretty value = do
202+ (_, rawVars) <- runStateT (crawl getNames value) []
203203 let vars = map head . List.group $ List.sort rawVars
204204 letters = map (:[]) ['a'..'z']
205205 suffix s = map (++s)
206206 allVars = letters ++ suffix "'" letters ++ concatMap (\n -> suffix (show n) letters) [0..]
207207 okayVars = filter (`notElem` vars) allVars
208− fold constraint okayVars rename
208+ runStateT (crawl rename value) okayVars
209+ return (pretty value)
209210 where
210211 getNames name vars =
211212 case name of
@@ -217,39 +218,60 @@ prettyNames constraint = do
217218 Just var -> (name, vars)
218219 Nothing -> (Just (head vars), tail vars)
219220
220−fold constraint initialState func =
221− runStateT (prettyName constraint) initialState
222− where
223− prettyName constraint =
224− case constraint of
225− CTrue -> return CTrue
226− CEqual a b -> CEqual <$> prettyTypeName a <*> prettyTypeName b
227− CAnd cs -> CAnd <$> mapM prettyName cs
228− CLet schemes c -> CLet <$> mapM prettySchemeName schemes <*> prettyName c
229− CInstance name tipe -> CInstance name <$> prettyTypeName tipe
230−
231− prettySchemeName (Scheme rqs fqs c headers) =
232− Scheme <$> mapM prettyVarName rqs <*> mapM prettyVarName fqs <*> prettyName c <*> return headers
233−
234− prettyVarName point = do
235− state <- get
236− put =<< do desc <- liftIO $ UF.descriptor point
237− let (name', state') = func (name desc) state
238− liftIO $ UF.setDescriptor point (desc { name = name' })
239− return state'
240− return point
241−
242− prettyTypeName tipe =
243− case tipe of
244− VarN x -> VarN <$> prettyVarName x
245− TermN term -> TermN <$> prettyTermName term
246−
247− prettyTermName term =
248− case term of
249− App1 a b -> App1 <$> prettyTypeName a <*> prettyTypeName b
250− Fun1 a b -> Fun1 <$> prettyTypeName a <*> prettyTypeName b
251− Var1 a -> Var1 <$> prettyTypeName a
252− EmptyRecord1 -> return EmptyRecord1
253− Record1 fields ext -> Record1 <$> fields' <*> prettyTypeName ext
254− where
255− fields' = traverse (mapM prettyTypeName) fields
221+
222+-- Code for traversing all the type data-structures and giving
223+-- names to the variables embedded deep in there.
224+class Crawl t where
225+ crawl :: (Maybe TypeName -> [String] -> (Maybe TypeName, [String]))
226+ -> t
227+ -> StateT [String] IO t
228+
229+instance (Crawl t, Crawl v) => Crawl (Constraint t v) where
230+ crawl nextState constraint =
231+ let rnm = crawl nextState in
232+ case constraint of
233+ CTrue -> return CTrue
234+ CEqual a b -> CEqual <$> rnm a <*> rnm b
235+ CAnd cs -> CAnd <$> crawl nextState cs
236+ CLet schemes c -> CLet <$> crawl nextState schemes <*> crawl nextState c
237+ CInstance name tipe -> CInstance name <$> rnm tipe
238+
239+instance Crawl a => Crawl [a] where
240+ crawl nextState list = mapM (crawl nextState) list
241+
242+instance (Crawl t, Crawl v) => Crawl (Scheme t v) where
243+ crawl nextState (Scheme rqs fqs c headers) =
244+ let rnm = crawl nextState in
245+ Scheme <$> rnm rqs <*> rnm fqs <*> crawl nextState c <*> return headers
246+
247+instance Crawl t => Crawl (TermN t) where
248+ crawl nextState tipe =
249+ case tipe of
250+ VarN x -> VarN <$> crawl nextState x
251+ TermN term -> TermN <$> crawl nextState term
252+
253+instance Crawl t => Crawl (Term1 t) where
254+ crawl nextState term =
255+ let rnm = crawl nextState in
256+ case term of
257+ App1 a b -> App1 <$> rnm a <*> rnm b
258+ Fun1 a b -> Fun1 <$> rnm a <*> rnm b
259+ Var1 a -> Var1 <$> rnm a
260+ EmptyRecord1 -> return EmptyRecord1
261+ Record1 fields ext ->
262+ Record1 <$> traverse (mapM rnm) fields <*> rnm ext
263+
264+instance Crawl a => Crawl (UF.Point a) where
265+ crawl nextState point = do
266+ desc <- liftIO $ UF.descriptor point
267+ desc' <- crawl nextState desc
268+ liftIO $ UF.setDescriptor point desc'
269+ return point
270+
271+instance Crawl Descriptor where
272+ crawl nextState desc = do
273+ state <- get
274+ let (name', state') = nextState (name desc) state
275+ structure' <- traverse (crawl nextState) (structure desc)
276+ put state'
277+ return $ desc { name = name', structure = structure' }