git.iko.soy/elk
on f4401ac help sign in
elk/compiler/src/Elm/Interface.hs
254 lines 6.0 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Elm.Interface
3 ( Interface(..)
4 , Union(..)
5 , Alias(..)
6 , Binop(..)
7 , fromModule
8 , toPublicUnion
9 , toPublicAlias
10 , DependencyInterface(..)
11 , public
12 , private
13 , privatize
14 , extractUnion
15 , extractAlias
16 )
17 where
20import Control.Monad (liftM, liftM3, liftM4, liftM5)
21import Data.Binary
22import Data.Map.Strict ((!))
23import qualified Data.Map.Strict as Map
24import qualified Data.Map.Merge.Strict as Map
25import qualified Data.Name as Name
27import qualified AST.Canonical as Can
28import qualified AST.Utils.Binop as Binop
29import qualified Elm.Package as Pkg
30import qualified Reporting.Annotation as A
34-- INTERFACE
37data Interface =
38 Interface
39 { _home :: Pkg.Name
40 , _values :: Map.Map Name.Name Can.Annotation
41 , _unions :: Map.Map Name.Name Union
42 , _aliases :: Map.Map Name.Name Alias
43 , _binops :: Map.Map Name.Name Binop
44 }
45 deriving (Eq)
48data Union
49 = OpenUnion Can.Union
50 | ClosedUnion Can.Union
51 | PrivateUnion Can.Union
52 deriving (Eq)
55data Alias
56 = PublicAlias Can.Alias
57 | PrivateAlias Can.Alias
58 deriving (Eq)
61data Binop =
62 Binop
63 { _op_name :: Name.Name
64 , _op_annotation :: Can.Annotation
65 , _op_associativity :: Binop.Associativity
66 , _op_precedence :: Binop.Precedence
67 }
68 deriving (Eq)
72-- FROM MODULE
75fromModule :: Pkg.Name -> Can.Module -> Map.Map Name.Name Can.Annotation -> Interface
76fromModule home (Can.Module _ exports _ _ unions aliases binops _) annotations =
77 Interface
78 { _home = home
79 , _values = restrict exports annotations
80 , _unions = restrictUnions exports unions
81 , _aliases = restrictAliases exports aliases
82 , _binops = restrict exports (Map.map (toOp annotations) binops)
83 }
86restrict :: Can.Exports -> Map.Map Name.Name a -> Map.Map Name.Name a
87restrict exports dict =
88 case exports of
89 Can.ExportEverything _ ->
90 dict
92 Can.Export explicitExports ->
93 Map.intersection dict explicitExports
96toOp :: Map.Map Name.Name Can.Annotation -> Can.Binop -> Binop
97toOp types (Can.Binop_ associativity precedence name) =
98 Binop name (types ! name) associativity precedence
101restrictUnions :: Can.Exports -> Map.Map Name.Name Can.Union -> Map.Map Name.Name Union
102restrictUnions exports unions =
103 case exports of
104 Can.ExportEverything _ ->
105 Map.map OpenUnion unions
107 Can.Export explicitExports ->
108 Map.merge onLeft onRight onBoth explicitExports unions
109 where
110 onLeft = Map.dropMissing
111 onRight = Map.mapMissing (\_ union -> PrivateUnion union)
112 onBoth = Map.zipWithMatched $ \_ (A.At _ export) union ->
113 case export of
114 Can.ExportUnionOpen -> OpenUnion union
115 Can.ExportUnionClosed -> ClosedUnion union
116 _ -> error "impossible exports discovered in restrictUnions"
119restrictAliases :: Can.Exports -> Map.Map Name.Name Can.Alias -> Map.Map Name.Name Alias
120restrictAliases exports aliases =
121 case exports of
122 Can.ExportEverything _ ->
123 Map.map PublicAlias aliases
125 Can.Export explicitExports ->
126 Map.merge onLeft onRight onBoth explicitExports aliases
127 where
128 onLeft = Map.dropMissing
129 onRight = Map.mapMissing (\_ a -> PrivateAlias a)
130 onBoth = Map.zipWithMatched (\_ _ a -> PublicAlias a)
134-- TO PUBLIC
137toPublicUnion :: Union -> Maybe Can.Union
138toPublicUnion iUnion =
139 case iUnion of
140 OpenUnion union -> Just union
141 ClosedUnion (Can.Union vars _ _ opts) -> Just (Can.Union vars [] 0 opts)
142 PrivateUnion _ -> Nothing
145toPublicAlias :: Alias -> Maybe Can.Alias
146toPublicAlias iAlias =
147 case iAlias of
148 PublicAlias alias -> Just alias
149 PrivateAlias _ -> Nothing
153-- DEPENDENCY INTERFACE
156data DependencyInterface
157 = Public Interface
158 | Private
159 Pkg.Name
160 (Map.Map Name.Name Can.Union)
161 (Map.Map Name.Name Can.Alias)
164public :: Interface -> DependencyInterface
165public =
166 Public
169private :: Interface -> DependencyInterface
170private (Interface pkg _ unions aliases _) =
171 Private pkg (Map.map extractUnion unions) (Map.map extractAlias aliases)
174extractUnion :: Union -> Can.Union
175extractUnion iUnion =
176 case iUnion of
177 OpenUnion union -> union
178 ClosedUnion union -> union
179 PrivateUnion union -> union
182extractAlias :: Alias -> Can.Alias
183extractAlias iAlias =
184 case iAlias of
185 PublicAlias alias -> alias
186 PrivateAlias alias -> alias
189privatize :: DependencyInterface -> DependencyInterface
190privatize di =
191 case di of
192 Public i -> private i
193 Private _ _ _ -> di
197-- BINARY
200instance Binary Interface where
201 get = liftM5 Interface get get get get get
202 put (Interface a b c d e) = put a >> put b >> put c >> put d >> put e
205instance Binary Union where
206 put union =
207 case union of
208 OpenUnion u -> putWord8 0 >> put u
209 ClosedUnion u -> putWord8 1 >> put u
210 PrivateUnion u -> putWord8 2 >> put u
212 get =
213 do n <- getWord8
214 case n of
215 0 -> liftM OpenUnion get
216 1 -> liftM ClosedUnion get
217 2 -> liftM PrivateUnion get
218 _ -> error "binary encoding of Union was corrupted"
221instance Binary Alias where
222 put union =
223 case union of
224 PublicAlias a -> putWord8 0 >> put a
225 PrivateAlias a -> putWord8 1 >> put a
227 get =
228 do n <- getWord8
229 case n of
230 0 -> liftM PublicAlias get
231 1 -> liftM PrivateAlias get
232 _ -> error "binary encoding of Alias was corrupted"
235instance Binary Binop where
236 get =
237 liftM4 Binop get get get get
239 put (Binop a b c d) =
240 put a >> put b >> put c >> put d
243instance Binary DependencyInterface where
244 put union =
245 case union of
246 Public a -> putWord8 0 >> put a
247 Private a b c -> putWord8 1 >> put a >> put b >> put c
249 get =
250 do n <- getWord8
251 case n of
252 0 -> liftM Public get
253 1 -> liftM3 Private get get get
254 _ -> error "binary encoding of DependencyInterface was corrupted"