git.iko.soy/elk
on 2deedfb help sign in
elk/src/Elm/Kernel.hs
250 lines 6.1 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Elm.Kernel
4 ( Opt.KContent(..)
5 , parse
6 )
7 where
10import qualified Data.ByteString as B
11import qualified Data.List as List
12import qualified Data.Map as Map
13import Data.Monoid ((<>))
14import qualified Data.Set as Set
15import qualified Data.Text as Text
16import Data.Word (Word8)
19import qualified AST.Optimized as Opt
20import qualified AST.Source as Src
21import qualified AST.Module.Name as ModuleName
22import qualified Elm.Name as N
23import qualified Elm.Package as Pkg
24import Parse.Primitives (Parser, run)
25import qualified Parse.Primitives.Kernel as K
26import qualified Parse.Primitives.Symbol as Symbol
27import qualified Parse.Module as Module
28import qualified Reporting.Annotation as A
29import qualified Reporting.Error as E
33-- PARSE
36type ImportDict =
37 Map.Map N.Name [Pkg.Name]
40parse :: ImportDict -> B.ByteString -> Either E.Error Opt.KContent
41parse importDict sourceCode =
42 case run (parser importDict) sourceCode of
43 Right kernel ->
44 Right kernel
46 Left err ->
47 Left (E.Syntax err)
50parser :: ImportDict -> Parser Opt.KContent
51parser importDict =
52 do Symbol.jsMultiCommentOpen
53 Module.freshLine
54 imports <- Module.chompImports []
55 Symbol.jsMultiCommentClose
57 let (State vtable deps) = processImports importDict imports
59 chunks <- chompChunks vtable Map.empty Map.empty []
61 return $ Opt.KContent chunks deps
65-- PROCESS IMPORTS
68type VarTable =
69 Map.Map Text.Text Opt.KChunk
72data State =
73 State VarTable (Set.Set Opt.Global)
76processImports :: ImportDict -> [Src.Import] -> State
77processImports importDict imports =
78 List.foldl' (addImport importDict) (State Map.empty Set.empty) imports
81addImport :: ImportDict -> State -> Src.Import -> State
82addImport importDict state (Src.Import (A.At _ home) maybeAlias exposing) =
83 if ModuleName.isKernel home then
84 case maybeAlias of
85 Just _ ->
86 error ("Cannot use aliases on kernel import of: " ++ show home)
88 Nothing ->
89 addKernelImport (ModuleName.getKernel home) exposing state
91 else
92 case Map.lookup home importDict of
93 Just [pkg] ->
94 let
95 canonicalHome = ModuleName.Canonical pkg home
96 prefix = toPrefix home maybeAlias
97 in
98 addNormalImport canonicalHome prefix exposing state
100 _ ->
101 error ("Cannot find kernel import of: " ++ show home)
104-- INVARIANT: the `home` is the * in `Elm.Kernel.*`
105--
106addKernelImport :: N.Name -> Src.Exposing -> State -> State
107addKernelImport home exposing (State vtable deps) =
108 let
109 addVar table name =
110 Map.insert (home <> "_" <> name) (Opt.JsVar home name) table
111 in
112 State
113 (List.foldl' addVar vtable (toNames exposing))
114 (Set.insert (Opt.kernel home) deps)
117addNormalImport :: ModuleName.Canonical -> N.Name -> Src.Exposing -> State -> State
118addNormalImport home prefix exposing state =
119 let
120 addVar (State vtable deps) name =
121 State
122 (Map.insert (prefix <> "_" <> name) (Opt.ElmVar home name) vtable)
123 (Set.insert (Opt.Global home name) deps)
124 in
125 List.foldl' addVar state (toNames exposing)
128toPrefix :: N.Name -> Maybe N.Name -> N.Name
129toPrefix home maybeAlias =
130 case maybeAlias of
131 Just alias ->
132 alias
134 Nothing ->
135 if Text.isInfixOf "." home then
136 error ("kernel imports with dots need an alias: " ++ show home)
137 else
138 home
140toNames :: Src.Exposing -> [N.Name]
141toNames exposing =
142 case exposing of
143 Src.Open ->
144 error "Cannot have `exposing (..)` in kernel code."
146 Src.Explicit exposedList ->
147 map toName exposedList
150toName :: A.Located Src.Exposed -> N.Name
151toName (A.At _ exposed) =
152 case exposed of
153 Src.Lower name ->
154 name
156 Src.Upper name Src.Private ->
157 name
159 Src.Upper _ Src.Public ->
160 error "cannot have Maybe(..) syntax in kernel code header"
162 Src.Operator _ ->
163 error "cannot use binops in kernel code"
167-- PARSE CHUNKS
170chompChunks :: VarTable -> Enums -> Fields -> [Opt.KChunk] -> Parser [Opt.KChunk]
171chompChunks vtable enums fields chunks =
172 do (javascript, maybeTag) <- K.chunk
173 case maybeTag of
174 Nothing ->
175 return (Opt.JS javascript : chunks)
177 Just tag ->
178 case tag of
179 K.Prod ->
180 chompChunks vtable enums fields $
181 Opt.Prod : Opt.JS javascript : chunks
183 K.Debug ->
184 chompChunks vtable enums fields $
185 Opt.Debug : Opt.JS javascript : chunks
187 K.Import var ->
188 case Map.lookup var vtable of
189 Nothing ->
190 error ("Bad kernel symbol: " ++ Text.unpack var)
192 Just chunk ->
193 chompChunks vtable enums fields $
194 chunk : Opt.JS javascript : chunks
196 K.Enum n var ->
197 let (enum, newEnums) = lookupEnum n var enums in
198 chompChunks vtable newEnums fields $
199 Opt.Enum enum : Opt.JS javascript : chunks
201 K.ElmField name ->
202 chompChunks vtable enums fields $
203 Opt.ElmField name : Opt.JS javascript : chunks
205 K.JsField name ->
206 let (field, newFields) = lookupField name fields in
207 chompChunks vtable enums newFields $
208 Opt.JsField field : Opt.JS javascript : chunks
212-- FIELDS
215type Fields =
216 Map.Map Text.Text Int
219lookupField :: Text.Text -> Fields -> (Int, Fields)
220lookupField name fields =
221 case Map.lookup name fields of
222 Just n ->
223 ( n, fields )
225 Nothing ->
226 let n = Map.size fields in
227 ( n, Map.insert name n fields )
231-- ENUMS
234type Enums =
235 Map.Map Word8 (Map.Map N.Name Int)
238lookupEnum :: Word8 -> N.Name -> Enums -> (Int, Enums)
239lookupEnum word var allEnums =
240 let
241 enums =
242 Map.findWithDefault Map.empty word allEnums
243 in
244 case Map.lookup var enums of
245 Just n ->
246 ( n, allEnums )
248 Nothing ->
249 let n = Map.size enums in
250 ( n, Map.insert word (Map.insert var n enums) allEnums )