git.iko.soy/elk
on 0efde80 help sign in
elk/src/Optimize/Names.hs
172 lines 3.9 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 $
89 case name of
90 "True" | home == ModuleName.basics -> Opt.Bool True
91 "False" | home == ModuleName.basics -> Opt.Bool False
92 _ -> Opt.VarEnum global index
94 Can.Unbox ->
95 ok uid (Set.insert identity newDeps) fields (Opt.VarBox global)
98identity :: Opt.Global
99identity =
100 Opt.Global ModuleName.basics N.identity
103registerField :: N.Name -> a -> Tracker a
104registerField name value =
105 Tracker $ \uid d fields ok ->
106 ok uid d (Map.insertWith (+) name 1 fields) value
109registerFieldDict :: Map.Map N.Name v -> a -> Tracker a
110registerFieldDict newFields value =
111 Tracker $ \uid d fields ok ->
112 ok uid d (Map.unionWith (+) fields (Map.map toOne newFields)) value
115toOne :: a -> Int
116toOne _ = 1
119registerFieldList :: [N.Name] -> a -> Tracker a
120registerFieldList names value =
121 Tracker $ \uid deps fields ok ->
122 ok uid deps (foldr addOne fields names) value
125addOne :: N.Name -> Map.Map N.Name Int -> Map.Map N.Name Int
126addOne name fields =
127 Map.insertWith (+) name 1 fields
131-- INSTANCES
134instance Functor Tracker where
135 fmap func (Tracker kv) =
136 Tracker $ \n d f ok ->
137 let
138 ok1 n1 d1 f1 value =
139 ok n1 d1 f1 (func value)
140 in
141 kv n d f ok1
144instance Applicative Tracker where
145 {-# INLINE pure #-}
146 pure value =
147 Tracker $ \n d f ok -> ok n d f value
149 (<*>) (Tracker kf) (Tracker kv) =
150 Tracker $ \n d f ok ->
151 let
152 ok1 n1 d1 f1 func =
153 let
154 ok2 n2 d2 f2 value =
155 ok n2 d2 f2 (func value)
156 in
157 kv n1 d1 f1 ok2
158 in
159 kf n d f ok1
162instance Monad Tracker where
163 return = pure
165 (>>=) (Tracker k) callback =
166 Tracker $ \n d f ok ->
167 let
168 ok1 n1 d1 f1 a =
169 case callback a of
170 Tracker kb -> kb n1 d1 f1 ok
171 in
172 k n d f ok1