git.iko.soy/elk
on 0bdfd73 help sign in
elk/src/Elm/Kernel.hs
248 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 qualified Data.Set as Set
14import Data.Word (Word8)
17import qualified AST.Optimized as Opt
18import qualified AST.Source as Src
19import qualified AST.Module.Name as ModuleName
20import qualified Elm.Name as N
21import qualified Elm.Package as Pkg
22import Parse.Primitives (Parser, run)
23import qualified Parse.Primitives.Kernel as K
24import qualified Parse.Primitives.Symbol as Symbol
25import qualified Parse.Module as Module
26import qualified Reporting.Annotation as A
27import qualified Reporting.Error as E
31-- PARSE
34type ImportDict =
35 Map.Map N.Name [Pkg.Name]
38parse :: ImportDict -> B.ByteString -> Either E.Error Opt.KContent
39parse importDict sourceCode =
40 case run (parser importDict) sourceCode of
41 Right kernel ->
42 Right kernel
44 Left err ->
45 Left (E.Syntax err)
48parser :: ImportDict -> Parser Opt.KContent
49parser importDict =
50 do Symbol.jsMultiCommentOpen
51 Module.freshLine
52 imports <- Module.chompImports []
53 Symbol.jsMultiCommentClose
55 let (State vtable deps) = processImports importDict imports
57 chunks <- chompChunks vtable Map.empty Map.empty []
59 return $ Opt.KContent chunks deps
63-- PROCESS IMPORTS
66type VarTable =
67 Map.Map N.Name Opt.KChunk
70data State =
71 State VarTable (Set.Set Opt.Global)
74processImports :: ImportDict -> [Src.Import] -> State
75processImports importDict imports =
76 List.foldl' (addImport importDict) (State Map.empty Set.empty) imports
79addImport :: ImportDict -> State -> Src.Import -> State
80addImport importDict state (Src.Import (A.At _ home) maybeAlias exposing) =
81 if ModuleName.isKernel home then
82 case maybeAlias of
83 Just _ ->
84 error ("Cannot use aliases on kernel import of: " ++ N.toString home)
86 Nothing ->
87 addKernelImport (ModuleName.getKernel home) exposing state
89 else
90 case Map.lookup home importDict of
91 Just [pkg] ->
92 let
93 canonicalHome = ModuleName.Canonical pkg home
94 prefix = toPrefix home maybeAlias
95 in
96 addNormalImport canonicalHome prefix exposing state
98 _ ->
99 error ("Cannot find kernel import of: " ++ N.toString home)
102-- INVARIANT: the `home` is the * in `Elm.Kernel.*`
103--
104addKernelImport :: N.Name -> Src.Exposing -> State -> State
105addKernelImport home exposing (State vtable deps) =
106 let
107 addVar table name =
108 Map.insert (N.sepBy 0x5F {- _ -} home name) (Opt.JsVar home name) table
109 in
110 State
111 (List.foldl' addVar vtable (toNames exposing))
112 (Set.insert (Opt.kernel home) deps)
115addNormalImport :: ModuleName.Canonical -> N.Name -> Src.Exposing -> State -> State
116addNormalImport home prefix exposing state =
117 let
118 addVar (State vtable deps) name =
119 State
120 (Map.insert (N.sepBy 0x5F {- _ -} prefix name) (Opt.ElmVar home name) vtable)
121 (Set.insert (Opt.Global home name) deps)
122 in
123 List.foldl' addVar state (toNames exposing)
126toPrefix :: N.Name -> Maybe N.Name -> N.Name
127toPrefix home maybeAlias =
128 case maybeAlias of
129 Just alias ->
130 alias
132 Nothing ->
133 if N.contains 0x2E {- . -} home then
134 error ("kernel imports with dots need an alias: " ++ show (N.toString home))
135 else
136 home
138toNames :: Src.Exposing -> [N.Name]
139toNames exposing =
140 case exposing of
141 Src.Open ->
142 error "Cannot have `exposing (..)` in kernel code."
144 Src.Explicit exposedList ->
145 map toName exposedList
148toName :: A.Located Src.Exposed -> N.Name
149toName (A.At _ exposed) =
150 case exposed of
151 Src.Lower name ->
152 name
154 Src.Upper name Src.Private ->
155 name
157 Src.Upper _ Src.Public ->
158 error "cannot have Maybe(..) syntax in kernel code header"
160 Src.Operator _ ->
161 error "cannot use binops in kernel code"
165-- PARSE CHUNKS
168chompChunks :: VarTable -> Enums -> Fields -> [Opt.KChunk] -> Parser [Opt.KChunk]
169chompChunks vtable enums fields chunks =
170 do (javascript, maybeTag) <- K.chunk
171 case maybeTag of
172 Nothing ->
173 return (Opt.JS javascript : chunks)
175 Just tag ->
176 case tag of
177 K.Prod ->
178 chompChunks vtable enums fields $
179 Opt.Prod : Opt.JS javascript : chunks
181 K.Debug ->
182 chompChunks vtable enums fields $
183 Opt.Debug : Opt.JS javascript : chunks
185 K.Import var ->
186 case Map.lookup var vtable of
187 Nothing ->
188 error ("Bad kernel symbol: " ++ N.toString var)
190 Just chunk ->
191 chompChunks vtable enums fields $
192 chunk : Opt.JS javascript : chunks
194 K.Enum n var ->
195 let (enum, newEnums) = lookupEnum n var enums in
196 chompChunks vtable newEnums fields $
197 Opt.JsEnum enum : Opt.JS javascript : chunks
199 K.ElmField name ->
200 chompChunks vtable enums fields $
201 Opt.ElmField name : Opt.JS javascript : chunks
203 K.JsField name ->
204 let (field, newFields) = lookupField name fields in
205 chompChunks vtable enums newFields $
206 Opt.JsField field : Opt.JS javascript : chunks
210-- FIELDS
213type Fields =
214 Map.Map N.Name Int
217lookupField :: N.Name -> Fields -> (Int, Fields)
218lookupField name fields =
219 case Map.lookup name fields of
220 Just n ->
221 ( n, fields )
223 Nothing ->
224 let n = Map.size fields in
225 ( n, Map.insert name n fields )
229-- ENUMS
232type Enums =
233 Map.Map Word8 (Map.Map N.Name Int)
236lookupEnum :: Word8 -> N.Name -> Enums -> (Int, Enums)
237lookupEnum word var allEnums =
238 let
239 enums =
240 Map.findWithDefault Map.empty word allEnums
241 in
242 case Map.lookup var enums of
243 Just n ->
244 ( n, allEnums )
246 Nothing ->
247 let n = Map.size enums in
248 ( n, Map.insert word (Map.insert var n enums) allEnums )