git.iko.soy/elk
on 63243ca help sign in
elk/compiler/Type/Alias.hs
139 lines 5.0 kB history raw
1{-# OPTIONS_GHC -W #-}
2module Type.Alias (realias, rules, canonicalRealias, Rules) where
4import Control.Applicative ((<$>),(<*>))
5import Control.Monad
6import Control.Arrow (second)
7import Data.Map ((!))
8import qualified Data.Map as Map
9import qualified Data.List as List
10import SourceSyntax.Type
11import SourceSyntax.Module
13type Rules = ([Alias], Type -> Type)
15rules interfaces moduleAliases moduleImports =
16 (collect interfaces moduleAliases, localizer moduleImports)
18collect interfaces moduleAliases =
19 filter (not . isPrimitive) rawAliases
20 where
21 rawAliases =
22 moduleAliases ++ concatMap iAliases (Map.elems interfaces)
24 isPrimitive (_,_,tipe,_) =
25 case tipe of
26 Data _ [] -> True
27 _ -> False
29localizer moduleImports = go
30 where
31 go tipe =
32 case tipe of
33 Var _ -> 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) 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 Lambda t1 t2 -> Lambda (f t1) (f t2)
87 Data name ts -> Data name (map f ts)
88 Record fs ext -> Record (map (second f) fs) ext
90allEqual [] = True
91allEqual (x:xs) = all (==x) xs
93bestType tipes = fst $ List.minimumBy (\a b -> compare (snd a) (snd b)) pairs
94 where
95 pairs :: [(Type,Int)]
96 pairs = zip tipes (map numFields tipes)
98 numFields :: Type -> Int
99 numFields tipe =
100 case tipe of
101 Lambda t1 t2 -> numFields t1 + numFields t2
102 Var _ -> 0
103 Data _ ts -> sum (map numFields ts)
104 Record fields _ -> length fields + sum (map (numFields . snd) fields)
106diff :: Type -> Type -> Maybe [(String,Type)]
107diff general specific =
108 case (general, specific) of
109 (Lambda g1 g2, Lambda s1 s2) -> (++) <$> diff g1 s1 <*> diff g2 s2
110 (Var x, t) -> Just [(x,t)]
111 (Data gname gts, Data sname sts)
112 | gname == sname && length gts == length sts ->
113 concat <$> zipWithM diff gts sts
114 (Record [] Nothing, Record [] Nothing) -> Just []
115 (Record _ _, Record [] Nothing) -> Nothing
116 (Record [] Nothing, Record _ _) -> Nothing
117 (Record gfs gext, Record sfs sext) ->
118 let gfields = collectFields gfs
119 sfields = collectFields sfs
121 overlap = Map.intersectionWith (\gs ss -> length gs == length ss) sfields gfields
122 isAligned = Map.size gfields == Map.size overlap && and (Map.elems overlap)
123 in
124 case isAligned of
125 False -> Nothing
126 True -> let remaining = Map.difference sfields gfields
127 sext' = case sext of
128 Just x | Map.null remaining -> Var x
129 _ -> Record (flattenFields remaining) sext
130 gext' = maybe (Record [] Nothing) Var gext
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)