@@ -0,0 +1,119 @@
1+module Type.Alias (realias, rules, canonicalRealias, Rules) where
2+
3+import Control.Applicative ((<$>),(<*>))
4+import Control.Monad
5+import Control.Arrow (second)
6+import Data.Map ((!))
7+import qualified Data.Map as Map
8+import qualified Data.List as List
9+import SourceSyntax.Type
10+import SourceSyntax.Module
11+
12+type Rules = ([(String,[String],Type)], Type -> Type)
13+
14+rules interfaces metaModule = (collect interfaces metaModule, localizer metaModule)
15+
16+collect interfaces metaModule = filter (not . isPrimitive) rawAliases
17+ where
18+ rawAliases = aliases metaModule ++ concatMap iAliases (Map.elems interfaces)
19+
20+ isPrimitive (_,_,tipe) =
21+ case tipe of
22+ Data _ [] -> True
23+ _ -> False
24+
25+localizer metaModule = go
26+ where
27+ go tipe =
28+ case tipe of
29+ Var _ -> tipe
30+ EmptyRecord -> tipe
31+ Lambda t1 t2 -> Lambda (go t1) (go t2)
32+ Data name ts -> Data (localize name) (map go ts)
33+ Record fs ext -> Record (map (second go) fs) (go ext)
34+
35+ byMethod = foldr (\(n,m) d -> Map.insertWith (++) n [m] d) Map.empty (imports metaModule)
36+
37+ separate name =
38+ case List.elemIndices '.' name of
39+ [] -> ("",name)
40+ is -> let i = last is in
41+ (take i name, drop (i+1) name)
42+
43+ shortest = List.minimumBy (\a b -> compare (length a) (length b))
44+
45+ localize name = shortest (name : concatMap (localize' value) methods)
46+ where (modul, value) = separate name
47+ methods = Map.findWithDefault [] modul byMethod
48+
49+ localize' name method =
50+ case method of
51+ As modul -> [modul ++ "." ++ name]
52+ Hiding xs | name `notElem` xs -> [name]
53+ Importing xs | name `elem` xs -> [name]
54+ _ -> []
55+
56+realias :: Rules -> Type -> Type
57+realias (aliases,localize) tipe = localize (canonicalRealias aliases tipe)
58+
59+canonicalRealias :: [(String,[String],Type)] -> Type -> Type
60+canonicalRealias aliases tipe =
61+ case concatMap tryRealias aliases of
62+ [tipe''] -> f tipe''
63+ _ -> if tipe == tipe' then tipe else f tipe'
64+ where
65+ tryRealias (name, args, t) =
66+ case diff t tipe of
67+ Nothing -> []
68+ Just kvs ->
69+ let holes = collectFields kvs
70+ hasArgs = List.sort args == Map.keys holes
71+ isConsistent = all allEqual (Map.elems holes)
72+ in case hasArgs && isConsistent of
73+ False -> []
74+ True -> [Data name $ map (\arg -> head (holes ! arg)) args]
75+
76+ f = canonicalRealias aliases
77+ tipe' =
78+ case tipe of
79+ Var _ -> tipe
80+ EmptyRecord -> tipe
81+ Lambda t1 t2 -> Lambda (f t1) (f t2)
82+ Data name ts -> Data name (map f ts)
83+ Record fs ext -> Record (map (second f) fs) (f ext)
84+
85+allEqual [] = True
86+allEqual (x:xs) = all (==x) xs
87+
88+diff :: Type -> Type -> Maybe [(String,Type)]
89+diff general specific =
90+ case (general, specific) of
91+ (Lambda g1 g2, Lambda s1 s2) -> (++) <$> diff g1 s1 <*> diff g2 s2
92+ (Var x, t) -> Just [(x,t)]
93+ (Data gname gts, Data sname sts)
94+ | gname == sname && length gts == length sts ->
95+ concat <$> zipWithM diff gts sts
96+ (EmptyRecord, EmptyRecord) -> Just []
97+ (Record _ _, Record _ _) ->
98+ let (gfs,gext) = collectRecords general
99+ (sfs,sext) = collectRecords specific
100+ gfields = collectFields gfs
101+ sfields = collectFields sfs
102+
103+ overlap = Map.intersectionWith (\gs ss -> length gs == length ss) sfields gfields
104+ isAligned = Map.size gfields == Map.size overlap && and (Map.elems overlap)
105+ in
106+ case isAligned of
107+ False -> Nothing
108+ True -> let remaining = Map.difference sfields gfields
109+ sext' = if Map.null remaining then sext else
110+ Record (flattenFields remaining) sext
111+ matchMap = Map.intersectionWith (zipWith diff) gfields sfields
112+ in concat <$> sequence (diff gext sext' : concat (Map.elems matchMap))
113+ (_,_) -> Nothing
114+
115+collectFields fields =
116+ foldr (\(f,t) fs -> Map.insertWith (++) f [t] fs) Map.empty fields
117+
118+flattenFields fields =
119+ concatMap (\(f,ts) -> map ((,) f) ts) (Map.toList fields)