git.iko.soy/elk
on c19392f help sign in
elk/src/Parse/Kernel.hs
183 lines 4.8 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Parse.Kernel
4 ( parser
5 )
6 where
9import qualified Data.ByteString as BS
10import qualified Data.Map as Map
11import Data.Monoid ((<>))
12import Data.Text (Text)
13import qualified Data.Text as Text
14import qualified Data.Text.Encoding as Text
15import Data.Word (Word8)
17import qualified AST.Expression.Source as Src
18import qualified AST.Kernel as Kernel
19import qualified AST.Module.Name as Module
20import qualified Elm.Name as N
21import Generate.JavaScript.Helpers as Help (toFieldName)
22import Generate.JavaScript.Variable as Var (intToAscii)
23import Parse.Primitives (Parser)
24import qualified Parse.Primitives.Kernel as K
25import qualified Parse.Primitives.Symbol as Symbol
26import qualified Parse.Module as Module
27import qualified Reporting.Annotation as A
31-- PARSER
34parser :: Parser Kernel.Content
35parser =
36 do Symbol.jsMultiCommentOpen
37 Module.freshLine
38 srcImports <- Module.chompImports []
39 Symbol.jsMultiCommentClose
40 let imports = Map.unions (map destructImport srcImports)
41 chunks <- parserHelp imports Map.empty Map.empty []
42 return (Kernel.Content (Map.elems imports) chunks)
45parserHelp :: Imports -> Enums -> Fields -> [Kernel.Chunk] -> Parser [Kernel.Chunk]
46parserHelp imports enums fields chunks =
47 do (javascript, maybeTag) <- K.chunk
48 case maybeTag of
49 Nothing ->
50 return (Kernel.JS javascript : chunks)
52 Just tag ->
53 case tag of
54 K.Prod ->
55 parserHelp imports enums fields (Kernel.Prod : Kernel.JS javascript : chunks)
57 K.Debug ->
58 parserHelp imports enums fields (Kernel.Debug : Kernel.JS javascript : chunks)
60 K.Import var ->
61 case Map.lookup var imports of
62 Nothing ->
63 error ("Bad kernel symbol: " ++ Text.unpack var)
65 Just (home, name) ->
66 parserHelp imports enums fields (Kernel.Var home name : Kernel.JS javascript : chunks)
68 K.Enum n var ->
69 let
70 (bytes, newEnums) =
71 lookupEnum n var enums
72 in
73 parserHelp imports newEnums fields (Kernel.JS bytes : Kernel.JS javascript : chunks)
75 K.ElmField name ->
76 parserHelp imports enums fields (Kernel.Field name : Kernel.JS javascript : chunks)
78 K.JsField name ->
79 let
80 (bytes, newFields) =
81 lookupField name fields
82 in
83 parserHelp imports enums newFields (Kernel.JS bytes : Kernel.JS javascript : chunks)
87-- FIELDS
90type Fields =
91 Map.Map Text BS.ByteString
94lookupField :: Text -> Fields -> (BS.ByteString, Fields)
95lookupField longName fields =
96 case Map.lookup longName fields of
97 Just bytes ->
98 ( bytes, fields )
100 Nothing ->
101 let
102 shortName =
103 Var.intToAscii (Map.size fields)
104 in
105 ( shortName, Map.insert longName shortName fields )
109-- ENUMS
112type Enums =
113 Map.Map Word8 (Map.Map Text BS.ByteString)
116lookupEnum :: Word8 -> Text -> Enums -> (BS.ByteString, Enums)
117lookupEnum word var allEnums =
118 let
119 enums =
120 Map.findWithDefault Map.empty word allEnums
121 in
122 case Map.lookup var enums of
123 Just bytes ->
124 ( bytes, allEnums )
126 Nothing ->
127 let
128 identifier =
129 Text.encodeUtf8 ("'" <> Help.toFieldName (Map.size enums) <> "'")
130 in
131 ( identifier, Map.insert word (Map.insert var identifier enums) allEnums )
135-- IMPORTS
138type Imports =
139 Map.Map Text (Module.Raw, Text)
142destructImport :: Src.Import -> Imports
143destructImport (Src.Import (A.A _ moduleName) maybeAlias exposing) =
144 let
145 shortName =
146 case maybeAlias of
147 Just alias ->
148 alias
150 Nothing ->
151 if Module.isKernel moduleName then
152 Module.getKernel moduleName
153 else if Text.isInfixOf "." moduleName then
154 error ("modules with dots in kernel code need an alias: " ++ show moduleName)
155 else
156 moduleName
158 toEntry name =
159 ( shortName <> "_" <> name, ( moduleName, name ) )
160 in
161 Map.fromList $ map toEntry $
162 case exposing of
163 Src.Open ->
164 error "cannot have open imports in kernel code"
166 Src.Explicit exposed ->
167 map exposedToName exposed
170exposedToName :: A.Located Src.Exposed -> N.Name
171exposedToName (A.A _ exposed) =
172 case exposed of
173 Src.Lower name ->
174 name
176 Src.Upper name Src.Private ->
177 name
179 Src.Upper _ Src.Public ->
180 error "cannot have Maybe(..) syntax in kernel code header"
182 Src.Operator _ ->
183 error "cannot use binops in kernel code"