git.iko.soy/elk
on 014d640 help sign in
elk/src/Elm/Compiler/Type/Extract.hs
166 lines 4.3 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Elm.Compiler.Type.Extract
3 ( extract
4 , extractProgram
5 )
6 where
8import qualified Control.Monad.Writer as Writer
9import qualified Data.Map as Map
10import qualified Data.Set as Set
11import qualified AST.Module as Module
12import qualified AST.Module.Name as ModuleName
13import qualified AST.Type as T
14import qualified AST.Variable as Var
15import Elm.Compiler.Type (Type(..), Program(Program))
19-- EXTRACTION
22extract :: T.Canonical -> Type
23extract astType =
24 fst $ Writer.runWriter $ extractHelp astType
27type Deps =
28 ( Set.Set Var.Canonical -- aliases
29 , Set.Set Var.Canonical -- unions
30 )
33diff :: Deps -> Deps -> Deps
34diff (oldAliases, oldUnions) (newAliases, newUnions) =
35 ( Set.difference newAliases oldAliases
36 , Set.difference newUnions oldUnions
37 )
40extractHelp :: T.Canonical -> Writer.Writer Deps Type
41extractHelp astType =
42 case astType of
43 T.Lambda arg result ->
44 Lambda <$> extractHelp arg <*> extractHelp result
46 T.Var x ->
47 return $ Var x
49 T.Type var ->
50 do Writer.tell ( Set.empty, Set.singleton var )
51 return $ Type $ Var.toString var
53 T.App constructor args ->
54 App <$> extractHelp constructor <*> traverse extractHelp args
56 T.Record fields ext ->
57 Record
58 <$> traverse (traverse extractHelp) fields
59 <*> traverse extractHelp ext
61 T.Aliased name args aliasedType ->
62 do Writer.tell ( Set.singleton name, Set.empty )
63 _ <- extractHelp (T.dealias args aliasedType)
64 App (Type (Var.toString name)) <$> traverse (extractHelp . snd) args
68-- EXTRACT MODEL, MSG, AND ANY TRANSITIVE DEPENDENCIES
71extractProgram :: Module.Interfaces -> ModuleName.Canonical -> Maybe Program
72extractProgram interfaces name =
73 do iface <- Map.lookup name interfaces
74 mainType <- Map.lookup "main" (Module.iTypes iface)
75 case mainType of
76 T.App _program [_flags, model, msg] ->
77 let
78 (modelType, modelDeps) =
79 Writer.runWriter (extractHelp model)
81 (msgType, msgDeps) =
82 Writer.runWriter (extractHelp msg)
84 (aliases, unions) =
85 extractTransitive interfaces mempty (mappend modelDeps msgDeps)
86 in
87 Just $ Program modelType msgType aliases unions
89 _ ->
90 Nothing
93type Alias =
94 ( String, [String], Type )
97type Union =
98 ( String, [String], [(String, [Type])] )
101extractTransitive :: Module.Interfaces -> Deps -> Deps -> ( [Alias], [Union] )
102extractTransitive interfaces oldDeps currentDeps =
103 let
104 (aliases, unions) =
105 diff oldDeps currentDeps
106 in
107 if Set.null aliases && Set.null unions then
108 ( [], [] )
110 else
111 let
112 (result, newDeps) =
113 Writer.runWriter $
114 (,)
115 <$> mapM (extractAlias interfaces) (Set.toList aliases)
116 <*> mapM (extractUnion interfaces) (Set.toList unions)
118 remainingResult =
119 extractTransitive interfaces (mappend oldDeps currentDeps) newDeps
120 in
121 mappend result remainingResult
124extractAlias :: Module.Interfaces -> Var.Canonical -> Writer.Writer Deps Alias
125extractAlias interfaces var =
126 case get Module.iAliases interfaces var of
127 Nothing ->
128 return ( Var.toString var, [], Type "_Tuple0" )
130 Just (args, tipe) ->
131 (,,) (Var.toString var) args
132 <$> extractHelp tipe
135extractUnion :: Module.Interfaces -> Var.Canonical -> Writer.Writer Deps Union
136extractUnion interfaces var =
137 case get Module.iUnions interfaces var of
138 Nothing ->
139 return ( Var.toString var, [], [] )
141 Just (args, constructors) ->
142 (,,) (Var.toString var) args
143 <$> traverse (traverse (traverse extractHelp)) constructors
146get :: (Module.Interface -> Map.Map String a) -> Module.Interfaces -> Var.Canonical -> Maybe a
147get getInfo interfaces var =
148 do (home, name) <- getHome var
149 iface <- Map.lookup home interfaces
150 Map.lookup name (getInfo iface)
153getHome :: Var.Canonical -> Maybe (ModuleName.Canonical, String)
154getHome (Var.Canonical home name) =
155 case home of
156 Var.BuiltIn ->
157 Nothing
159 Var.Module moduleName ->
160 Just (moduleName, name)
162 Var.TopLevel moduleName ->
163 Just (moduleName, name)
165 Var.Local ->
166 Nothing