@@ -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