git.iko.soy/elk
on dd2feec help sign in
elk/src/Elm/Compiler/Type/Extract.hs
235 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 qualified Data.Set as Set
17import qualified AST.Canonical as Can
18import qualified AST.Optimized as Opt
19import qualified AST.Module.Name as ModuleName
20import qualified AST.Utils.Type as Type
21import qualified Elm.Compiler.Type as T
22import qualified Elm.Interface as I
23import qualified Elm.Name as N
27-- EXTRACTION
30fromAnnotation :: Can.Annotation -> T.Type
31fromAnnotation (Can.Forall _ astType) =
32 fromType astType
35fromType :: Can.Type -> T.Type
36fromType astType =
37 snd (run (extract astType))
40extract :: Can.Type -> Extractor T.Type
41extract astType =
42 case astType of
43 Can.TLambda arg result ->
44 T.Lambda
45 <$> extract arg
46 <*> extract result
48 Can.TVar x ->
49 pure (T.Var x)
51 Can.TType home name args ->
52 addUnion (Opt.Global home name) (T.Type (toPublicName home name))
53 <*> traverse extract args
55 Can.TRecord fields ext ->
56 T.Record
57 <$> fmap Map.toList (traverse extract fields)
58 <*> traverse extract ext
60 Can.TUnit ->
61 pure T.Unit
63 Can.TTuple a b maybeC ->
64 T.Tuple
65 <$> extract a
66 <*> extract b
67 <*> traverse extract (Maybe.maybeToList maybeC)
69 Can.TAlias home name args aliasType ->
70 do addAlias (Opt.Global home name) ()
71 _ <- extract (Type.dealias args aliasType)
72 T.Type (toPublicName home name)
73 <$> traverse (extract . snd) args
76toPublicName :: ModuleName.Canonical -> N.Name -> N.Name
77toPublicName (ModuleName.Canonical _ home) name =
78 N.sepBy 0x2E {- . -} home name
82-- EXTRACT MODEL, MSG, AND ANY TRANSITIVE DEPENDENCIES
85fromMsg :: I.Interfaces -> Can.Type -> T.DebugMetadata
86fromMsg interfaces message =
87 let
88 (msgDeps, msgType) =
89 run (extract message)
91 (aliases, unions) =
92 extractTransitive interfaces noDeps msgDeps
93 in
94 T.DebugMetadata msgType aliases unions
97extractTransitive :: I.Interfaces -> Deps -> Deps -> ( [T.Alias], [T.Union] )
98extractTransitive interfaces (Deps seenAliases seenUnions) (Deps nextAliases nextUnions) =
99 let
100 aliases = Set.difference nextAliases seenAliases
101 unions = Set.difference nextUnions seenUnions
102 in
103 if Set.null aliases && Set.null unions then
104 ( [], [] )
106 else
107 let
108 (newDeps, result) =
109 run $
110 (,)
111 <$> traverse (extractAlias interfaces) (Set.toList aliases)
112 <*> traverse (extractUnion interfaces) (Set.toList unions)
114 oldDeps =
115 Deps (Set.union seenAliases nextAliases) (Set.union seenUnions nextUnions)
117 remainingResult =
118 extractTransitive interfaces oldDeps newDeps
119 in
120 mappend result remainingResult
123extractAlias :: I.Interfaces -> Opt.Global -> Extractor T.Alias
124extractAlias interfaces (Opt.Global home name) =
125 let
126 (I.Interface _ _ aliases _) = interfaces ! home
127 (Can.Alias args aliasType _) = aliases ! name
128 in
129 T.Alias (toPublicName home name) args <$> extract aliasType
132extractUnion :: I.Interfaces -> Opt.Global -> Extractor T.Union
133extractUnion interfaces (Opt.Global home name) =
134 let
135 pname = toPublicName home name
136 unions = I._unions (interfaces ! home)
137 in
138 case unions ! name of
139 Can.Union vars ctors _ _ ->
140 T.Union pname vars <$> traverse extractCtor ctors
143extractCtor :: Can.Ctor -> Extractor (N.Name, [T.Type])
144extractCtor (Can.Ctor ctor _ _ args) =
145 (,) ctor <$> traverse extract args
149-- DEPS
152data Deps =
153 Deps
154 { _aliases :: Set.Set Opt.Global
155 , _unions :: Set.Set Opt.Global
156 }
159{-# NOINLINE noDeps #-}
160noDeps :: Deps
161noDeps =
162 Deps Set.empty Set.empty
166-- EXTRACTOR
169newtype Extractor a =
170 Extractor (
171 forall result.
172 Set.Set Opt.Global
173 -> Set.Set Opt.Global
174 -> (Set.Set Opt.Global -> Set.Set Opt.Global -> a -> result)
175 -> result
176 )
179run :: Extractor a -> (Deps, a)
180run (Extractor k) =
181 k Set.empty Set.empty $ \aliases unions value ->
182 ( Deps aliases unions, value )
185addAlias :: Opt.Global -> a -> Extractor a
186addAlias alias value =
187 Extractor $ \aliases unions ok ->
188 ok (Set.insert alias aliases) unions value
191addUnion :: Opt.Global -> a -> Extractor a
192addUnion union value =
193 Extractor $ \aliases unions ok ->
194 ok aliases (Set.insert union unions) value
197instance Functor Extractor where
198 fmap func (Extractor k) =
199 Extractor $ \aliases unions ok ->
200 let
201 ok1 a1 u1 value =
202 ok a1 u1 (func value)
203 in
204 k aliases unions ok1
207instance Applicative Extractor where
208 pure value =
209 Extractor $ \aliases unions ok ->
210 ok aliases unions value
212 (<*>) (Extractor kf) (Extractor kv) =
213 Extractor $ \aliases unions ok ->
214 let
215 ok1 a1 u1 func =
216 let
217 ok2 a2 u2 value =
218 ok a2 u2 (func value)
219 in
220 kv a1 u1 ok2
221 in
222 kf aliases unions ok1
225instance Monad Extractor where
226 return = pure
228 (>>=) (Extractor ka) callback =
229 Extractor $ \aliases unions ok ->
230 let
231 ok1 a1 u1 value =
232 case callback value of
233 Extractor kb -> kb a1 u1 ok
234 in
235 ka aliases unions ok1