git.iko.soy/elk
on 19ff114 help sign in
elk/src/Optimize/Names.hs
168 lines 3.8 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 , registerCtor
11 , registerField
12 , registerFieldDict
13 , registerFieldList
14 )
15 where
18import Data.Monoid ((<>))
19import qualified Data.Map as Map
20import qualified Data.Set as Set
21import qualified Data.Text as Text
23import qualified AST.Canonical as Can
24import qualified AST.Optimized as Opt
25import qualified AST.Module.Name as ModuleName
26import qualified Data.Index as Index
27import qualified Elm.Name as N
28import qualified Elm.Package as Pkg
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" <> Text.pack (show 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)
76registerCtor :: ModuleName.Canonical -> N.Name -> Index.ZeroBased -> Can.CtorOpts -> Tracker Opt.Expr
77registerCtor home name index opts =
78 Tracker $ \uid deps fields ok ->
79 let
80 global = Opt.Global home name
81 newDeps = Set.insert global deps
82 in
83 case opts of
84 Can.Normal ->
85 ok uid newDeps fields (Opt.VarGlobal global)
87 Can.Enum ->
88 ok uid newDeps fields (Opt.VarEnum global index)
90 Can.Unbox ->
91 ok uid (Set.insert identity newDeps) fields (Opt.VarBox global)
94identity :: Opt.Global
95identity =
96 Opt.Global ModuleName.basics N.identity
99registerField :: N.Name -> a -> Tracker a
100registerField name value =
101 Tracker $ \uid d fields ok ->
102 ok uid d (Map.insertWith (+) name 1 fields) value
105registerFieldDict :: Map.Map N.Name v -> a -> Tracker a
106registerFieldDict newFields value =
107 Tracker $ \uid d fields ok ->
108 ok uid d (Map.unionWith (+) fields (Map.map toOne newFields)) value
111toOne :: a -> Int
112toOne _ = 1
115registerFieldList :: [N.Name] -> a -> Tracker a
116registerFieldList names value =
117 Tracker $ \uid deps fields ok ->
118 ok uid deps (foldr addOne fields names) value
121addOne :: N.Name -> Map.Map N.Name Int -> Map.Map N.Name Int
122addOne name fields =
123 Map.insertWith (+) name 1 fields
127-- INSTANCES
130instance Functor Tracker where
131 fmap func (Tracker kv) =
132 Tracker $ \n d f ok ->
133 let
134 ok1 n1 d1 f1 value =
135 ok n1 d1 f1 (func value)
136 in
137 kv n d f ok1
140instance Applicative Tracker where
141 {-# INLINE pure #-}
142 pure value =
143 Tracker $ \n d f ok -> ok n d f value
145 (<*>) (Tracker kf) (Tracker kv) =
146 Tracker $ \n d f ok ->
147 let
148 ok1 n1 d1 f1 func =
149 let
150 ok2 n2 d2 f2 value =
151 ok n2 d2 f2 (func value)
152 in
153 kv n1 d1 f1 ok2
154 in
155 kf n d f ok1
158instance Monad Tracker where
159 return = pure
161 (>>=) (Tracker k) callback =
162 Tracker $ \n d f ok ->
163 let
164 ok1 n1 d1 f1 a =
165 case callback a of
166 Tracker kb -> kb n1 d1 f1 ok
167 in
168 k n d f ok1