1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module AST.Canonical
4  ( Expr, Expr_(..)
5  , CaseBranch(..)
6  , FieldUpdate(..)
7  , CtorOpts(..)
8  -- definitions
9  , Def(..)
10  , Decls(..)
11  -- patterns
12  , Pattern, Pattern_(..)
13  , PatternCtorArg(..)
14  -- types
15  , Annotation(..)
16  , Type(..)
17  , AliasType(..)
18  , FieldType(..)
19  , fieldsToList
20  -- modules
21  , Module(..)
22  , Alias(..)
23  , Binop(..)
24  , Union(..)
25  , Ctor(..)
26  , Exports(..)
27  , Export(..)
28  , Effects(..)
29  , Port(..)
30  , Manager(..)
31  )
32  where
33
34{- Creating a canonical AST means finding the home module for all variables.
35So if you have L.map, you need to figure out that it is from the elm/core
36package in the List module.
37
38In later phases (e.g. type inference, exhaustiveness checking, optimization)
39you need to look up additional info from these modules. What is the type?
40What are the alternative type constructors? These lookups can be quite costly,
41especially in type inference. To reduce costs the canonicalization phase
42caches info needed in later phases. This means we no longer build large
43dictionaries of metadata with O(log(n)) lookups in those phases. Instead
44there is an O(1) read of an existing field! I have tried to mark all
45cached data with comments like:
46
47-- CACHE for exhaustiveness
48-- CACHE for inference
49
50So it is clear why the data is kept around.
51-}
52
53
54import Control.Monad (liftM, liftM2, liftM3, liftM4, replicateM)
55import Data.Binary
56import qualified Data.List as List
57import qualified Data.Map as Map
58import Data.Name (Name)
59
60import qualified AST.Source as Src
61import qualified AST.Utils.Binop as Binop
62import qualified AST.Utils.Shader as Shader
63import qualified Data.Index as Index
64import qualified Elm.Float as EF
65import qualified Elm.ModuleName as ModuleName
66import qualified Elm.String as ES
67import qualified Reporting.Annotation as A
68
69
70
71-- EXPRESSIONS
72
73
74type Expr =
75  A.Located Expr_
76
77
78-- CACHE Annotations for type inference
79data Expr_
80  = VarLocal Name
81  | VarTopLevel ModuleName.Canonical Name
82  | VarKernel Name Name
83  | VarForeign ModuleName.Canonical Name Annotation
84  | VarCtor CtorOpts ModuleName.Canonical Name Index.ZeroBased Annotation
85  | VarDebug ModuleName.Canonical Name Annotation
86  | VarOperator Name ModuleName.Canonical Name Annotation -- CACHE real name for optimization
87  | Chr ES.String
88  | Str ES.String
89  | Int Int
90  | Float EF.Float
91  | List [Expr]
92  | Negate Expr
93  | Binop Name ModuleName.Canonical Name Annotation Expr Expr -- CACHE real name for optimization
94  | Lambda [Pattern] Expr
95  | Call Expr [Expr]
96  | If [(Expr, Expr)] Expr
97  | Let Def Expr
98  | LetRec [Def] Expr
99  | LetDestruct Pattern Expr Expr
100  | Case Expr [CaseBranch]
101  | Accessor Name
102  | Access Expr (A.Located Name)
103  | Update Name Expr (Map.Map Name FieldUpdate)
104  | Record (Map.Map Name Expr)
105  | Unit
106  | Tuple Expr Expr (Maybe Expr)
107  | Shader Shader.Source Shader.Types
108
109
110data CaseBranch =
111  CaseBranch Pattern Expr
112
113
114data FieldUpdate =
115  FieldUpdate A.Region Expr
116
117
118
119-- DEFS
120
121
122data Def
123  = Def (A.Located Name) [Pattern] Expr
124  | TypedDef (A.Located Name) FreeVars [(Pattern, Type)] Expr Type
125
126
127
128-- DECLARATIONS
129
130
131data Decls
132  = Declare Def Decls
133  | DeclareRec Def [Def] Decls
134  | SaveTheEnvironment
135
136
137
138-- PATTERNS
139
140
141type Pattern =
142  A.Located Pattern_
143
144
145data Pattern_
146  = PAnything
147  | PVar Name
148  | PRecord [Name]
149  | PAlias Pattern Name
150  | PUnit
151  | PTuple Pattern Pattern (Maybe Pattern)
152  | PList [Pattern]
153  | PCons Pattern Pattern
154  | PBool Union Bool
155  | PChr ES.String
156  | PStr ES.String
157  | PInt Int
158  | PCtor
159      { _p_home :: ModuleName.Canonical
160      , _p_type :: Name
161      , _p_union :: Union
162      , _p_name :: Name
163      , _p_index :: Index.ZeroBased
164      , _p_args :: [PatternCtorArg]
165      }
166      -- CACHE _p_home, _p_type, and _p_vars for type inference
167      -- CACHE _p_index to replace _p_name in PROD code gen
168      -- CACHE _p_opts to allocate less in PROD code gen
169      -- CACHE _p_alts and _p_numAlts for exhaustiveness checker
170
171
172data PatternCtorArg =
173  PatternCtorArg
174    { _index :: Index.ZeroBased -- CACHE for destructors/errors
175    , _type :: Type             -- CACHE for type inference
176    , _arg :: Pattern
177    }
178
179
180
181-- TYPES
182
183
184data Annotation = Forall FreeVars Type
185  deriving (Eq)
186
187
188type FreeVars = Map.Map Name ()
189
190
191data Type
192  = TLambda Type Type
193  | TVar Name
194  | TType ModuleName.Canonical Name [Type]
195  | TRecord (Map.Map Name FieldType) (Maybe Name)
196  | TUnit
197  | TTuple Type Type (Maybe Type)
198  | TAlias ModuleName.Canonical Name [(Name, Type)] AliasType
199  deriving (Eq)
200
201
202data AliasType
203  = Holey Type
204  | Filled Type
205  deriving (Eq)
206
207
208data FieldType = FieldType {-# UNPACK #-} !Word16 Type
209  deriving (Eq)
210
211
212-- NOTE: The Word16 marks the source order, but it may not be available
213-- for every canonical type. For example, if the canonical type is inferred
214-- the orders will all be zeros.
215--
216fieldsToList :: Map.Map Name FieldType -> [(Name, Type)]
217fieldsToList fields =
218  let
219    getIndex (_, FieldType index _) =
220      index
221
222    dropIndex (name, FieldType _ tipe) =
223      (name, tipe)
224  in
225  map dropIndex (List.sortOn getIndex (Map.toList fields))
226
227
228
229-- MODULES
230
231
232data Module =
233  Module
234    { _name    :: ModuleName.Canonical
235    , _exports :: Exports
236    , _docs    :: Src.Docs
237    , _decls   :: Decls
238    , _unions  :: Map.Map Name Union
239    , _aliases :: Map.Map Name Alias
240    , _binops  :: Map.Map Name Binop
241    , _effects :: Effects
242    }
243
244
245data Alias = Alias [Name] Type
246  deriving (Eq)
247
248
249data Binop = Binop_ Binop.Associativity Binop.Precedence Name
250  deriving (Eq)
251
252
253data Union =
254  Union
255    { _u_vars :: [Name]
256    , _u_alts :: [Ctor]
257    , _u_numAlts :: Int -- CACHE numAlts for exhaustiveness checking
258    , _u_opts :: CtorOpts -- CACHE which optimizations are available
259    }
260  deriving (Eq)
261
262
263data CtorOpts
264  = Normal
265  | Enum
266  | Unbox
267  deriving (Eq, Ord)
268
269
270data Ctor = Ctor Name Index.ZeroBased Int [Type] -- CACHE length args
271  deriving (Eq)
272
273
274
275-- EXPORTS
276
277
278data Exports
279  = ExportEverything A.Region
280  | Export (Map.Map Name (A.Located Export))
281
282
283data Export
284  = ExportValue
285  | ExportBinop
286  | ExportAlias
287  | ExportUnionOpen
288  | ExportUnionClosed
289  | ExportPort
290
291
292
293-- EFFECTS
294
295
296data Effects
297  = NoEffects
298  | Ports (Map.Map Name Port)
299  | Manager A.Region A.Region A.Region Manager
300
301
302data Port
303  = Incoming { _freeVars :: FreeVars, _payload :: Type, _func :: Type }
304  | Outgoing { _freeVars :: FreeVars, _payload :: Type, _func :: Type }
305
306
307data Manager
308  = Cmd Name
309  | Sub Name
310  | Fx Name Name
311
312
313
314-- BINARY
315
316
317instance Binary Alias where
318  get = liftM2 Alias get get
319  put (Alias a b) = put a >> put b
320
321
322instance Binary Union where
323  put (Union a b c d) = put a >> put b >> put c >> put d
324  get = liftM4 Union get get get get
325
326
327instance Binary Ctor where
328  get = liftM4 Ctor get get get get
329  put (Ctor a b c d) = put a >> put b >> put c >> put d
330
331
332instance Binary CtorOpts where
333  put opts =
334    case opts of
335      Normal -> putWord8 0
336      Enum   -> putWord8 1
337      Unbox  -> putWord8 2
338
339  get =
340    do  n <- getWord8
341        case n of
342          0 -> return Normal
343          1 -> return Enum
344          2 -> return Unbox
345          _ -> fail "binary encoding of CtorOpts was corrupted"
346
347
348instance Binary Annotation where
349  get = liftM2 Forall get get
350  put (Forall a b) = put a >> put b
351
352
353instance Binary Type where
354  put tipe =
355    case tipe of
356      TLambda a b        -> putWord8 0 >> put a >> put b
357      TVar a             -> putWord8 1 >> put a
358      TRecord a b        -> putWord8 2 >> put a >> put b
359      TUnit              -> putWord8 3
360      TTuple a b c       -> putWord8 4 >> put a >> put b >> put c
361      TAlias a b c d     -> putWord8 5 >> put a >> put b >> put c >> put d
362      TType home name ts ->
363        let potentialWord = length ts + 7 in
364        if potentialWord <= fromIntegral (maxBound :: Word8) then
365          do  putWord8 (fromIntegral potentialWord)
366              put home
367              put name
368              mapM_ put ts
369        else
370          putWord8 6 >> put home >> put name >> put ts
371
372  get =
373    do  word <- getWord8
374        case word of
375          0 -> liftM2 TLambda get get
376          1 -> liftM  TVar get
377          2 -> liftM2 TRecord get get
378          3 -> return TUnit
379          4 -> liftM3 TTuple get get get
380          5 -> liftM4 TAlias get get get get
381          6 -> liftM3 TType get get get
382          n -> liftM3 TType get get (replicateM (fromIntegral (n - 7)) get)
383
384
385instance Binary AliasType where
386  put aliasType =
387    case aliasType of
388      Holey tipe  -> putWord8 0 >> put tipe
389      Filled tipe -> putWord8 1 >> put tipe
390
391  get =
392    do  n <- getWord8
393        case n of
394          0 -> liftM Holey get
395          1 -> liftM Filled get
396          _ -> fail "binary encoding of AliasType was corrupted"
397
398
399instance Binary FieldType where
400  get = liftM2 FieldType get get
401  put (FieldType a b) = put a >> put b
402