git.iko.soy/elk
on 8eeedda 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
22import qualified Data.Name as Name
24import qualified AST.Canonical as Can
25import qualified AST.Utils.Binop as Binop
26import qualified Elm.ModuleName as ModuleName
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 Name.Name Can.Annotation
45 , _unions :: Map.Map Name.Name Union
46 , _aliases :: Map.Map Name.Name Alias
47 , _binops :: Map.Map Name.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 :: Name.Name
65 , _op_annotation :: Can.Annotation
66 , _op_associativity :: Binop.Associativity
67 , _op_precedence :: Binop.Precedence
68 }
72-- FROM MODULE
75fromModule :: Map.Map Name.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 Name.Name a -> Map.Map Name.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 Name.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 Name.Name Can.Union -> Map.Map Name.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 Name.Name Can.Alias -> Map.Map Name.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