Skip to content

Commit 7fcb393

Browse files
leplep
committed
Doing everything in haskell
1 parent 1c75db0 commit 7fcb393

27 files changed

+689
-137
lines changed

‎Compiler/Natives.hs

+241
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,241 @@
1+
{-# LANGUAGE GADTs #-}
2+
3+
module Compiler.Natives where
4+
5+
import Data.Map (Map)
6+
import qualified Data.Map as Map
7+
8+
import Data.Set (Set)
9+
import qualified Data.Set as Set
10+
11+
import Data.Maybe
12+
import Data.List
13+
14+
import Control.Arrow ((&&&))
15+
import Control.Monad
16+
import Control.Exception
17+
18+
import System.Environment
19+
import System.FilePath
20+
import System.IO
21+
22+
import Text.Megaparsec
23+
24+
import Jass.Ast hiding (fmap)
25+
import Jass.Parser
26+
import Jass.Printer
27+
28+
import qualified Data.ByteString.Builder as Builder
29+
30+
import Data.MonoidMap (MonoidMap)
31+
import qualified Data.MonoidMap as MM
32+
33+
binsearch :: String -> [ Ast String Stmt ] -> Ast String Stmt
34+
binsearch n = go . zip [1..]
35+
where
36+
go :: [ (Int, Ast String Stmt) ] -> Ast String Stmt
37+
go [(_, stmt)] = stmt
38+
go xs =
39+
let (lhs, rhs@((idx,_):_)) = splitAt (length xs `div` 2) xs
40+
in If (Call "<" [ v, Int $ show idx])
41+
[ go lhs ]
42+
[]
43+
(Just [ go rhs ] )
44+
45+
v = Var $ SVar n
46+
47+
parseFromFile p file = runParser p file . (++"\n") <$> readFile file
48+
49+
getName :: Ast v Toplevel -> v
50+
getName (Native _ name _ _) = name
51+
52+
isNative :: Ast v Toplevel -> Bool
53+
isNative Native{} = True
54+
isNative _ = False
55+
56+
isTypedef :: Ast v Toplevel -> Bool
57+
isTypedef Typedef{} = True
58+
isTypedef _ = False
59+
60+
basicConverters :: Map String ([Ast String Expr] -> Ast String Expr)
61+
basicConverters = Map.map Call $ Map.fromList
62+
[ ("integer", "Value#_2int"), ("real", "Value#_2real")
63+
, ("boolean", "Value#_2boolean"), ("string", "Value#_2string")
64+
]
65+
66+
varOfType :: String -> String
67+
varOfType ty = "_value2" <> ty
68+
69+
extractJassValue :: Int -> (String, String) -> Ast String Expr
70+
extractJassValue idx (ty, _) =
71+
let var = Var $ SVar $ "arg" <> show idx
72+
functionName = Map.findWithDefault ( convert2 ty) ty basicConverters
73+
in functionName [ var, Var $ SVar "interpreter" ]
74+
75+
convert2 :: String -> [ Ast String Expr] -> Ast String Expr
76+
convert2 ty = Call $ "_convert2" <> ty
77+
78+
79+
basicSetter :: Map String (Ast String Expr -> Ast String x)
80+
basicSetter = Map.fromList
81+
[ ("integer", Call "Value#_litint" . pure )
82+
, ("real", Call "Value#_litfloat" . pure )
83+
, ("string", Call "Value#_litstring" . pure )
84+
, ("boolean", Call "Value#_litbool" . pure )
85+
]
86+
87+
88+
-- TODO: cleanup
89+
-- TODO: upcasting (numbers/handles)
90+
mkWrapper :: Ast String Toplevel -> Ast String Toplevel
91+
mkWrapper (Native _ name args ret) =
92+
Function Normal name' args' "nothing" $
93+
local_value:return_table:argLocals ++ call'
94+
where
95+
name' = '_':name
96+
args' = [("integer", "tbl"), ("integer", "ctx"), ("integer", "interpreter")]
97+
argLocals = zipWith toLocal [1..] args
98+
99+
call :: Ast String x
100+
call = Call name $ zipWith extractJassValue [1..] args
101+
102+
call' =
103+
case ret of
104+
"nothing" -> [ call ]
105+
ty | Just setter <- Map.lookup ty basicSetter ->
106+
[ Call "Table#_set" [ Var $ AVar "Value#_Int" (Var $ SVar "r"), Int "1", setter call] ]
107+
_ ->
108+
[ Set (SVar "v") $ Call "Value#_foreign" [ Var $ SVar $ "Jass#_" <> ret ]
109+
, Set (AVar (varOfType ret) (Var $ SVar "v")) call
110+
, Call "Table#_set" [ Var $ AVar "Value#_Int" (Var $ SVar "r"), Int "1", Var $ SVar "v" ]
111+
]
112+
113+
return_table :: Ast String Stmt
114+
return_table =
115+
let init = Just $ Call "Table#_get" [ Var $ SVar "tbl", Int "0" ]
116+
in Local $ SDef Normal "r" "integer" init
117+
118+
local_value :: Ast String Stmt
119+
local_value = Local $ SDef Normal "v" "integer" Nothing
120+
121+
toLocal :: Int -> w -> Ast String Stmt
122+
toLocal idx _ =
123+
let tbl_call = Call "Table#_get" [ tbl_arg, idx_arg ]
124+
tbl_arg = Var $ SVar "tbl"
125+
idx_arg = Int $ show idx
126+
in Local $ SDef Normal ("arg"<>show idx) "integer" $ Just tbl_call
127+
128+
129+
mkGlobal :: String -> Ast String Toplevel
130+
mkGlobal ty = Global $ ADef (varOfType ty) ty
131+
132+
getBothTypes :: Ast x Toplevel -> Set String
133+
getBothTypes (Typedef a b) = Set.fromList [a, b]
134+
getBothTypes _ = mempty
135+
136+
mkConstant :: Int -> String -> Ast String Toplevel
137+
mkConstant idx ty =
138+
Global $ SDef Const ("_" <> ty) "integer" (Just $ Int $ show idx)
139+
140+
parent2children :: [ Ast x Toplevel ] -> MonoidMap String (Set String)
141+
parent2children = foldl' go mempty
142+
where
143+
go :: MonoidMap String (Set String) -> Ast x Toplevel -> MonoidMap String (Set String)
144+
go m (Typedef a b) = m <> MM.singleton b (Set.singleton a)
145+
go m _ = m
146+
147+
getAllChildren :: String -> MonoidMap String (Set String) -> [ String ]
148+
getAllChildren base m = do
149+
c <- Set.toList $ MM.lookup' base m
150+
c:getAllChildren c m
151+
152+
153+
154+
mkConvert :: MonoidMap String (Set String) -> String -> Ast String Toplevel
155+
mkConvert types "boolexpr" =
156+
Function Normal "_convert2boolexpr" [("integer", "v"), ("integer", "interpreter")] "boolexpr"
157+
[ Set (SVar "Builtin::Boolexpr#_v") $ Var $ SVar "v"
158+
, Set (SVar "Builtin::Boolexpr#_i") $ Var $ SVar "interpreter"
159+
, Set (SVar "Builtin::Boolexpr#_r") $ Call "Value#_table" []
160+
, Return . Just . Var $ SVar "Builtin::Boolexpr#_filter"
161+
]
162+
mkConvert types ty =
163+
Function Normal ("_convert2" <> ty) [("integer", "v"), ("integer", "interpreter")] ty body
164+
where
165+
body = locals ++ mkCheckAndReturn ty
166+
locals =
167+
[ Local $ SDef Normal "lua_type" "integer" $ Just $ Var $ AVar "Value#_Type" v
168+
, Local $ SDef Normal "jass_type" "integer" $ Just $ Call "Value#_getJassType" [ v ]
169+
]
170+
171+
v = Var $ SVar "v"
172+
jass_type = Var $ SVar "jass_type"
173+
174+
mkCheckAndReturn target_type = foldl' go errorCase $ target_type:getAllChildren target_type types
175+
where
176+
177+
go :: [ Ast String Stmt ] -> String -> [ Ast String Stmt ]
178+
go elseBlock ty = pure $
179+
If cond
180+
[ Return $ Just $ Var $ AVar ( "_value2" <> ty ) v ]
181+
[] $
182+
Just elseBlock
183+
where
184+
cond = Call "==" [ jass_type, Var $ SVar $ "Jass#_" <> ty ]
185+
186+
errorCase :: [ Ast String Stmt ]
187+
errorCase = [ Call "Value#_error_str" [String $ "Value not of type " <> ty ], Return $ Just Null ]
188+
189+
mkDispatch :: [String] -> [String] -> Ast String Toplevel
190+
mkDispatch autogenerated custom =
191+
let autogenerated' = map ("Natives#_" <>) autogenerated
192+
calls = map mkCall $ autogenerated' <> custom
193+
switch = binsearch "fn" calls
194+
in Function Normal "_dispatch" [("integer", "fn"), ("integer", "tbl"), ("integer", "ctx"), ("integer", "interpreter")] "nothing"
195+
[ switch ]
196+
where
197+
mkCall name = Call name [ Var $ SVar "tbl", Var $ SVar "ctx", Var $ SVar "interpreter" ]
198+
199+
mkRegister :: [String] -> Ast String Toplevel
200+
mkRegister names =
201+
Function Normal "_register" [("integer", "ctx")] "nothing"
202+
body
203+
where
204+
body = zipWith mkStmt [1..] names
205+
mkStmt idx name =
206+
Call "Context#_set" [ Var $ SVar "ctx", String name,
207+
Call "Value#_builtin" [ Int $ show idx, String name ] ]
208+
209+
210+
compile :: Map String String -> Ast String Programm -> [((String, Set String), Ast String Programm)]
211+
compile extraFunctions (Programm ts) =
212+
let natives = filter ((`Set.notMember` skip) . getName) $ filter isNative ts
213+
allTypes = Set.unions $ map getBothTypes ts
214+
allTypes' = allTypes <> Set.fromList [ "integer", "real", "string", "boolean" ]
215+
wrappers = map mkWrapper natives
216+
globals = map mkGlobal $ Set.toList allTypes
217+
218+
skip = Map.keysSet extraFunctions
219+
(from, to) = unzip $ Map.toList extraFunctions
220+
221+
converters = map (mkConvert $ parent2children ts) $ Set.toList allTypes
222+
223+
dispatch = mkDispatch (map getName natives) to
224+
register = mkRegister $ map getName natives ++ from
225+
226+
nativeAst = Programm $ globals ++ converters ++ wrappers
227+
jassAst = Programm $ zipWith mkConstant [1..] $ Set.toList allTypes'
228+
229+
230+
dispatchAst = Programm [ dispatch, register ]
231+
in [ (("Dispatch", dispatchDeps), dispatchAst)
232+
, (("Jass", jassDeps), jassAst)
233+
, (("Natives", nativeDeps), nativeAst)
234+
]
235+
where
236+
dispatchDeps = Set.fromList
237+
[ "Builtins", "Builtin::Coroutine", "Builtin::Trigger"
238+
, "Builtin::Timer", "Builtin::Boolexpr", "Builtin::Math"
239+
, "Builtin::Table", "Value", "Context", "Natives" ]
240+
jassDeps = Set.empty
241+
nativeDeps = Set.fromList [ "Table", "Value", "Jass" ]

‎Compiler/Preprocess.hs

+115
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,115 @@
1+
{-# LANGUAGE LambdaCase #-}
2+
{-# LANGUAGE GADTs #-}
3+
{-# LANGUAGE TemplateHaskell #-}
4+
5+
module Compiler.Preprocess where
6+
7+
import qualified Jass.Parser as Jass
8+
import qualified Jass.Ast as Jass
9+
import qualified Jass.Printer as Jass
10+
import Data.Composeable
11+
12+
import Data.Void
13+
14+
import Text.Megaparsec
15+
import Text.Megaparsec.Char
16+
17+
import System.Environment
18+
import System.IO
19+
20+
import Data.Set (Set)
21+
import qualified Data.Set as Set
22+
23+
import Control.Monad
24+
25+
import Data.FileEmbed
26+
27+
import Debug.Trace
28+
29+
type Parser = Parsec Void String
30+
31+
flattenModuleName = map (\case ':' -> '_'; x -> x)
32+
33+
lname2jname :: String -> String -> (String, Maybe String) -> String
34+
lname2jname globalPrefix modulePrefix (nameOrModule, realName) =
35+
case realName of
36+
Nothing -> potentiallyAddPrefix nameOrModule
37+
Just name -> addPrefix (flattenModuleName nameOrModule) <> name
38+
39+
where
40+
addPrefix = (globalPrefix <> )
41+
potentiallyAddPrefix = \case
42+
xs@('_':_) -> globalPrefix <> modulePrefix <> xs
43+
x -> x
44+
45+
pName :: Parser (String, Maybe String)
46+
pName = do
47+
nameOrModule <- pModule
48+
realName <- optional $ char '#' *> ident
49+
pure (nameOrModule, realName)
50+
where
51+
ident = many $ alphaNumChar <|> char '_'
52+
53+
pModule = many (char ':' <|> char '_' <|> alphaNumChar )
54+
55+
pMetadata = do
56+
scope <- pScope
57+
requires <- pRequires
58+
pure (scope, requires)
59+
60+
pScope = string "// scope " *> pModule <* eol
61+
62+
pRequires = Set.fromList . concat <$> many pRequire
63+
pRequire = do
64+
string "// REQUIRES "
65+
requirements <- pModule `sepBy` hspace1
66+
eol
67+
pure requirements
68+
69+
bla :: String -> String -> String -> String
70+
bla globalPrefix modulePrefix name =
71+
let Right x = runParser pName name name
72+
in lname2jname globalPrefix modulePrefix x
73+
74+
75+
rename :: String -> String -> Jass.Ast String x -> Jass.Ast String x
76+
rename globalPrefix modulePrefix = rename' globalPrefix (flattenModuleName modulePrefix)
77+
78+
rename' :: String -> String -> Jass.Ast String x -> Jass.Ast String x
79+
rename' globalPrefix modulePrefix x =
80+
case x of
81+
Jass.Function co name args ret body ->
82+
Jass.Function co (t name) args ret $ map c body
83+
Jass.Call name args
84+
| not $ Jass.isOp name -> Jass.Call (t name) $ map (rename' globalPrefix modulePrefix) args
85+
Jass.Code name -> Jass.Code $ t name
86+
Jass.AVar name idx -> Jass.AVar (t name) (c idx)
87+
Jass.SVar name -> Jass.SVar $ t name
88+
Jass.ADef name ty -> Jass.ADef (t name) ty
89+
Jass.SDef co name ty init -> Jass.SDef co (t name) ty $ fmap c init
90+
_ -> composeOp (rename' globalPrefix modulePrefix) x
91+
where
92+
t = bla globalPrefix modulePrefix
93+
94+
c :: Jass.Ast String x -> Jass.Ast String x
95+
c = rename' globalPrefix modulePrefix
96+
97+
process :: String -> String -> Either (ParseErrorBundle String Void) ((String, Set String), Jass.Ast String Jass.Programm)
98+
process globalPrefix prog = do
99+
((scope, requirements), ast) <- runParser ((,) <$> pMetadata <*> Jass.programm) "" prog
100+
let ast' = rename globalPrefix scope ast
101+
let ast'' = addAlloc ast' scope requirements
102+
pure ((scope, Set.delete "Alloc" requirements), ast'')
103+
where
104+
addAlloc ast scope requirements
105+
| "Alloc" `Set.member` requirements = Jass.concat (alloc globalPrefix scope) ast
106+
| otherwise = ast
107+
108+
109+
allocFile :: String
110+
allocFile = $(embedStringFile "runtime/Alloc.j")
111+
112+
alloc :: String -> String -> Jass.Ast String Jass.Programm
113+
alloc globalPrefix modulePrefix =
114+
let Right ast = runParser Jass.programm "runtime/Alloc.j" allocFile
115+
in rename' globalPrefix modulePrefix ast

‎GNUmakefile

+4-1
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,4 @@
1-
RUNTIME := runtime/Ins.j runtime/Interpreter.j runtime/Table.j runtime/Value.j
1+
RUNTIME := runtime/Ins.j runtime/Interpreter.j runtime/Table.j runtime/Value.j
22
RUNTIME += runtime/Context.j runtime/StringTable.j runtime/List.j runtime/Print.j
33
RUNTIME += runtime/Types.j runtime/Builtins.j runtime/Wrap.j runtime/Call.j
44
RUNTIME += runtime/GC.j runtime/Deque.j runtime/Helper.j
@@ -17,6 +17,9 @@ OUT += $(patsubst auto/%, out/%, $(AUTO))
1717

1818
.PHONY: check clean
1919

20+
print-jorder:
21+
@echo $$(./jorder.sh $(RUNTIME) $(AUTO)) scaffold.j main.j
22+
2023
runtime.dot: $(RUNTIME) $(AUTO)
2124
bash jdigraph.sh $(RUNTIME) $(AUTO) > "$@"
2225

‎Jass/Ast.hs

+5-1
Original file line numberDiff line numberDiff line change
@@ -21,6 +21,7 @@ module Jass.Ast
2121
, s2i, s2r, rawcode2int
2222
, eliminateElseIfs
2323
, isGlobal, isLocal, isFunction, isOp
24+
, Jass.Ast.concat
2425
) where
2526

2627
import Prelude hiding (fmap, foldMap, traverse)
@@ -318,4 +319,7 @@ isFunction _ = False
318319
isOp x = x `elem` ["and", "or", "not"
319320
, "+", "-", "*", "/", "%"
320321
, "==", "!=", "<=", ">=", "<", ">"
321-
]
322+
]
323+
324+
concat :: Ast v Programm -> Ast v Programm -> Ast v Programm
325+
concat (Programm a) (Programm b) = Programm $ a <> b

0 commit comments

Comments
 (0)