git.iko.soy/elk
on 247359c help sign in
elk/src/Optimize/Names.hs
142 lines 3.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 , registerField
11 , registerFieldDict
12 , registerFieldList
13 )
14 where
17import Data.Monoid ((<>))
18import qualified Data.Map as Map
19import qualified Data.Set as Set
20import qualified Data.Text as Text
22import qualified AST.Optimized as Opt
23import qualified AST.Module.Name as ModuleName
24import qualified Elm.Name as N
25import qualified Elm.Package as Pkg
29-- GENERATOR
32newtype Tracker a =
33 Tracker (
34 forall r.
35 Int
36 -> Set.Set Opt.Global
37 -> Map.Map N.Name Int
38 -> (Int -> Set.Set Opt.Global -> Map.Map N.Name Int -> a -> r)
39 -> r
40 )
43run :: Tracker a -> (Set.Set Opt.Global, Map.Map N.Name Int, a)
44run (Tracker k) =
45 k 0 Set.empty Map.empty
46 (\_uid deps fields value -> (deps, fields, value))
49generate :: Tracker N.Name
50generate =
51 Tracker $ \uid deps fields ok ->
52 ok (uid + 1) deps fields ("_n" <> Text.pack (show uid))
55registerKernel :: N.Name -> a -> Tracker a
56registerKernel home value =
57 Tracker $ \uid deps fields ok ->
58 ok uid (Set.insert (toKernelGlobal home) deps) fields value
61toKernelGlobal :: N.Name -> Opt.Global
62toKernelGlobal home =
63 Opt.Global (ModuleName.Canonical Pkg.kernel home) N.dollar
66registerGlobal :: ModuleName.Canonical -> N.Name -> Tracker Opt.Expr
67registerGlobal home name =
68 Tracker $ \uid deps fields ok ->
69 let global = Opt.Global home name in
70 ok uid (Set.insert global deps) fields (Opt.VarGlobal global)
73registerField :: N.Name -> a -> Tracker a
74registerField name value =
75 Tracker $ \uid d fields ok ->
76 ok uid d (Map.insertWith (+) name 1 fields) value
79registerFieldDict :: Map.Map N.Name v -> a -> Tracker a
80registerFieldDict newFields value =
81 Tracker $ \uid d fields ok ->
82 ok uid d (Map.unionWith (+) fields (Map.map toOne newFields)) value
85toOne :: a -> Int
86toOne _ = 1
89registerFieldList :: [N.Name] -> a -> Tracker a
90registerFieldList names value =
91 Tracker $ \uid deps fields ok ->
92 ok uid deps (foldr addOne fields names) value
95addOne :: N.Name -> Map.Map N.Name Int -> Map.Map N.Name Int
96addOne name fields =
97 Map.insertWith (+) name 1 fields
101-- INSTANCES
104instance Functor Tracker where
105 fmap func (Tracker kv) =
106 Tracker $ \n d f ok ->
107 let
108 ok1 n1 d1 f1 value =
109 ok n1 d1 f1 (func value)
110 in
111 kv n d f ok1
114instance Applicative Tracker where
115 {-# INLINE pure #-}
116 pure value =
117 Tracker $ \n d f ok -> ok n d f value
119 (<*>) (Tracker kf) (Tracker kv) =
120 Tracker $ \n d f ok ->
121 let
122 ok1 n1 d1 f1 func =
123 let
124 ok2 n2 d2 f2 value =
125 ok n2 d2 f2 (func value)
126 in
127 kv n1 d1 f1 ok2
128 in
129 kf n d f ok1
132instance Monad Tracker where
133 return = pure
135 (>>=) (Tracker k) callback =
136 Tracker $ \n d f ok ->
137 let
138 ok1 n1 d1 f1 a =
139 case callback a of
140 Tracker kb -> kb n1 d1 f1 ok
141 in
142 k n d f ok1