git.iko.soy/elk
on 42f3721 help sign in
elk/compiler/src/Elm/Interface.hs
226 lines 4.9 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Elm.Interface
3 ( Interfaces
4 , Interface(..)
5 , Union
6 , Alias
7 , Binop(..)
8 , fromModule
9 , toPublicUnion
10 , toPublicAlias
11 , toUnionInternals
12 , toAliasInternals
13 )
14 where
17import Control.Monad (liftM4)
18import Data.Binary
19import Data.Map ((!))
20import qualified Data.Map as Map
21import qualified Data.Map.Merge.Strict as Map
23import qualified AST.Canonical as Can
24import qualified AST.Module.Name as ModuleName
25import qualified AST.Utils.Binop as Binop
26import qualified Elm.Name as N
27import qualified Reporting.Annotation as A
31-- INTERFACES
34type Interfaces =
35 Map.Map ModuleName.Canonical Interface
39-- INTERFACE
42data Interface =
43 Interface
44 { _types :: Map.Map N.Name Can.Annotation
45 , _unions :: Map.Map N.Name Union
46 , _aliases :: Map.Map N.Name Alias
47 , _binops :: Map.Map N.Name Binop
48 }
51data Union
52 = OpenUnion Can.Union
53 | ClosedUnion Can.Union
54 | PrivateUnion Can.Union
57data Alias
58 = PublicAlias Can.Alias
59 | PrivateAlias Can.Alias
62data Binop =
63 Binop
64 { _op_name :: N.Name
65 , _op_annotation :: Can.Annotation
66 , _op_associativity :: Binop.Associativity
67 , _op_precedence :: Binop.Precedence
68 }
72-- FROM MODULE
75fromModule :: Map.Map N.Name Can.Annotation -> Can.Module -> Interface
76fromModule types (Can.Module _ _ exports _ unions aliases binops _) =
77 Interface
78 { _types = privatize exports types
79 , _unions = privatizeUnions exports unions
80 , _aliases = privatizeAliases exports aliases
81 , _binops = privatize exports (Map.map (toOp types) binops)
82 }
85privatize :: Can.Exports -> Map.Map N.Name a -> Map.Map N.Name a
86privatize exports dict =
87 case exports of
88 Can.ExportEverything _ ->
89 dict
91 Can.Export explicitExports ->
92 Map.intersection dict explicitExports
95toOp :: Map.Map N.Name Can.Annotation -> Can.Binop -> Binop
96toOp types (Can.Binop_ associativity precedence name) =
97 Binop name (types ! name) associativity precedence
100privatizeUnions :: Can.Exports -> Map.Map N.Name Can.Union -> Map.Map N.Name Union
101privatizeUnions exports unions =
102 case exports of
103 Can.ExportEverything _ ->
104 Map.map OpenUnion unions
106 Can.Export explicitExports ->
107 Map.merge onLeft onRight onBoth explicitExports unions
108 where
109 onLeft = Map.dropMissing
110 onRight = Map.mapMissing (\_ u -> PrivateUnion u)
111 onBoth = Map.zipWithMatched $ \_ e u ->
112 case A.toValue e of
113 Can.ExportUnionOpen -> OpenUnion u
114 Can.ExportUnionClosed -> ClosedUnion u
115 _ -> error "impossible exports discovered in privatizeUnions"
118privatizeAliases :: Can.Exports -> Map.Map N.Name Can.Alias -> Map.Map N.Name Alias
119privatizeAliases exports aliases =
120 case exports of
121 Can.ExportEverything _ ->
122 Map.map PublicAlias aliases
124 Can.Export explicitExports ->
125 Map.merge onLeft onRight onBoth explicitExports aliases
126 where
127 onLeft = Map.dropMissing
128 onRight = Map.mapMissing (\_ a -> PrivateAlias a)
129 onBoth = Map.zipWithMatched (\_ _ a -> PublicAlias a)
133-- PUBLICIZE
136toPublicUnion :: Union -> Maybe Can.Union
137toPublicUnion iUnion =
138 case iUnion of
139 OpenUnion union ->
140 Just union
142 ClosedUnion (Can.Union vars _ _ opts) ->
143 Just (Can.Union vars [] 0 opts)
145 PrivateUnion _ ->
146 Nothing
149toPublicAlias :: Alias -> Maybe Can.Alias
150toPublicAlias iAlias =
151 case iAlias of
152 PublicAlias alias ->
153 Just alias
155 PrivateAlias _ ->
156 Nothing
160-- INTERNALS
163toUnionInternals :: Union -> Can.Union
164toUnionInternals iUnion =
165 case iUnion of
166 OpenUnion union -> union
167 ClosedUnion union -> union
168 PrivateUnion union -> union
171toAliasInternals :: Alias -> Can.Alias
172toAliasInternals iAlias =
173 case iAlias of
174 PublicAlias alias -> alias
175 PrivateAlias alias -> alias
179-- BINARY
182instance Binary Interface where
183 get =
184 liftM4 Interface get get get get
186 put (Interface a b c d) =
187 put a >> put b >> put c >> put d
190instance Binary Union where
191 put union =
192 case union of
193 OpenUnion u -> putWord8 0 >> put u
194 ClosedUnion u -> putWord8 1 >> put u
195 PrivateUnion u -> putWord8 2 >> put u
197 get =
198 do n <- getWord8
199 case n of
200 0 -> OpenUnion <$> get
201 1 -> ClosedUnion <$> get
202 2 -> PrivateUnion <$> get
203 _ -> error "binary encoding of Union was corrupted"
206instance Binary Alias where
207 put union =
208 case union of
209 PublicAlias a -> putWord8 0 >> put a
210 PrivateAlias a -> putWord8 1 >> put a
212 get =
213 do n <- getWord8
214 case n of
215 0 -> PublicAlias <$> get
216 1 -> PrivateAlias <$> get
217 _ -> error "binary encoding of Alias was corrupted"
220instance Binary Binop where
221 get =
222 liftM4 Binop get get get get
224 put (Binop a b c d) =
225 put a >> put b >> put c >> put d