@@ -1,31 +1,197 @@
11{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
23module Elm.Kernel
3− ( Kernel.Data(..)
4− , Kernel.Content
4+ ( Kernel(..)
55 , parse
66 )
77 where
88
99
10−import Data.Text (Text)
10+import qualified Data.ByteString as B
11+import qualified Data.Map as Map
12+import Data.Monoid ((<>))
13+import qualified Data.Text as Text
14+import Data.Word (Word8)
1115
12−import qualified AST.Kernel as Kernel (Data(..), Content(..))
13−import qualified Elm.Compiler.Internals as I
14−import qualified Parse.Helpers as Parse (run)
15−import qualified Parse.Kernel as Kernel (parser)
16+
17+import qualified AST.Optimized as Opt
18+import qualified AST.Source as Src
19+import qualified AST.Module.Name as ModuleName
20+import qualified Elm.Name as N
21+import Parse.Primitives (Parser, run)
22+import qualified Parse.Primitives.Kernel as K
23+import qualified Parse.Primitives.Symbol as Symbol
24+import qualified Parse.Module as Module
1625import qualified Reporting.Annotation as A
17−import qualified Reporting.Error as Error
26+import qualified Reporting.Error as E
27+
28+
1829
30+-- PARSE
1931
2032
21−-- PARSE KERNEL
33+data Kernel =
34+ Kernel
35+ { _imports :: [(N.Name, N.Name)]
36+ , _chunks :: [Opt.KChunk]
37+ }
2238
2339
24−parse :: Text -> Either I.Error Kernel.Content
40+parse :: B.ByteString -> Either E.Error Kernel
2541parse sourceCode =
26− case Parse.run Kernel.parser sourceCode of
27− Right content ->
28− Right content
42+ case run parser sourceCode of
43+ Right kernel ->
44+ Right kernel
2945
3046 Left err ->
31− Left (I.Error (A.map Error.Syntax err))
47+ Left (E.Syntax err)
48+
49+
50+
51+-- PARSER
52+
53+
54+parser :: Parser Kernel
55+parser =
56+ do Symbol.jsMultiCommentOpen
57+ Module.freshLine
58+ srcImports <- Module.chompImports []
59+ Symbol.jsMultiCommentClose
60+ let imports = Map.unions (map destructImport srcImports)
61+ chunks <- parserHelp imports Map.empty Map.empty []
62+ return $ Kernel (Map.elems imports) chunks
63+
64+
65+parserHelp :: Imports -> Enums -> Fields -> [Opt.KChunk] -> Parser [Opt.KChunk]
66+parserHelp imports enums fields chunks =
67+ do (javascript, maybeTag) <- K.chunk
68+ case maybeTag of
69+ Nothing ->
70+ return (Opt.JS javascript : chunks)
71+
72+ Just tag ->
73+ case tag of
74+ K.Prod ->
75+ parserHelp imports enums fields $
76+ Opt.Prod : Opt.JS javascript : chunks
77+
78+ K.Debug ->
79+ parserHelp imports enums fields $
80+ Opt.Debug : Opt.JS javascript : chunks
81+
82+ K.Import var ->
83+ case Map.lookup var imports of
84+ Nothing ->
85+ error ("Bad kernel symbol: " ++ Text.unpack var)
86+
87+ Just (home, name) ->
88+ parserHelp imports enums fields $
89+ Opt.Var home name : Opt.JS javascript : chunks
90+
91+ K.Enum n var ->
92+ let (enum, newEnums) = lookupEnum n var enums in
93+ parserHelp imports newEnums fields $
94+ Opt.Enum enum : Opt.JS javascript : chunks
95+
96+ K.ElmField name ->
97+ parserHelp imports enums fields $
98+ Opt.ElmField name : Opt.JS javascript : chunks
99+
100+ K.JsField name ->
101+ let (field, newFields) = lookupField name fields in
102+ parserHelp imports enums newFields $
103+ Opt.JsField field : Opt.JS javascript : chunks
104+
105+
106+
107+-- FIELDS
108+
109+
110+type Fields =
111+ Map.Map Text.Text Int
112+
113+
114+lookupField :: Text.Text -> Fields -> (Int, Fields)
115+lookupField name fields =
116+ case Map.lookup name fields of
117+ Just n ->
118+ ( n, fields )
119+
120+ Nothing ->
121+ let n = Map.size fields in
122+ ( n, Map.insert name n fields )
123+
124+
125+
126+-- ENUMS
127+
128+
129+type Enums =
130+ Map.Map Word8 (Map.Map N.Name Int)
131+
132+
133+lookupEnum :: Word8 -> N.Name -> Enums -> (Int, Enums)
134+lookupEnum word var allEnums =
135+ let
136+ enums =
137+ Map.findWithDefault Map.empty word allEnums
138+ in
139+ case Map.lookup var enums of
140+ Just n ->
141+ ( n, allEnums )
142+
143+ Nothing ->
144+ let n = Map.size enums in
145+ ( n, Map.insert word (Map.insert var n enums) allEnums )
146+
147+
148+
149+-- IMPORTS
150+
151+
152+type Imports =
153+ Map.Map Text.Text (N.Name, N.Name)
154+
155+
156+destructImport :: Src.Import -> Imports
157+destructImport (Src.Import (A.At _ moduleName) maybeAlias exposing) =
158+ let
159+ shortName =
160+ case maybeAlias of
161+ Just alias ->
162+ alias
163+
164+ Nothing ->
165+ if ModuleName.isKernel moduleName then
166+ ModuleName.getKernel moduleName
167+ else if Text.isInfixOf "." moduleName then
168+ error ("modules with dots in kernel code need an alias: " ++ show moduleName)
169+ else
170+ moduleName
171+
172+ toEntry name =
173+ ( shortName <> "_" <> name, ( moduleName, name ) )
174+ in
175+ Map.fromList $ map toEntry $
176+ case exposing of
177+ Src.Open ->
178+ error "cannot have open imports in kernel code"
179+
180+ Src.Explicit exposed ->
181+ map exposedToName exposed
182+
183+
184+exposedToName :: A.Located Src.Exposed -> N.Name
185+exposedToName (A.At _ exposed) =
186+ case exposed of
187+ Src.Lower name ->
188+ name
189+
190+ Src.Upper name Src.Private ->
191+ name
192+
193+ Src.Upper _ Src.Public ->
194+ error "cannot have Maybe(..) syntax in kernel code header"
195+
196+ Src.Operator _ ->
197+ error "cannot use binops in kernel code"