git.iko.soy/elk
on 4624721 help sign in
elk/src/Elm/Compiler/Type/Extract.hs
242 lines 5.7 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE Rank2Types #-}
4module Elm.Compiler.Type.Extract
5 ( fromAnnotation
6 , fromType
7 , fromProgram
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
86fromProgram :: I.Interfaces -> ModuleName.Canonical -> Maybe T.Program
87fromProgram interfaces name =
88 do iface <- Map.lookup name interfaces
89 mainType <- Map.lookup "main" (I._types iface)
90 message <- getMessage mainType
92 let (msgDeps, msgType) = run (extract message)
93 let (aliases, unions) = extractTransitive interfaces noDeps msgDeps
94 Just (T.Program msgType aliases unions)
97getMessage :: Can.Annotation -> Maybe Can.Type
98getMessage (Can.Forall _ mainType) =
99 case Type.deepDealias mainType of
100 Can.TType _ _program [_flags, _model, msg] ->
101 Just msg
103 Can.TType _ _node [msg] ->
104 Just msg
106 _ ->
107 Nothing
110extractTransitive :: I.Interfaces -> Deps -> Deps -> ( [T.Alias], [T.Union] )
111extractTransitive interfaces (Deps seenAliases seenUnions) (Deps nextAliases nextUnions) =
112 let
113 aliases = Set.difference nextAliases seenAliases
114 unions = Set.difference nextUnions seenUnions
115 in
116 if Set.null aliases && Set.null unions then
117 ( [], [] )
119 else
120 let
121 (newDeps, result) =
122 run $
123 (,)
124 <$> traverse (extractAlias interfaces) (Set.toList aliases)
125 <*> traverse (extractUnion interfaces) (Set.toList unions)
127 oldDeps =
128 Deps (Set.union seenAliases nextAliases) (Set.union seenUnions nextUnions)
130 remainingResult =
131 extractTransitive interfaces oldDeps newDeps
132 in
133 mappend result remainingResult
136extractAlias :: I.Interfaces -> Opt.Global -> Extractor T.Alias
137extractAlias interfaces (Opt.Global home name) =
138 let
139 (I.Interface _ _ aliases _) = interfaces ! home
140 (Can.Alias args aliasType _) = aliases ! name
141 in
142 T.Alias (toPublicName home name) args <$> extract aliasType
145extractUnion :: I.Interfaces -> Opt.Global -> Extractor T.Union
146extractUnion interfaces (Opt.Global home name) =
147 let
148 (I.Interface _ unions _ _) = interfaces ! home
149 (Can.Union args constructors) = unions ! name
150 in
151 T.Union (toPublicName home name) args
152 <$> traverse (traverse (traverse extract)) constructors
156-- DEPS
159data Deps =
160 Deps
161 { _aliases :: Set.Set Opt.Global
162 , _unions :: Set.Set Opt.Global
163 }
166{-# NOINLINE noDeps #-}
167noDeps :: Deps
168noDeps =
169 Deps Set.empty Set.empty
173-- EXTRACTOR
176newtype Extractor a =
177 Extractor (
178 forall result.
179 Set.Set Opt.Global
180 -> Set.Set Opt.Global
181 -> (Set.Set Opt.Global -> Set.Set Opt.Global -> a -> result)
182 -> result
183 )
186run :: Extractor a -> (Deps, a)
187run (Extractor k) =
188 k Set.empty Set.empty $ \aliases unions value ->
189 ( Deps aliases unions, value )
192addAlias :: Opt.Global -> a -> Extractor a
193addAlias alias value =
194 Extractor $ \aliases unions ok ->
195 ok (Set.insert alias aliases) unions value
198addUnion :: Opt.Global -> a -> Extractor a
199addUnion union value =
200 Extractor $ \aliases unions ok ->
201 ok aliases (Set.insert union unions) value
204instance Functor Extractor where
205 fmap func (Extractor k) =
206 Extractor $ \aliases unions ok ->
207 let
208 ok1 a1 u1 value =
209 ok a1 u1 (func value)
210 in
211 k aliases unions ok1
214instance Applicative Extractor where
215 pure value =
216 Extractor $ \aliases unions ok ->
217 ok aliases unions value
219 (<*>) (Extractor kf) (Extractor kv) =
220 Extractor $ \aliases unions ok ->
221 let
222 ok1 a1 u1 func =
223 let
224 ok2 a2 u2 value =
225 ok a2 u2 (func value)
226 in
227 kv a1 u1 ok2
228 in
229 kf aliases unions ok1
232instance Monad Extractor where
233 return = pure
235 (>>=) (Extractor ka) callback =
236 Extractor $ \aliases unions ok ->
237 let
238 ok1 a1 u1 value =
239 case callback value of
240 Extractor kb -> kb a1 u1 ok
241 in
242 ka aliases unions ok1