git.iko.soy/elk
on e00a3f3 help sign in
elk/src/Elm/Compiler/Type/Extract.hs
161 lines 4.3 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Elm.Compiler.Type.Extract
4 ( extract
5 , extractProgram
6 )
7 where
9import qualified Control.Monad.Writer as Writer
10import qualified Data.Map as Map
11import qualified Data.Maybe as Maybe
12import qualified Data.Set as Set
13import Data.Text (Text)
15import qualified AST.Module as Module
16import qualified AST.Module.Name as ModuleName
17import qualified AST.Type as T
18import qualified AST.Variable as Var
19import Elm.Compiler.Type (Type(..), Program(Program))
23-- EXTRACTION
26extract :: T.Canonical -> Type
27extract astType =
28 fst $ Writer.runWriter $ extractHelp astType
31type Deps =
32 ( Set.Set Var.Canonical -- aliases
33 , Set.Set Var.Canonical -- unions
34 )
37diff :: Deps -> Deps -> Deps
38diff (oldAliases, oldUnions) (newAliases, newUnions) =
39 ( Set.difference newAliases oldAliases
40 , Set.difference newUnions oldUnions
41 )
44extractHelp :: T.Canonical -> Writer.Writer Deps Type
45extractHelp astType =
46 case astType of
47 T.Lambda arg result ->
48 Lambda <$> extractHelp arg <*> extractHelp result
50 T.Var x ->
51 return (Var x)
53 T.Type var ->
54 do Writer.tell ( Set.empty, Set.singleton var )
55 return (Type (Var.toText var))
57 T.App constructor args ->
58 App <$> extractHelp constructor <*> traverse extractHelp args
60 T.Record fields ext ->
61 Record
62 <$> traverse (traverse extractHelp) fields
63 <*> traverse extractHelp ext
65 T.Aliased name args aliasedType ->
66 do Writer.tell ( Set.singleton name, Set.empty )
67 _ <- extractHelp (T.dealias args aliasedType)
68 App (Type (Var.toText name)) <$> traverse (extractHelp . snd) args
72-- EXTRACT MODEL, MSG, AND ANY TRANSITIVE DEPENDENCIES
75extractProgram :: Module.Interfaces -> ModuleName.Canonical -> Maybe Program
76extractProgram interfaces name =
77 do iface <- Map.lookup name interfaces
78 mainType <- Map.lookup "main" (Module.iTypes iface)
80 message <-
81 case T.deepDealias mainType of
82 T.App _program [_flags, _model, msg] -> Just msg
83 T.App _node [msg] -> Just msg
84 _ -> Nothing
86 let (msgType, msgDeps) = Writer.runWriter (extractHelp message)
87 let (aliases, unions) = extractTransitive interfaces mempty msgDeps
88 Just (Program msgType aliases unions)
91type Alias =
92 ( Text, [Text], Type )
95type Union =
96 ( Text, [Text], [(Text, [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.toText 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.toText var) args
136 <$> traverse (traverse (traverse extractHelp)) constructors
137 in
138 traverse toUnion (get Module.iUnions interfaces var)
141get :: (Module.Interface -> Map.Map Text 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, Text)
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