git.iko.soy/elk
on fcf5cef help sign in
elk/src/Elm/Compiler/Type/Extract.hs
158 lines 4.2 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.Maybe as Maybe
11import qualified Data.Set as Set
12import qualified AST.Module as Module
13import qualified AST.Module.Name as ModuleName
14import qualified AST.Type as T
15import qualified AST.Variable as Var
16import Elm.Compiler.Type (Type(..), Program(Program))
20-- EXTRACTION
23extract :: T.Canonical -> Type
24extract astType =
25 fst $ Writer.runWriter $ extractHelp astType
28type Deps =
29 ( Set.Set Var.Canonical -- aliases
30 , Set.Set Var.Canonical -- unions
31 )
34diff :: Deps -> Deps -> Deps
35diff (oldAliases, oldUnions) (newAliases, newUnions) =
36 ( Set.difference newAliases oldAliases
37 , Set.difference newUnions oldUnions
38 )
41extractHelp :: T.Canonical -> Writer.Writer Deps Type
42extractHelp astType =
43 case astType of
44 T.Lambda arg result ->
45 Lambda <$> extractHelp arg <*> extractHelp result
47 T.Var x ->
48 return $ Var x
50 T.Type var ->
51 do Writer.tell ( Set.empty, Set.singleton var )
52 return $ Type $ Var.toString var
54 T.App constructor args ->
55 App <$> extractHelp constructor <*> traverse extractHelp args
57 T.Record fields ext ->
58 Record
59 <$> traverse (traverse extractHelp) fields
60 <*> traverse extractHelp ext
62 T.Aliased name args aliasedType ->
63 do Writer.tell ( Set.singleton name, Set.empty )
64 _ <- extractHelp (T.dealias args aliasedType)
65 App (Type (Var.toString name)) <$> traverse (extractHelp . snd) args
69-- EXTRACT MODEL, MSG, AND ANY TRANSITIVE DEPENDENCIES
72extractProgram :: Module.Interfaces -> ModuleName.Canonical -> Maybe Program
73extractProgram interfaces name =
74 do iface <- Map.lookup name interfaces
75 mainType <- Map.lookup "main" (Module.iTypes iface)
77 message <-
78 case T.deepDealias mainType of
79 T.App _program [_flags, _model, msg] -> Just msg
80 T.App _node [msg] -> Just msg
81 _ -> Nothing
83 let (msgType, msgDeps) = Writer.runWriter (extractHelp message)
84 let (aliases, unions) = extractTransitive interfaces mempty msgDeps
85 Just $ Program msgType aliases unions
88type Alias =
89 ( String, [String], Type )
92type Union =
93 ( String, [String], [(String, [Type])] )
96extractTransitive :: Module.Interfaces -> Deps -> Deps -> ( [Alias], [Union] )
97extractTransitive interfaces oldDeps currentDeps =
98 let
99 (aliases, unions) =
100 diff oldDeps currentDeps
101 in
102 if Set.null aliases && Set.null unions then
103 ( [], [] )
105 else
106 let
107 (result, newDeps) =
108 Writer.runWriter $ do
109 publicAliases <- mapM (extractAlias interfaces) (Set.toList aliases)
110 publicUnions <- mapM (extractUnion interfaces) (Set.toList unions)
111 return ( Maybe.catMaybes publicAliases, Maybe.catMaybes publicUnions )
113 remainingResult =
114 extractTransitive interfaces (mappend oldDeps currentDeps) newDeps
115 in
116 mappend result remainingResult
119extractAlias :: Module.Interfaces -> Var.Canonical -> Writer.Writer Deps (Maybe Alias)
120extractAlias interfaces var =
121 let
122 toAlias (args, tipe) =
123 (,,) (Var.toString var) args <$> extractHelp tipe
124 in
125 traverse toAlias (get Module.iAliases interfaces var)
128extractUnion :: Module.Interfaces -> Var.Canonical -> Writer.Writer Deps (Maybe Union)
129extractUnion interfaces var =
130 let
131 toUnion (args, constructors) =
132 (,,) (Var.toString var) args
133 <$> traverse (traverse (traverse extractHelp)) constructors
134 in
135 traverse toUnion (get Module.iUnions interfaces var)
138get :: (Module.Interface -> Map.Map String a) -> Module.Interfaces -> Var.Canonical -> Maybe a
139get getInfo interfaces var =
140 do (home, name) <- getHome var
141 iface <- Map.lookup home interfaces
142 Map.lookup name (getInfo iface)
145getHome :: Var.Canonical -> Maybe (ModuleName.Canonical, String)
146getHome (Var.Canonical home name) =
147 case home of
148 Var.BuiltIn ->
149 Nothing
151 Var.Module moduleName ->
152 Just (moduleName, name)
154 Var.TopLevel moduleName ->
155 Just (moduleName, name)
157 Var.Local ->
158 Nothing