git.iko.soy/elk
on fbff9ce help sign in
elk/src/Elm/Compiler/Type/Extract.hs
158 lines 4.2 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.Strict 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 args ->
54 do Writer.tell ( Set.empty, Set.singleton var )
55 Type (Var.toText var) <$> 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 Type (Var.toText 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.Type _program [_flags, _model, msg] -> Just msg
80 T.Type _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 ( Text, [Text], Type )
92type Union =
93 ( Text, [Text], [(Text, [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.toText 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.toText var) args
133 <$> traverse (traverse (traverse extractHelp)) constructors
134 in
135 traverse toUnion (get Module.iUnions interfaces var)
138get :: (Module.Interface -> Map.Map Text 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, Text)
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