@@ -1,148 +0,0 @@
1−{-# OPTIONS_GHC -W #-}
2−module Type.Alias (realias, rules, canonicalRealias, Rules) where
3−
4−import Control.Applicative ((<$>),(<*>))
5−import Control.Monad
6−import Control.Arrow (second)
7−import Data.Map ((!))
8−import qualified Data.Map as Map
9−import qualified Data.List as List
10−import AST.Type
11−import AST.Module
12−
13−type Rules = (Aliases, CanonicalType -> CanonicalType)
14−
15−rules interfaces moduleAliases moduleImports = (Map.empty, id)
16− --(error "Type.Alias.rules is not defined")
17− --(collect interfaces moduleAliases, localizer moduleImports)
18−{--
19−collect interfaces moduleAliases =
20− filter (not . isPrimitive) rawAliases
21− where
22− rawAliases =
23− moduleAliases ++ concatMap iAliases (Map.elems interfaces)
24−
25− isPrimitive (_,_,tipe) =
26− case tipe of
27− Data _ [] -> True
28− _ -> False
29−--}
30−{--
31−localizer moduleImports = go
32− where
33− go tipe =
34− case tipe of
35− Var _ -> tipe
36− Lambda t1 t2 -> Lambda (go t1) (go t2)
37− Data name ts -> Data (localize name) (map go ts)
38− Record fs ext -> Record (map (second go) fs) ext
39−
40− byMethod = foldr (\(n,m) d -> Map.insertWith (++) n [m] d)
41− Map.empty moduleImports
42−
43− separate name =
44− case List.elemIndices '.' name of
45− [] -> ("",name)
46− is -> let i = last is in
47− (take i name, drop (i+1) name)
48−
49− shortest = List.minimumBy (\a b -> compare (length a) (length b))
50−
51− localize name = shortest (name : concatMap (localize' value) methods)
52− where (modul, value) = separate name
53− methods = Map.findWithDefault [] modul byMethod
54−
55− localize' name method =
56− case method of
57− As modul -> [modul ++ "." ++ name]
58− Hiding xs | name `notElem` xs -> [name]
59− Importing xs | name `elem` xs -> [name]
60− _ -> []
61−--}
62−realias :: Rules -> CanonicalType -> CanonicalType
63−realias (aliases,localize) tipe = tipe
64− -- (error "Type.Alias.realias is not defined")
65− -- localize (canonicalRealias aliases tipe)
66−
67−-- Realias using canonical aliases, so results will have aliases
68−-- that are fully qualified and possible to compare.
69−canonicalRealias :: Aliases -> CanonicalType -> CanonicalType
70−canonicalRealias aliases tipe = tipe
71−-- (error "Type.Alias.rules is not defined")
72−{--
73− case concatMap tryRealias aliases of
74− [] -> if tipe == tipe' then tipe else f tipe'
75− tipes -> f (bestType tipes)
76− where
77− tryRealias (name, args, aliasTipe) =
78− case diff aliasTipe tipe of
79− Nothing -> []
80− Just kvs ->
81− let holes = collectFields kvs
82− hasArgs = List.sort args == Map.keys holes
83− isConsistent = all allEqual (Map.elems holes)
84− in case hasArgs && isConsistent of
85− False -> []
86− True -> [Data name $ map (\arg -> head (holes ! arg)) args]
87−
88− f = canonicalRealias aliases
89− tipe' =
90− case tipe of
91− Var _ -> tipe
92− Lambda t1 t2 -> Lambda (f t1) (f t2)
93− Data name ts -> Data name (map f ts)
94− Record fs ext -> Record (map (second f) fs) ext
95−--}
96−
97−allEqual [] = True
98−allEqual (x:xs) = all (==x) xs
99−
100−{--
101−bestType tipes = fst $ List.minimumBy (\a b -> compare (snd a) (snd b)) pairs
102− where
103− pairs :: [(Type,Int)]
104− pairs = zip tipes (map numFields tipes)
105−
106− numFields :: Type -> Int
107− numFields tipe =
108− case tipe of
109− Lambda t1 t2 -> numFields t1 + numFields t2
110− Var _ -> 0
111− Data _ ts -> sum (map numFields ts)
112− Record fields _ -> length fields + sum (map (numFields . snd) fields)
113−
114−diff :: CanonicalType -> CanonicalType -> Maybe [(String,CanonicalType)]
115−diff general specific =
116− case (general, specific) of
117− (Lambda g1 g2, Lambda s1 s2) -> (++) <$> diff g1 s1 <*> diff g2 s2
118− (Var x, t) -> Just [(x,t)]
119− (Data gname gts, Data sname sts)
120− | gname == sname && length gts == length sts ->
121− concat <$> zipWithM diff gts sts
122− (Record [] Nothing, Record [] Nothing) -> Just []
123− (Record _ _, Record [] Nothing) -> Nothing
124− (Record [] Nothing, Record _ _) -> Nothing
125− (Record gfs gext, Record sfs sext) ->
126− let gfields = collectFields gfs
127− sfields = collectFields sfs
128−
129− overlap = Map.intersectionWith (\gs ss -> length gs == length ss) sfields gfields
130− isAligned = Map.size gfields == Map.size overlap && and (Map.elems overlap)
131− in
132− case isAligned of
133− False -> Nothing
134− True -> let remaining = Map.difference sfields gfields
135− sext' = case sext of
136− Just x | Map.null remaining -> Var x
137− _ -> Record (flattenFields remaining) sext
138− gext' = maybe (Record [] Nothing) Var gext
139− matchMap = Map.intersectionWith (zipWith diff) gfields sfields
140− in concat <$> sequence (diff gext' sext' : concat (Map.elems matchMap))
141− (_,_) -> Nothing
142−
143−collectFields fields =
144− foldr (\(f,t) fs -> Map.insertWith (++) f [t] fs) Map.empty fields
145−
146−flattenFields fields =
147− concatMap (\(f,ts) -> map ((,) f) ts) (Map.toList fields)
148−--}