git.iko.soy/elk
on 14fc72d help sign in
elk/src/Optimize/Names.hs
170 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 qualified Data.Map as Map
19import qualified Data.Set as Set
21import qualified AST.Canonical as Can
22import qualified AST.Optimized as Opt
23import qualified AST.Module.Name as ModuleName
24import qualified Data.Index as Index
25import qualified Elm.Name as N
26import qualified Elm.Package as Pkg
30-- GENERATOR
33newtype Tracker a =
34 Tracker (
35 forall r.
36 Int
37 -> Set.Set Opt.Global
38 -> Map.Map N.Name Int
39 -> (Int -> Set.Set Opt.Global -> Map.Map N.Name Int -> a -> r)
40 -> r
41 )
44run :: Tracker a -> (Set.Set Opt.Global, Map.Map N.Name Int, a)
45run (Tracker k) =
46 k 0 Set.empty Map.empty
47 (\_uid deps fields value -> (deps, fields, value))
50generate :: Tracker N.Name
51generate =
52 Tracker $ \uid deps fields ok ->
53 ok (uid + 1) deps fields (N.addIndex "_n" uid)
56registerKernel :: N.Name -> a -> Tracker a
57registerKernel home value =
58 Tracker $ \uid deps fields ok ->
59 ok uid (Set.insert (toKernelGlobal home) deps) fields value
62toKernelGlobal :: N.Name -> Opt.Global
63toKernelGlobal home =
64 Opt.Global (ModuleName.Canonical Pkg.kernel home) N.dollar
67registerGlobal :: ModuleName.Canonical -> N.Name -> Tracker Opt.Expr
68registerGlobal home name =
69 Tracker $ \uid deps fields ok ->
70 let global = Opt.Global home name in
71 ok uid (Set.insert global deps) fields (Opt.VarGlobal global)
74registerCtor :: ModuleName.Canonical -> N.Name -> Index.ZeroBased -> Can.CtorOpts -> Tracker Opt.Expr
75registerCtor home name index opts =
76 Tracker $ \uid deps fields ok ->
77 let
78 global = Opt.Global home name
79 newDeps = Set.insert global deps
80 in
81 case opts of
82 Can.Normal ->
83 ok uid newDeps fields (Opt.VarGlobal global)
85 Can.Enum ->
86 ok uid newDeps fields $
87 case name of
88 "True" | home == ModuleName.basics -> Opt.Bool True
89 "False" | home == ModuleName.basics -> Opt.Bool False
90 _ -> Opt.VarEnum global index
92 Can.Unbox ->
93 ok uid (Set.insert identity newDeps) fields (Opt.VarBox global)
96identity :: Opt.Global
97identity =
98 Opt.Global ModuleName.basics N.identity
101registerField :: N.Name -> a -> Tracker a
102registerField name value =
103 Tracker $ \uid d fields ok ->
104 ok uid d (Map.insertWith (+) name 1 fields) value
107registerFieldDict :: Map.Map N.Name v -> a -> Tracker a
108registerFieldDict newFields value =
109 Tracker $ \uid d fields ok ->
110 ok uid d (Map.unionWith (+) fields (Map.map toOne newFields)) value
113toOne :: a -> Int
114toOne _ = 1
117registerFieldList :: [N.Name] -> a -> Tracker a
118registerFieldList names value =
119 Tracker $ \uid deps fields ok ->
120 ok uid deps (foldr addOne fields names) value
123addOne :: N.Name -> Map.Map N.Name Int -> Map.Map N.Name Int
124addOne name fields =
125 Map.insertWith (+) name 1 fields
129-- INSTANCES
132instance Functor Tracker where
133 fmap func (Tracker kv) =
134 Tracker $ \n d f ok ->
135 let
136 ok1 n1 d1 f1 value =
137 ok n1 d1 f1 (func value)
138 in
139 kv n d f ok1
142instance Applicative Tracker where
143 {-# INLINE pure #-}
144 pure value =
145 Tracker $ \n d f ok -> ok n d f value
147 (<*>) (Tracker kf) (Tracker kv) =
148 Tracker $ \n d f ok ->
149 let
150 ok1 n1 d1 f1 func =
151 let
152 ok2 n2 d2 f2 value =
153 ok n2 d2 f2 (func value)
154 in
155 kv n1 d1 f1 ok2
156 in
157 kf n d f ok1
160instance Monad Tracker where
161 return = pure
163 (>>=) (Tracker k) callback =
164 Tracker $ \n d f ok ->
165 let
166 ok1 n1 d1 f1 a =
167 case callback a of
168 Tracker kb -> kb n1 d1 f1 ok
169 in
170 k n d f ok1