git.iko.soy/elk
on ba0b721 help sign in
elk/src/Elm/Compiler/Type/Extract.hs
236 lines 5.4 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE Rank2Types #-}
4module Elm.Compiler.Type.Extract
5 ( fromAnnotation
6 , fromType
7 , fromMsg
8 )
9 where
12import Data.Map ((!))
13import qualified Data.Map as Map
14import qualified Data.Maybe as Maybe
15import Data.Monoid ((<>))
16import qualified Data.Set as Set
18import qualified AST.Canonical as Can
19import qualified AST.Optimized as Opt
20import qualified AST.Module.Name as ModuleName
21import qualified AST.Utils.Type as Type
22import qualified Elm.Compiler.Type as T
23import qualified Elm.Interface as I
24import qualified Elm.Name as N
28-- EXTRACTION
31fromAnnotation :: Can.Annotation -> T.Type
32fromAnnotation (Can.Forall _ astType) =
33 fromType astType
36fromType :: Can.Type -> T.Type
37fromType astType =
38 snd (run (extract astType))
41extract :: Can.Type -> Extractor T.Type
42extract astType =
43 case astType of
44 Can.TLambda arg result ->
45 T.Lambda
46 <$> extract arg
47 <*> extract result
49 Can.TVar x ->
50 pure (T.Var x)
52 Can.TType home name args ->
53 addUnion (Opt.Global home name) (T.Type (toPublicName home name))
54 <*> traverse extract args
56 Can.TRecord fields ext ->
57 T.Record
58 <$> fmap Map.toList (traverse extract fields)
59 <*> traverse extract ext
61 Can.TUnit ->
62 pure T.Unit
64 Can.TTuple a b maybeC ->
65 T.Tuple
66 <$> extract a
67 <*> extract b
68 <*> traverse extract (Maybe.maybeToList maybeC)
70 Can.TAlias home name args aliasType ->
71 do addAlias (Opt.Global home name) ()
72 _ <- extract (Type.dealias args aliasType)
73 T.Type (toPublicName home name)
74 <$> traverse (extract . snd) args
77toPublicName :: ModuleName.Canonical -> N.Name -> N.Name
78toPublicName (ModuleName.Canonical _ home) name =
79 home <> "." <> name
83-- EXTRACT MODEL, MSG, AND ANY TRANSITIVE DEPENDENCIES
86fromMsg :: I.Interfaces -> Can.Type -> T.DebugMetadata
87fromMsg interfaces message =
88 let
89 (msgDeps, msgType) =
90 run (extract message)
92 (aliases, unions) =
93 extractTransitive interfaces noDeps msgDeps
94 in
95 T.DebugMetadata msgType aliases unions
98extractTransitive :: I.Interfaces -> Deps -> Deps -> ( [T.Alias], [T.Union] )
99extractTransitive interfaces (Deps seenAliases seenUnions) (Deps nextAliases nextUnions) =
100 let
101 aliases = Set.difference nextAliases seenAliases
102 unions = Set.difference nextUnions seenUnions
103 in
104 if Set.null aliases && Set.null unions then
105 ( [], [] )
107 else
108 let
109 (newDeps, result) =
110 run $
111 (,)
112 <$> traverse (extractAlias interfaces) (Set.toList aliases)
113 <*> traverse (extractUnion interfaces) (Set.toList unions)
115 oldDeps =
116 Deps (Set.union seenAliases nextAliases) (Set.union seenUnions nextUnions)
118 remainingResult =
119 extractTransitive interfaces oldDeps newDeps
120 in
121 mappend result remainingResult
124extractAlias :: I.Interfaces -> Opt.Global -> Extractor T.Alias
125extractAlias interfaces (Opt.Global home name) =
126 let
127 (I.Interface _ _ aliases _) = interfaces ! home
128 (Can.Alias args aliasType _) = aliases ! name
129 in
130 T.Alias (toPublicName home name) args <$> extract aliasType
133extractUnion :: I.Interfaces -> Opt.Global -> Extractor T.Union
134extractUnion interfaces (Opt.Global home name) =
135 let
136 pname = toPublicName home name
137 unions = I._unions (interfaces ! home)
138 in
139 case unions ! name of
140 Can.Union vars ctors _ _ ->
141 T.Union pname vars <$> traverse extractCtor ctors
144extractCtor :: Can.Ctor -> Extractor (N.Name, [T.Type])
145extractCtor (Can.Ctor ctor _ _ args) =
146 (,) ctor <$> traverse extract args
150-- DEPS
153data Deps =
154 Deps
155 { _aliases :: Set.Set Opt.Global
156 , _unions :: Set.Set Opt.Global
157 }
160{-# NOINLINE noDeps #-}
161noDeps :: Deps
162noDeps =
163 Deps Set.empty Set.empty
167-- EXTRACTOR
170newtype Extractor a =
171 Extractor (
172 forall result.
173 Set.Set Opt.Global
174 -> Set.Set Opt.Global
175 -> (Set.Set Opt.Global -> Set.Set Opt.Global -> a -> result)
176 -> result
177 )
180run :: Extractor a -> (Deps, a)
181run (Extractor k) =
182 k Set.empty Set.empty $ \aliases unions value ->
183 ( Deps aliases unions, value )
186addAlias :: Opt.Global -> a -> Extractor a
187addAlias alias value =
188 Extractor $ \aliases unions ok ->
189 ok (Set.insert alias aliases) unions value
192addUnion :: Opt.Global -> a -> Extractor a
193addUnion union value =
194 Extractor $ \aliases unions ok ->
195 ok aliases (Set.insert union unions) value
198instance Functor Extractor where
199 fmap func (Extractor k) =
200 Extractor $ \aliases unions ok ->
201 let
202 ok1 a1 u1 value =
203 ok a1 u1 (func value)
204 in
205 k aliases unions ok1
208instance Applicative Extractor where
209 pure value =
210 Extractor $ \aliases unions ok ->
211 ok aliases unions value
213 (<*>) (Extractor kf) (Extractor kv) =
214 Extractor $ \aliases unions ok ->
215 let
216 ok1 a1 u1 func =
217 let
218 ok2 a2 u2 value =
219 ok a2 u2 (func value)
220 in
221 kv a1 u1 ok2
222 in
223 kf aliases unions ok1
226instance Monad Extractor where
227 return = pure
229 (>>=) (Extractor ka) callback =
230 Extractor $ \aliases unions ok ->
231 let
232 ok1 a1 u1 value =
233 case callback value of
234 Extractor kb -> kb a1 u1 ok
235 in
236 ka aliases unions ok1