git.iko.soy/elk
on dcce951 help sign in
elk/src/Elm/Compiler/Type/Extract.hs
161 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)
76 case mainType of
77 T.App _program [_flags, _model, msg] ->
78 let
79 (msgType, msgDeps) =
80 Writer.runWriter (extractHelp msg)
82 (aliases, unions) =
83 extractTransitive interfaces mempty msgDeps
84 in
85 Just $ Program msgType aliases unions
87 _ ->
88 Nothing
91type Alias =
92 ( String, [String], Type )
95type Union =
96 ( String, [String], [(String, [Type])] )
99extractTransitive :: Module.Interfaces -> Deps -> Deps -> ( [Alias], [Union] )
100extractTransitive interfaces oldDeps currentDeps =
101 let
102 (aliases, unions) =
103 diff oldDeps currentDeps
104 in
105 if Set.null aliases && Set.null unions then
106 ( [], [] )
108 else
109 let
110 (result, newDeps) =
111 Writer.runWriter $ do
112 publicAliases <- mapM (extractAlias interfaces) (Set.toList aliases)
113 publicUnions <- mapM (extractUnion interfaces) (Set.toList unions)
114 return ( Maybe.catMaybes publicAliases, Maybe.catMaybes publicUnions )
116 remainingResult =
117 extractTransitive interfaces (mappend oldDeps currentDeps) newDeps
118 in
119 mappend result remainingResult
122extractAlias :: Module.Interfaces -> Var.Canonical -> Writer.Writer Deps (Maybe Alias)
123extractAlias interfaces var =
124 let
125 toAlias (args, tipe) =
126 (,,) (Var.toString var) args <$> extractHelp tipe
127 in
128 traverse toAlias (get Module.iAliases interfaces var)
131extractUnion :: Module.Interfaces -> Var.Canonical -> Writer.Writer Deps (Maybe Union)
132extractUnion interfaces var =
133 let
134 toUnion (args, constructors) =
135 (,,) (Var.toString var) args
136 <$> traverse (traverse (traverse extractHelp)) constructors
137 in
138 traverse toUnion (get Module.iUnions interfaces var)
141get :: (Module.Interface -> Map.Map String a) -> Module.Interfaces -> Var.Canonical -> Maybe a
142get getInfo interfaces var =
143 do (home, name) <- getHome var
144 iface <- Map.lookup home interfaces
145 Map.lookup name (getInfo iface)
148getHome :: Var.Canonical -> Maybe (ModuleName.Canonical, String)
149getHome (Var.Canonical home name) =
150 case home of
151 Var.BuiltIn ->
152 Nothing
154 Var.Module moduleName ->
155 Just (moduleName, name)
157 Var.TopLevel moduleName ->
158 Just (moduleName, name)
160 Var.Local ->
161 Nothing