git.iko.soy/elk
on 0bdfd73 help sign in
elk/src/Elm/Compiler/Type/Extract.hs
234 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 do efields <- fmap Map.toList (traverse extract fields)
57 pure (T.Record efields ext)
59 Can.TUnit ->
60 pure T.Unit
62 Can.TTuple a b maybeC ->
63 T.Tuple
64 <$> extract a
65 <*> extract b
66 <*> traverse extract (Maybe.maybeToList maybeC)
68 Can.TAlias home name args aliasType ->
69 do addAlias (Opt.Global home name) ()
70 _ <- extract (Type.dealias args aliasType)
71 T.Type (toPublicName home name)
72 <$> traverse (extract . snd) args
75toPublicName :: ModuleName.Canonical -> N.Name -> N.Name
76toPublicName (ModuleName.Canonical _ home) name =
77 N.sepBy 0x2E {- . -} home name
81-- EXTRACT MODEL, MSG, AND ANY TRANSITIVE DEPENDENCIES
84fromMsg :: I.Interfaces -> Can.Type -> T.DebugMetadata
85fromMsg interfaces message =
86 let
87 (msgDeps, msgType) =
88 run (extract message)
90 (aliases, unions) =
91 extractTransitive interfaces noDeps msgDeps
92 in
93 T.DebugMetadata msgType aliases unions
96extractTransitive :: I.Interfaces -> Deps -> Deps -> ( [T.Alias], [T.Union] )
97extractTransitive interfaces (Deps seenAliases seenUnions) (Deps nextAliases nextUnions) =
98 let
99 aliases = Set.difference nextAliases seenAliases
100 unions = Set.difference nextUnions seenUnions
101 in
102 if Set.null aliases && Set.null unions then
103 ( [], [] )
105 else
106 let
107 (newDeps, result) =
108 run $
109 (,)
110 <$> traverse (extractAlias interfaces) (Set.toList aliases)
111 <*> traverse (extractUnion interfaces) (Set.toList unions)
113 oldDeps =
114 Deps (Set.union seenAliases nextAliases) (Set.union seenUnions nextUnions)
116 remainingResult =
117 extractTransitive interfaces oldDeps newDeps
118 in
119 mappend result remainingResult
122extractAlias :: I.Interfaces -> Opt.Global -> Extractor T.Alias
123extractAlias interfaces (Opt.Global home name) =
124 let
125 (I.Interface _ _ aliases _) = interfaces ! home
126 (Can.Alias args aliasType _) = aliases ! name
127 in
128 T.Alias (toPublicName home name) args <$> extract aliasType
131extractUnion :: I.Interfaces -> Opt.Global -> Extractor T.Union
132extractUnion interfaces (Opt.Global home name) =
133 let
134 pname = toPublicName home name
135 unions = I._unions (interfaces ! home)
136 in
137 case unions ! name of
138 Can.Union vars ctors _ _ ->
139 T.Union pname vars <$> traverse extractCtor ctors
142extractCtor :: Can.Ctor -> Extractor (N.Name, [T.Type])
143extractCtor (Can.Ctor ctor _ _ args) =
144 (,) ctor <$> traverse extract args
148-- DEPS
151data Deps =
152 Deps
153 { _aliases :: Set.Set Opt.Global
154 , _unions :: Set.Set Opt.Global
155 }
158{-# NOINLINE noDeps #-}
159noDeps :: Deps
160noDeps =
161 Deps Set.empty Set.empty
165-- EXTRACTOR
168newtype Extractor a =
169 Extractor (
170 forall result.
171 Set.Set Opt.Global
172 -> Set.Set Opt.Global
173 -> (Set.Set Opt.Global -> Set.Set Opt.Global -> a -> result)
174 -> result
175 )
178run :: Extractor a -> (Deps, a)
179run (Extractor k) =
180 k Set.empty Set.empty $ \aliases unions value ->
181 ( Deps aliases unions, value )
184addAlias :: Opt.Global -> a -> Extractor a
185addAlias alias value =
186 Extractor $ \aliases unions ok ->
187 ok (Set.insert alias aliases) unions value
190addUnion :: Opt.Global -> a -> Extractor a
191addUnion union value =
192 Extractor $ \aliases unions ok ->
193 ok aliases (Set.insert union unions) value
196instance Functor Extractor where
197 fmap func (Extractor k) =
198 Extractor $ \aliases unions ok ->
199 let
200 ok1 a1 u1 value =
201 ok a1 u1 (func value)
202 in
203 k aliases unions ok1
206instance Applicative Extractor where
207 pure value =
208 Extractor $ \aliases unions ok ->
209 ok aliases unions value
211 (<*>) (Extractor kf) (Extractor kv) =
212 Extractor $ \aliases unions ok ->
213 let
214 ok1 a1 u1 func =
215 let
216 ok2 a2 u2 value =
217 ok a2 u2 (func value)
218 in
219 kv a1 u1 ok2
220 in
221 kf aliases unions ok1
224instance Monad Extractor where
225 return = pure
227 (>>=) (Extractor ka) callback =
228 Extractor $ \aliases unions ok ->
229 let
230 ok1 a1 u1 value =
231 case callback value of
232 Extractor kb -> kb a1 u1 ok
233 in
234 ka aliases unions ok1