git.iko.soy/elk
on 1238607 help sign in
elk/compiler/src/Optimize/Names.hs
173 lines 4.1 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.Name as Name
21import qualified Data.Set as Set
23import qualified AST.Canonical as Can
24import qualified AST.Optimized as Opt
25import qualified Data.Index as Index
26import qualified Elm.ModuleName as ModuleName
27import qualified Reporting.Annotation as A
31-- GENERATOR
34newtype Tracker a =
35 Tracker (
36 forall r.
37 Int
38 -> Set.Set Opt.Global
39 -> Map.Map Name.Name Int
40 -> (Int -> Set.Set Opt.Global -> Map.Map Name.Name Int -> a -> r)
41 -> r
42 )
45run :: Tracker a -> (Set.Set Opt.Global, Map.Map Name.Name Int, a)
46run (Tracker k) =
47 k 0 Set.empty Map.empty
48 (\_uid deps fields value -> (deps, fields, value))
51generate :: Tracker Name.Name
52generate =
53 Tracker $ \uid deps fields ok ->
54 ok (uid + 1) deps fields (Name.fromVarIndex uid)
57registerKernel :: Name.Name -> a -> Tracker a
58registerKernel home value =
59 Tracker $ \uid deps fields ok ->
60 ok uid (Set.insert (Opt.toKernelGlobal home) deps) fields value
63registerGlobal :: ModuleName.Canonical -> Name.Name -> Tracker Opt.Expr
64registerGlobal home name =
65 Tracker $ \uid deps fields ok ->
66 let global = Opt.Global home name in
67 ok uid (Set.insert global deps) fields (Opt.VarGlobal global)
70registerDebug :: Name.Name -> ModuleName.Canonical -> A.Region -> Tracker Opt.Expr
71registerDebug name home region =
72 Tracker $ \uid deps fields ok ->
73 let global = Opt.Global ModuleName.debug name in
74 ok uid (Set.insert global deps) fields (Opt.VarDebug name home region Nothing)
77registerCtor :: ModuleName.Canonical -> Name.Name -> Index.ZeroBased -> Can.CtorOpts -> Tracker Opt.Expr
78registerCtor home name index opts =
79 Tracker $ \uid deps fields ok ->
80 let
81 global = Opt.Global home name
82 newDeps = Set.insert global deps
83 in
84 case opts of
85 Can.Normal ->
86 ok uid newDeps fields (Opt.VarGlobal global)
88 Can.Enum ->
89 ok uid newDeps fields $
90 case name of
91 "True" | home == ModuleName.basics -> Opt.Bool True
92 "False" | home == ModuleName.basics -> Opt.Bool False
93 _ -> Opt.VarEnum global index
95 Can.Unbox ->
96 ok uid (Set.insert identity newDeps) fields (Opt.VarBox global)
99identity :: Opt.Global
100identity =
101 Opt.Global ModuleName.basics Name.identity
104registerField :: Name.Name -> a -> Tracker a
105registerField name value =
106 Tracker $ \uid d fields ok ->
107 ok uid d (Map.insertWith (+) name 1 fields) value
110registerFieldDict :: Map.Map Name.Name v -> a -> Tracker a
111registerFieldDict newFields value =
112 Tracker $ \uid d fields ok ->
113 ok uid d (Map.unionWith (+) fields (Map.map toOne newFields)) value
116toOne :: a -> Int
117toOne _ = 1
120registerFieldList :: [Name.Name] -> a -> Tracker a
121registerFieldList names value =
122 Tracker $ \uid deps fields ok ->
123 ok uid deps (foldr addOne fields names) value
126addOne :: Name.Name -> Map.Map Name.Name Int -> Map.Map Name.Name Int
127addOne name fields =
128 Map.insertWith (+) name 1 fields
132-- INSTANCES
135instance Functor Tracker where
136 fmap func (Tracker kv) =
137 Tracker $ \n d f ok ->
138 let
139 ok1 n1 d1 f1 value =
140 ok n1 d1 f1 (func value)
141 in
142 kv n d f ok1
145instance Applicative Tracker where
146 {-# INLINE pure #-}
147 pure value =
148 Tracker $ \n d f ok -> ok n d f value
150 (<*>) (Tracker kf) (Tracker kv) =
151 Tracker $ \n d f ok ->
152 let
153 ok1 n1 d1 f1 func =
154 let
155 ok2 n2 d2 f2 value =
156 ok n2 d2 f2 (func value)
157 in
158 kv n1 d1 f1 ok2
159 in
160 kf n d f ok1
163instance Monad Tracker where
164 return = pure
166 (>>=) (Tracker k) callback =
167 Tracker $ \n d f ok ->
168 let
169 ok1 n1 d1 f1 a =
170 case callback a of
171 Tracker kb -> kb n1 d1 f1 ok
172 in
173 k n d f ok1