git.iko.soy/elk
on 2ea433c help sign in
elk/compiler/src/Optimize/Names.hs
179 lines 4.2 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE Rank2Types #-}
4module Optimize.Names
5 ( Tracker
6 , run
7 , generate
8 , registerKernel
9 , registerGlobal
10 , registerDebug
11 , registerCtor
12 , registerField
13 , registerFieldDict
14 , registerFieldList
15 )
16 where
19import qualified Data.Map as Map
20import qualified Data.Set as Set
22import qualified AST.Canonical as Can
23import qualified AST.Optimized as Opt
24import qualified AST.Module.Name as ModuleName
25import qualified Data.Index as Index
26import qualified Elm.Name as N
27import qualified Elm.Package as Pkg
28import qualified Reporting.Region as R
32-- GENERATOR
35newtype Tracker a =
36 Tracker (
37 forall r.
38 Int
39 -> Set.Set Opt.Global
40 -> Map.Map N.Name Int
41 -> (Int -> Set.Set Opt.Global -> Map.Map N.Name Int -> a -> r)
42 -> r
43 )
46run :: Tracker a -> (Set.Set Opt.Global, Map.Map N.Name Int, a)
47run (Tracker k) =
48 k 0 Set.empty Map.empty
49 (\_uid deps fields value -> (deps, fields, value))
52generate :: Tracker N.Name
53generate =
54 Tracker $ \uid deps fields ok ->
55 ok (uid + 1) deps fields (N.addIndex "_n" uid)
58registerKernel :: N.Name -> a -> Tracker a
59registerKernel home value =
60 Tracker $ \uid deps fields ok ->
61 ok uid (Set.insert (toKernelGlobal home) deps) fields value
64toKernelGlobal :: N.Name -> Opt.Global
65toKernelGlobal home =
66 Opt.Global (ModuleName.Canonical Pkg.kernel home) N.dollar
69registerGlobal :: ModuleName.Canonical -> N.Name -> Tracker Opt.Expr
70registerGlobal home name =
71 Tracker $ \uid deps fields ok ->
72 let global = Opt.Global home name in
73 ok uid (Set.insert global deps) fields (Opt.VarGlobal global)
76registerDebug :: N.Name -> ModuleName.Canonical -> R.Region -> Tracker Opt.Expr
77registerDebug name home region =
78 Tracker $ \uid deps fields ok ->
79 let global = Opt.Global ModuleName.debug name in
80 ok uid (Set.insert global deps) fields (Opt.VarDebug name home region Nothing)
83registerCtor :: ModuleName.Canonical -> N.Name -> Index.ZeroBased -> Can.CtorOpts -> Tracker Opt.Expr
84registerCtor home name index opts =
85 Tracker $ \uid deps fields ok ->
86 let
87 global = Opt.Global home name
88 newDeps = Set.insert global deps
89 in
90 case opts of
91 Can.Normal ->
92 ok uid newDeps fields (Opt.VarGlobal global)
94 Can.Enum ->
95 ok uid newDeps fields $
96 case name of
97 "True" | home == ModuleName.basics -> Opt.Bool True
98 "False" | home == ModuleName.basics -> Opt.Bool False
99 _ -> Opt.VarEnum global index
101 Can.Unbox ->
102 ok uid (Set.insert identity newDeps) fields (Opt.VarBox global)
105identity :: Opt.Global
106identity =
107 Opt.Global ModuleName.basics N.identity
110registerField :: N.Name -> a -> Tracker a
111registerField name value =
112 Tracker $ \uid d fields ok ->
113 ok uid d (Map.insertWith (+) name 1 fields) value
116registerFieldDict :: Map.Map N.Name v -> a -> Tracker a
117registerFieldDict newFields value =
118 Tracker $ \uid d fields ok ->
119 ok uid d (Map.unionWith (+) fields (Map.map toOne newFields)) value
122toOne :: a -> Int
123toOne _ = 1
126registerFieldList :: [N.Name] -> a -> Tracker a
127registerFieldList names value =
128 Tracker $ \uid deps fields ok ->
129 ok uid deps (foldr addOne fields names) value
132addOne :: N.Name -> Map.Map N.Name Int -> Map.Map N.Name Int
133addOne name fields =
134 Map.insertWith (+) name 1 fields
138-- INSTANCES
141instance Functor Tracker where
142 fmap func (Tracker kv) =
143 Tracker $ \n d f ok ->
144 let
145 ok1 n1 d1 f1 value =
146 ok n1 d1 f1 (func value)
147 in
148 kv n d f ok1
151instance Applicative Tracker where
152 {-# INLINE pure #-}
153 pure value =
154 Tracker $ \n d f ok -> ok n d f value
156 (<*>) (Tracker kf) (Tracker kv) =
157 Tracker $ \n d f ok ->
158 let
159 ok1 n1 d1 f1 func =
160 let
161 ok2 n2 d2 f2 value =
162 ok n2 d2 f2 (func value)
163 in
164 kv n1 d1 f1 ok2
165 in
166 kf n d f ok1
169instance Monad Tracker where
170 return = pure
172 (>>=) (Tracker k) callback =
173 Tracker $ \n d f ok ->
174 let
175 ok1 n1 d1 f1 a =
176 case callback a of
177 Tracker kb -> kb n1 d1 f1 ok
178 in
179 k n d f ok1