git.iko.soy/elk
on 0bdfd73 help sign in
elk/src/Elm/Interface.hs
113 lines 2.4 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Elm.Interface
3 ( Interfaces
4 , Interface(..)
5 , Binop(..)
6 , fromModule
7 )
8 where
11import Control.Monad (liftM4)
12import Data.Binary
13import Data.Map ((!))
14import qualified Data.Map as Map
16import qualified AST.Canonical as Can
17import qualified AST.Module.Name as ModuleName
18import qualified AST.Utils.Binop as Binop
19import qualified Elm.Name as N
20import qualified Reporting.Annotation as A
24-- INTERFACES
27type Interfaces =
28 Map.Map ModuleName.Canonical Interface
32-- INTERFACE
35data Interface =
36 Interface
37 { _types :: Map.Map N.Name Can.Annotation
38 , _unions :: Map.Map N.Name Can.Union
39 , _aliases :: Map.Map N.Name Can.Alias
40 , _binops :: Map.Map N.Name Binop
41 }
44data Binop =
45 Binop
46 { _op_name :: N.Name
47 , _op_annotation :: Can.Annotation
48 , _op_associativity :: Binop.Associativity
49 , _op_precedence :: Binop.Precedence
50 }
54-- FROM MODULE
57fromModule :: Map.Map N.Name Can.Annotation -> Can.Module -> Interface
58fromModule types (Can.Module _ _ exports _ unions aliases binops _) =
59 Interface
60 { _types = privatize exports const types
61 , _unions = privatize exports toUnion unions
62 , _aliases = privatize exports const aliases
63 , _binops = privatize exports const (Map.map (toOp types) binops)
64 }
67privatize :: Can.Exports -> (a -> A.Located Can.Export -> a) -> Map.Map N.Name a -> Map.Map N.Name a
68privatize exports func dict =
69 case exports of
70 Can.ExportEverything _ ->
71 dict
73 Can.Export explicitExports ->
74 Map.intersectionWith func dict explicitExports
77toUnion :: Can.Union -> A.Located Can.Export -> Can.Union
78toUnion union@(Can.Union vars _ _ opts) (A.At _ export) =
79 case export of
80 Can.ExportUnionOpen ->
81 union
83 Can.ExportUnionClosed ->
84 Can.Union vars [] 0 opts
86 _ ->
87 error "Compiler bug. Should not run into non-union exports here."
90toOp :: Map.Map N.Name Can.Annotation -> Can.Binop -> Binop
91toOp types (Can.Binop_ associativity precedence name) =
92 Binop name (types ! name) associativity precedence
96-- BINARY
99instance Binary Interface where
100 get =
101 liftM4 Interface get get get get
103 put (Interface a b c d) =
104 put a >> put b >> put c >> put d
107instance Binary Binop where
108 get =
109 liftM4 Binop get get get get
111 put (Binop a b c d) =
112 put a >> put b >> put c >> put d