git.iko.soy/elk
on master help sign in
Add Parse.Kernel that sets things up for code gen
f5bf4adEvan Czaplicki
elm-compiler.cabal+1
compare with master
unifiedsplit
@@ -109,6 +109,7 @@ Library
109 Parse.Declaration,
109 Parse.Declaration,
110 Parse.Expression,
110 Parse.Expression,
111 Parse.Helpers,
111 Parse.Helpers,
112+ Parse.Kernel,
112 Parse.Literal,
113 Parse.Literal,
113 Parse.Module,
114 Parse.Module,
114 Parse.Parse,
115 Parse.Parse,
src/Parse/Kernel.hsnew file+119
@@ -0,0 +1,119 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Parse.Kernel
4+ ( Chunk(..)
5+ , parse
6+ )
7+ where
8+
9+import qualified Data.Map as Map
10+import Data.Monoid ((<>))
11+import Data.Text (Text)
12+import qualified Data.Text as Text
13+
14+import qualified AST.Exposing as Exposing
15+import qualified AST.Module as Module
16+import qualified AST.Module.Name as Module
17+import Parse.Helpers (Parser)
18+import qualified Parse.Helpers as Parse
19+import qualified Parse.Module as Parse
20+import qualified Reporting.Annotation as A
21+
22+
23+
24+-- PARSE
25+
26+
27+data Chunk
28+ = JS Text
29+ | Var Module.Raw Text
30+
31+
32+parse :: Text -> ( [(Module.Raw, Text)], [Chunk] )
33+parse source =
34+ case Parse.run parser source of
35+ Left _ ->
36+ error "problem parsing kernel code"
37+
38+ Right answer ->
39+ answer
40+
41+
42+
43+-- PARSER
44+
45+
46+parser :: Parser ( [(Module.Raw, Text)], [Chunk] )
47+parser =
48+ do imports <- Parse.kernelHeader
49+ let table = Map.unions (map importToTable imports)
50+ chunks <- parserHelp table
51+ return ( Map.elems table, chunks )
52+
53+
54+parserHelp :: Table -> Parser [Chunk]
55+parserHelp table =
56+ do chunk <- Parse.kernelChunk
57+ case chunk of
58+ Left js ->
59+ return [JS js]
60+
61+ Right (js, var) ->
62+ case Map.lookup var table of
63+ Nothing ->
64+ error $ show $ "could not find " <> var <> " when parsing kernel code"
65+
66+ Just (home, name) ->
67+ do rest <- parserHelp table
68+ return (JS js : Var home name : rest)
69+
70+
71+
72+-- SYMBOL TABLE
73+
74+
75+type Table =
76+ Map.Map Text (Module.Raw, Text)
77+
78+
79+importToTable :: Module.UserImport -> Table
80+importToTable (A.A _ ( fullName, Module.ImportMethod maybeAlias exposed )) =
81+ let
82+ shortName =
83+ case maybeAlias of
84+ Just alias ->
85+ alias
86+
87+ Nothing ->
88+ if Module.isKernel fullName then
89+ Module.getKernel fullName
90+ else if Text.isInfixOf "." fullName then
91+ error ("modules with dots in kernel code need an alias: " ++ show fullName)
92+ else
93+ fullName
94+
95+ toEntry value =
96+ ( "__" <> shortName <> "_" <> value, ( fullName, value ) )
97+ in
98+ Map.fromList $ map toEntry $
99+ concatMap entryToValues $ getExplicits exposed
100+
101+
102+getExplicits :: Exposing.Exposing a -> [a]
103+getExplicits exposed =
104+ case exposed of
105+ Exposing.Open ->
106+ error "cannot have open imports in kernel code"
107+
108+ Exposing.Explicit entries ->
109+ map A.drop entries
110+
111+
112+entryToValues :: Exposing.Entry -> [Text]
113+entryToValues entry =
114+ case entry of
115+ Exposing.Lower name ->
116+ [name]
117+
118+ Exposing.Upper name ctors ->
119+ maybe [name] getExplicits ctors
src/Parse/Module.hs+11−1
@@ -1,7 +1,8 @@
1−{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
1+{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Parse.Module
3module Parse.Module
4 ( header
4 ( header
5+ , kernelHeader
5 )
6 )
6 where
7 where
7
8
@@ -25,6 +26,15 @@ header =
25 Module.Header <$> maybeHeaderDecl <*> chompImports []
26 Module.Header <$> maybeHeaderDecl <*> chompImports []
26
27
27
28
29+kernelHeader :: Parser [Module.UserImport]
30+kernelHeader =
31+ do symbol "/*"
32+ freshLine
33+ imports <- chompImports []
34+ symbol "*/"
35+ return imports
36+
37+
28
38
29-- HEADER DECL
39-- HEADER DECL
30
40
src/Parse/Primitives.hs+61−1
@@ -15,6 +15,7 @@ module Parse.Primitives
15 , string, character
15 , string, character
16 , digit, number
16 , digit, number
17 , shaderSource, shaderFailure
17 , shaderSource, shaderFailure
18+ , kernelChunk
18 )
19 )
19 where
20 where
20
21
@@ -1297,4 +1298,63 @@ eatShader array offset length row col =
1297 eatShader array (offset + 1) (length - 1) row (col + 1)
1298 eatShader array (offset + 1) (length - 1) row (col + 1)
1298
1299
1299 else
1300 else
1300− eatShader array (offset + 2) (length - 2) row (col + 1)
1301+ eatShader array (offset + 2) (length - 2) row (col + 1)
1302+
1303+
1304+
1305+-- KERNEL CHOMP
1306+
1307+
1308+kernelChunk :: Parser (Either Text (Text, Text))
1309+kernelChunk =
1310+ Parser $ \(State array offset length indent row col ctx) cok _ _ _ ->
1311+ let
1312+ (# isAtUnderscores, newOffset, newLength, newRow, newCol #) =
1313+ kernelChunkHelp array offset length row col
1314+
1315+ javascript =
1316+ Text.Text array offset (newOffset - offset)
1317+ in
1318+ if not isAtUnderscores then
1319+
1320+ let
1321+ !newState =
1322+ State array newOffset newLength indent newRow newCol ctx
1323+ in
1324+ cok (Left javascript) newState noError
1325+
1326+ else
1327+
1328+ let
1329+ (# newerOffset, newerLength, newerCol #) =
1330+ varPrimHelp array newOffset newLength newCol
1331+
1332+ !newState =
1333+ State array newerOffset newerLength indent newRow newerCol ctx
1334+
1335+ !kernelSymbol =
1336+ Text.Text array newOffset (newerOffset - newOffset)
1337+ in
1338+ cok (Right (javascript, kernelSymbol)) newState noError
1339+
1340+
1341+kernelChunkHelp :: Text.Array -> Int -> Int -> Int -> Int -> (# Bool, Int, Int, Int, Int #)
1342+kernelChunkHelp array offset length row col =
1343+ if length < 2 then
1344+ (# False, offset, length, row, col #)
1345+
1346+ else
1347+ let
1348+ !word = Text.unsafeIndex array offset
1349+ in
1350+ if word == 0x005F {- _ -} && Text.unsafeIndex array (offset + 1) == 0x005F {- _ -} then
1351+ (# True, offset, length, row, col #)
1352+
1353+ else if word == 0x000A {- \n -} then
1354+ kernelChunkHelp array (offset + 1) (length - 1) (row + 1) 1
1355+
1356+ else if word < 0xD800 || word > 0xDBFF then
1357+ kernelChunkHelp array (offset + 1) (length - 1) row (col + 1)
1358+
1359+ else
1360+ kernelChunkHelp array (offset + 2) (length - 2) row (col + 1)