git.iko.soy/elk
on 2deedfb help sign in
elk/src/Elm/Compiler/Type/Extract.hs
230 lines 5.3 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 (I.Interface _ unions _ _) = interfaces ! home
137 (Can.Union args constructors) = unions ! name
138 in
139 T.Union (toPublicName home name) args
140 <$> traverse (traverse (traverse extract)) constructors
144-- DEPS
147data Deps =
148 Deps
149 { _aliases :: Set.Set Opt.Global
150 , _unions :: Set.Set Opt.Global
151 }
154{-# NOINLINE noDeps #-}
155noDeps :: Deps
156noDeps =
157 Deps Set.empty Set.empty
161-- EXTRACTOR
164newtype Extractor a =
165 Extractor (
166 forall result.
167 Set.Set Opt.Global
168 -> Set.Set Opt.Global
169 -> (Set.Set Opt.Global -> Set.Set Opt.Global -> a -> result)
170 -> result
171 )
174run :: Extractor a -> (Deps, a)
175run (Extractor k) =
176 k Set.empty Set.empty $ \aliases unions value ->
177 ( Deps aliases unions, value )
180addAlias :: Opt.Global -> a -> Extractor a
181addAlias alias value =
182 Extractor $ \aliases unions ok ->
183 ok (Set.insert alias aliases) unions value
186addUnion :: Opt.Global -> a -> Extractor a
187addUnion union value =
188 Extractor $ \aliases unions ok ->
189 ok aliases (Set.insert union unions) value
192instance Functor Extractor where
193 fmap func (Extractor k) =
194 Extractor $ \aliases unions ok ->
195 let
196 ok1 a1 u1 value =
197 ok a1 u1 (func value)
198 in
199 k aliases unions ok1
202instance Applicative Extractor where
203 pure value =
204 Extractor $ \aliases unions ok ->
205 ok aliases unions value
207 (<*>) (Extractor kf) (Extractor kv) =
208 Extractor $ \aliases unions ok ->
209 let
210 ok1 a1 u1 func =
211 let
212 ok2 a2 u2 value =
213 ok a2 u2 (func value)
214 in
215 kv a1 u1 ok2
216 in
217 kf aliases unions ok1
220instance Monad Extractor where
221 return = pure
223 (>>=) (Extractor ka) callback =
224 Extractor $ \aliases unions ok ->
225 let
226 ok1 a1 u1 value =
227 case callback value of
228 Extractor kb -> kb a1 u1 ok
229 in
230 ka aliases unions ok1