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