git.iko.soy/Idris-dev
on master help sign in
Extract java backend and dependencies to new repo
000bfa0Edwin Brady
idris.cabal+1−7
compare with master
unifiedsplit
@@ -655,17 +655,12 @@ Library
655 , IRTS.Bytecode
655 , IRTS.Bytecode
656 , IRTS.CodegenC
656 , IRTS.CodegenC
657 , IRTS.CodegenCommon
657 , IRTS.CodegenCommon
658− , IRTS.CodegenJava
659 , IRTS.CodegenJavaScript
658 , IRTS.CodegenJavaScript
660 , IRTS.JavaScript.AST
659 , IRTS.JavaScript.AST
661 , IRTS.Compiler
660 , IRTS.Compiler
662 , IRTS.Defunctionalise
661 , IRTS.Defunctionalise
663 , IRTS.DumpBC
662 , IRTS.DumpBC
664 , IRTS.Inliner
663 , IRTS.Inliner
665− , IRTS.Java.ASTBuilding
666− , IRTS.Java.JTypes
667− , IRTS.Java.Mangling
668− , IRTS.Java.Pom
669 , IRTS.Lang
664 , IRTS.Lang
670 , IRTS.LangOpts
665 , IRTS.LangOpts
671 , IRTS.Simplified
666 , IRTS.Simplified
@@ -674,10 +669,10 @@ Library
674 , Pkg.Package
669 , Pkg.Package
675 , Util.DynamicLinker
670 , Util.DynamicLinker
676 , Util.ScreenSize
671 , Util.ScreenSize
672+ , Util.System
677
673
678 Other-modules:
674 Other-modules:
679 Util.Pretty
675 Util.Pretty
680− , Util.System
681 , Util.Net
676 , Util.Net
682 , Util.Zlib
677 , Util.Zlib
683
678
@@ -703,7 +698,6 @@ Library
703 , filepath < 1.4
698 , filepath < 1.4
704 , fingertree >= 0.1 && < 0.2
699 , fingertree >= 0.1 && < 0.2
705 , haskeline >= 0.7 && < 0.8
700 , haskeline >= 0.7 && < 0.8
706− , language-java >= 0.2.7 && < 0.3
707 , lens >= 4.1.1 && < 4.5
701 , lens >= 4.1.1 && < 4.5
708 , mtl < 2.3
702 , mtl < 2.3
709 , network < 2.7
703 , network < 2.7
src/IRTS/CodegenJava.hsdeleted−757
@@ -1,757 +0,0 @@
1−{-# LANGUAGE PatternGuards #-}
2−module IRTS.CodegenJava (codegenJava) where
3−
4−import Idris.Core.TT hiding (mkApp)
5−import IRTS.CodegenCommon
6−import IRTS.Java.ASTBuilding
7−import IRTS.Java.JTypes
8−import IRTS.Java.Mangling
9−import IRTS.Java.Pom (pomString)
10−import IRTS.Lang
11−import IRTS.Simplified
12−import IRTS.System
13−import Util.System
14−
15−import Control.Applicative hiding (Const)
16−import Control.Arrow
17−import Control.Monad
18−import Control.Monad.Error
19−import qualified Control.Monad.Trans as T
20−import Control.Monad.Trans.State
21−import Data.List (foldl', isSuffixOf)
22−import qualified Data.Text as T
23−import qualified Data.Text.IO as TIO
24−import qualified Data.Vector.Unboxed as V
25−import Language.Java.Parser
26−import Language.Java.Pretty
27−import Language.Java.Syntax hiding (Name)
28−import qualified Language.Java.Syntax as J
29−import System.Directory
30−import System.Exit
31−import System.FilePath
32−import System.IO
33−import System.Process
34−
35−-----------------------------------------------------------------------
36−-- Main function
37−codegenJava :: CodeGenerator
38−codegenJava cg = codegenJava' [] (simpleDecls cg) (outputFile cg)
39− (includes cg) (compileLibs cg)
40− (outputType cg)
41−
42−codegenJava' :: [(Name, SExp)] -> -- initialization of globals
43− [(Name, SDecl)] -> -- decls
44− FilePath -> -- output file name
45− [String] -> -- headers
46− [String] -> -- libs
47− OutputType ->
48− IO ()
49−codegenJava' globalInit defs out hdrs libs exec =
50− withTgtDir exec out (codegenJava' exec)
51− where
52− codegenJava' :: OutputType -> FilePath -> IO ()
53− codegenJava' Raw tgtDir = do
54− srcDir <- prepareSrcDir exec tgtDir
55− generateJavaFile globalInit defs hdrs srcDir out
56− codegenJava' MavenProject tgtDir = do
57− codegenJava' Raw tgtDir
58− generatePom tgtDir out libs
59− codegenJava' Object tgtDir = do
60− codegenJava' MavenProject tgtDir
61− invokeMvn tgtDir "compile"
62− copyClassFiles tgtDir out
63− cleanUpTmp tgtDir
64− codegenJava' _ tgtDir = do
65− codegenJava' MavenProject tgtDir
66− invokeMvn tgtDir "package";
67− copyJar tgtDir out
68− makeJarExecutable out
69− cleanUpTmp tgtDir
70−
71−-----------------------------------------------------------------------
72−-- Compiler IO
73−
74−withTgtDir :: OutputType -> FilePath -> (FilePath -> IO ()) -> IO ()
75−withTgtDir Raw out action = action (dropFileName out)
76−withTgtDir MavenProject out action = createDirectoryIfMissing False out >> action out
77−withTgtDir _ out action = withTempdir (takeBaseName out) action
78−
79−prepareSrcDir :: OutputType -> FilePath -> IO FilePath
80−prepareSrcDir Raw tgtDir = return tgtDir
81−prepareSrcDir _ tgtDir = do
82− let srcDir = (tgtDir </> "src" </> "main" </> "java")
83− createDirectoryIfMissing True srcDir
84− return srcDir
85−
86−javaFileName :: FilePath -> FilePath -> FilePath
87−javaFileName srcDir out =
88− either error (\ (Ident clsName) -> srcDir </> clsName <.> "java") (mkClassName out)
89−
90−generateJavaFile :: [(Name, SExp)] -> -- initialization of globals
91− [(Name, SDecl)] -> -- definitions
92− [String] -> -- headers
93− FilePath -> -- Source dir
94− FilePath -> -- output target
95− IO ()
96−generateJavaFile globalInit defs hdrs srcDir out = do
97− let code = either error
98− (prettyPrint)-- flatIndent . prettyPrint)
99− (evalStateT (mkCompilationUnit globalInit defs hdrs out) mkCodeGenEnv)
100− writeFile (javaFileName srcDir out) code
101−
102−pomFileName :: FilePath -> FilePath
103−pomFileName tgtDir = tgtDir </> "pom.xml"
104−
105−generatePom :: FilePath -> -- tgt dir
106− FilePath -> -- output target
107− [String] -> -- libs
108− IO ()
109−generatePom tgtDir out libs = writeFile (pomFileName tgtDir) execPom
110− where
111− (Ident clsName) = either error id (mkClassName out)
112− execPom = pomString clsName (takeBaseName out) libs
113−
114−
115−invokeMvn :: FilePath -> String -> IO ()
116−invokeMvn tgtDir command = do
117− mvnCmd <- getMvn
118− let args = ["-f", pomFileName tgtDir]
119− (exit, mvout, err) <- readProcessWithExitCode mvnCmd (args ++ [command]) ""
120− when (exit /= ExitSuccess) $
121− error ("FAILURE: " ++ mvnCmd ++ " " ++ command ++ "\n" ++ err ++ mvout)
122−
123−classFileDir :: FilePath -> FilePath
124−classFileDir tgtDir = tgtDir </> "target" </> "classes"
125−
126−copyClassFiles :: FilePath -> FilePath -> IO ()
127−copyClassFiles tgtDir out = do
128− classFiles <- map (\ clsFile -> classFileDir tgtDir </> clsFile)
129− . filter ((".class" ==) . takeExtension)
130− <$> getDirectoryContents (classFileDir tgtDir)
131− mapM_ (\ clsFile -> copyFile clsFile (takeDirectory out </> takeFileName clsFile)) classFiles
132−
133−jarFileName :: FilePath -> FilePath -> FilePath
134−jarFileName tgtDir out = tgtDir </> "target" </> (takeBaseName out) <.> "jar"
135−
136−copyJar :: FilePath -> FilePath -> IO ()
137−copyJar tgtDir out =
138− copyFile (jarFileName tgtDir out) out
139−
140−makeJarExecutable :: FilePath -> IO ()
141−makeJarExecutable out = do
142− handle <- openBinaryFile out ReadMode
143− contents <- TIO.hGetContents handle
144− hClose handle
145− handle <- openBinaryFile out WriteMode
146− TIO.hPutStr handle (T.append (T.pack jarHeader) contents)
147− hFlush handle
148− hClose handle
149− perms <- getPermissions out
150− setPermissions out (setOwnerExecutable True perms)
151−
152−removePom :: FilePath -> IO ()
153−removePom tgtDir = removeFile (pomFileName tgtDir)
154−
155−cleanUpTmp :: FilePath -> IO ()
156−cleanUpTmp tgtDir = do
157− invokeMvn tgtDir "clean"
158− removePom tgtDir
159−
160−-----------------------------------------------------------------------
161−-- Jar and Pom infrastructure
162−
163−jarHeader :: String
164−jarHeader =
165− "#!/usr/bin/env sh\n"
166− ++ "MYSELF=`which \"$0\" 2>/dev/null`\n"
167− ++ "[ $? -gt 0 -a -f \"$0\" ] && MYSELF=\"./$0\"\n"
168− ++ "java=java\n"
169− ++ "if test -n \"$JAVA_HOME\"; then\n"
170− ++ " java=\"$JAVA_HOME/bin/java\"\n"
171− ++ "fi\n"
172− ++ "exec \"$java\" $java_args -jar $MYSELF \"$@\"\n"
173− ++ "exit 1\n"
174−
175−-----------------------------------------------------------------------
176−-- Code generation environment
177−
178−data CodeGenerationEnv
179− = CodeGenerationEnv
180− { globalVariables :: [(Name, ArrayIndex)]
181− , localVariables :: [[(Int, Ident)]]
182− , localVarCounter :: Int
183− }
184−
185−type CodeGeneration = StateT (CodeGenerationEnv) (Either String)
186−
187−mkCodeGenEnv :: CodeGenerationEnv
188−mkCodeGenEnv = CodeGenerationEnv [] [] 0
189−
190−varPos :: LVar -> CodeGeneration (Either ArrayIndex Ident)
191−varPos (Loc i) = do
192− vars <- (concat . localVariables) <$> get
193− case lookup i vars of
194− (Just varName) -> return (Right varName)
195− Nothing -> throwError $ "Invalid local variable id: " ++ show i
196−varPos (Glob name) = do
197− vars <- globalVariables <$> get
198− case lookup name vars of
199− (Just varIdx) -> return (Left varIdx)
200− Nothing -> throwError $ "Invalid global variable id: " ++ show name
201−
202−pushScope :: CodeGeneration ()
203−pushScope =
204− modify (\ env -> env { localVariables = []:(localVariables env) })
205−
206−popScope :: CodeGeneration ()
207−popScope = do
208− env <- get
209− let lVars = tail $ localVariables env
210− let vC = if null lVars then 0 else localVarCounter env
211− put $ env { localVariables = tail (localVariables env)
212− , localVarCounter = vC }
213−
214−setVariable :: LVar -> CodeGeneration (Either ArrayIndex Ident)
215−setVariable (Loc i) = do
216− env <- get
217− let lVars = localVariables env
218− let getter = localVar $ localVarCounter env
219− let lVars' = ((i, getter) : head lVars) : tail lVars
220− put $ env { localVariables = lVars'
221− , localVarCounter = 1 + localVarCounter env}
222− return (Right getter)
223−setVariable (Glob n) = do
224− env <- get
225− let gVars = globalVariables env
226− let getter = globalContext @! length gVars
227− let gVars' = (n, getter):gVars
228− put (env { globalVariables = gVars' })
229− return (Left getter)
230−
231−pushParams :: [Ident] -> CodeGeneration ()
232−pushParams paramNames =
233− let varMap = zipWith (flip (,)) paramNames [0..] in
234− modify (\ env -> env { localVariables = varMap:(localVariables env)
235− , localVarCounter = (length varMap) + (localVarCounter env) })
236−
237−flatIndent :: String -> String
238−flatIndent (' ' : ' ' : xs) = flatIndent xs
239−flatIndent (x:xs) = x:flatIndent xs
240−flatIndent [] = []
241−
242−-----------------------------------------------------------------------
243−-- Maintaining control structures over code blocks
244−
245−data BlockPostprocessor
246− = BlockPostprocessor
247− { ppInnerBlock :: [BlockStmt] -> Exp -> CodeGeneration [BlockStmt]
248− , ppOuterBlock :: [BlockStmt] -> CodeGeneration [BlockStmt]
249− }
250−
251−ppExp :: BlockPostprocessor -> Exp -> CodeGeneration [BlockStmt]
252−ppExp pp exp = ((ppInnerBlock pp) [] exp) >>= ppOuterBlock pp
253−
254−addReturn :: BlockPostprocessor
255−addReturn =
256− BlockPostprocessor
257− { ppInnerBlock = (\ block exp -> return $ block ++ [jReturn exp])
258− , ppOuterBlock = return
259− }
260−
261−ignoreResult :: BlockPostprocessor
262−ignoreResult =
263− BlockPostprocessor
264− { ppInnerBlock = (\ block exp -> return block)
265− , ppOuterBlock = return
266− }
267−
268−ignoreOuter :: BlockPostprocessor -> BlockPostprocessor
269−ignoreOuter pp = pp { ppOuterBlock = return }
270−
271−throwRuntimeException :: BlockPostprocessor -> BlockPostprocessor
272−throwRuntimeException pp =
273− pp
274− { ppInnerBlock =
275− (\ blk exp -> return $
276− blk ++ [ BlockStmt $ Throw
277− ( InstanceCreation
278− []
279− (toClassType runtimeExceptionType)
280− [exp]
281− Nothing
282− )
283− ]
284− )
285− }
286−
287−
288−rethrowAsRuntimeException :: BlockPostprocessor -> BlockPostprocessor
289−rethrowAsRuntimeException pp =
290− pp
291− { ppOuterBlock =
292− (\ blk -> do
293− ex <- ppInnerBlock (throwRuntimeException pp) [] (ExpName $ J.Name [Ident "ex"])
294− ppOuterBlock pp
295− $ [ BlockStmt $ Try
296− (Block blk)
297− [Catch (FormalParam [] exceptionType False (VarId (Ident "ex"))) $
298− Block ex
299− ]
300− Nothing
301− ]
302− )
303− }
304−
305−-----------------------------------------------------------------------
306−-- File structure
307−
308−mkCompilationUnit :: [(Name, SExp)] -> [(Name, SDecl)] -> [String] -> FilePath -> CodeGeneration CompilationUnit
309−mkCompilationUnit globalInit defs hdrs out = do
310− clsName <- mkClassName out
311− CompilationUnit Nothing ( [ ImportDecl False idrisRts True
312− , ImportDecl True idrisPrelude True
313− , ImportDecl False bigInteger False
314− , ImportDecl False runtimeException False
315− , ImportDecl False byteBuffer False
316− ] ++ otherHdrs
317− )
318− <$> mkTypeDecl clsName globalInit defs
319− where
320− idrisRts = J.Name $ map Ident ["org", "idris", "rts"]
321− idrisPrelude = J.Name $ map Ident ["org", "idris", "rts", "Prelude"]
322− bigInteger = J.Name $ map Ident ["java", "math", "BigInteger"]
323− runtimeException = J.Name $ map Ident ["java", "lang", "RuntimeException"]
324− byteBuffer = J.Name $ map Ident ["java", "nio", "ByteBuffer"]
325− otherHdrs = map ( (\ name -> ImportDecl False name False)
326− . J.Name
327− . map (Ident . T.unpack)
328− . T.splitOn (T.pack ".")
329− . T.pack)
330− $ filter (not . isSuffixOf ".h") hdrs
331−
332−-----------------------------------------------------------------------
333−-- Main class
334−
335−mkTypeDecl :: Ident -> [(Name, SExp)] -> [(Name, SDecl)] -> CodeGeneration [TypeDecl]
336−mkTypeDecl name globalInit defs =
337− (\ body -> [ClassTypeDecl $ ClassDecl [ Public
338− , Annotation $ SingleElementAnnotation
339− (jName "SuppressWarnings")
340− (EVVal . InitExp $ jString "unchecked")
341− ]
342− name
343− []
344− Nothing
345− []
346− body])
347− <$> mkClassBody globalInit (map (second (prefixCallNamespaces name)) defs)
348−
349−mkClassBody :: [(Name, SExp)] -> [(Name, SDecl)] -> CodeGeneration ClassBody
350−mkClassBody globalInit defs =
351− (\ globals defs -> ClassBody . (globals++) . addMainMethod . mergeInnerClasses $ defs)
352− <$> mkGlobalContext globalInit
353− <*> mapM mkDecl defs
354−
355−mkGlobalContext :: [(Name, SExp)] -> CodeGeneration [Decl]
356−mkGlobalContext [] = return []
357−mkGlobalContext initExps = do
358− pushScope
359− varInit <-
360− mapM (\ (name, exp) -> do
361− pos <- setVariable (Glob name)
362− mkUpdate ignoreResult (Glob name) exp
363− ) initExps
364− popScope
365− return [ MemberDecl $ FieldDecl [Private, Static, Final]
366− (array objectType)
367− [ VarDecl (VarId $ globalContextID). Just . InitExp
368− $ ArrayCreate objectType [jInt $ length initExps] 0
369− ]
370− , InitDecl True (Block $ concat varInit)
371− ]
372−
373−addMainMethod :: [Decl] -> [Decl]
374−addMainMethod decls
375− | findMainMethod decls = mkMainMethod : decls
376− | otherwise = decls
377− where
378− findMainMethod ((MemberDecl (MethodDecl _ _ _ name [] _ _)):_)
379− | name == mangle' (sMN 0 "runMain") = True
380− findMainMethod (_:decls) = findMainMethod decls
381− findMainMethod [] = False
382−
383−mkMainMethod :: Decl
384−mkMainMethod =
385− simpleMethod
386− [Public, Static]
387− Nothing
388− "main"
389− [FormalParam [] (array stringType) False (VarId $ Ident "args")]
390− $ Block [ BlockStmt . ExpStmt
391− $ call "idris_initArgs" [ jConst "args" ]
392− , BlockStmt . ExpStmt $ call (mangle' (sMN 0 "runMain")) []
393− ]
394−
395−-----------------------------------------------------------------------
396−-- Inner classes (idris namespaces)
397−
398−mergeInnerClasses :: [Decl] -> [Decl]
399−mergeInnerClasses = foldl' mergeInner []
400− where
401− mergeInner ((decl@(MemberDecl (MemberClassDecl (ClassDecl priv name targs ext imp (ClassBody body))))):decls)
402− decl'@(MemberDecl (MemberClassDecl (ClassDecl _ name' _ ext' imp' (ClassBody body'))))
403− | name == name' =
404− (MemberDecl $ MemberClassDecl $
405− ClassDecl priv
406− name
407− targs
408− (mplus ext ext')
409− (imp ++ imp')
410− (ClassBody $ mergeInnerClasses (body ++ body')))
411− : decls
412− | otherwise = decl:(mergeInner decls decl')
413− mergeInner (decl:decls) decl' = decl:(mergeInner decls decl')
414− mergeInner [] decl' = [decl']
415−
416−
417−
418−mkDecl :: (Name, SDecl) -> CodeGeneration Decl
419−mkDecl ((NS n (ns:nss)), decl) =
420− (\ name body ->
421− MemberDecl $ MemberClassDecl $ ClassDecl [Public, Static] name [] Nothing [] body)
422− <$> mangle (UN ns)
423− <*> mkClassBody [] [(NS n nss, decl)]
424−mkDecl (_, SFun name params stackSize body) = do
425− (Ident methodName) <- mangle name
426− methodParams <- mapM mkFormalParam params
427− paramNames <- mapM mangle params
428− pushParams paramNames
429− methodBody <- mkExp addReturn body
430− popScope
431− return $
432− simpleMethod [Public, Static] (Just objectType) methodName methodParams
433− (Block methodBody)
434−
435−mkFormalParam :: Name -> CodeGeneration FormalParam
436−mkFormalParam name =
437− (\ name -> FormalParam [Final] objectType False (VarId name))
438− <$> mangle name
439−
440−-----------------------------------------------------------------------
441−-- Expressions
442−
443−-- | Compile a simple expression and use the given continuation to postprocess
444−-- the resulting value.
445−mkExp :: BlockPostprocessor -> SExp -> CodeGeneration [BlockStmt]
446−-- Variables
447−mkExp pp (SV var) =
448− (Nothing <>@! var) >>= ppExp pp
449−
450−-- Applications
451−mkExp pp (SApp pushTail name args) =
452− mkApp pushTail name args >>= ppExp pp
453−
454−-- Bindings
455−mkExp pp (SLet var newExp inExp) =
456− mkLet pp var newExp inExp
457−mkExp pp (SUpdate var@(Loc i) newExp) = -- can only update locals
458− mkUpdate pp var newExp
459−mkExp pp (SUpdate var newExp) =
460− mkExp pp newExp
461−
462−-- Objects
463−mkExp pp (SCon _ conId _ args) =
464− mkIdrisObject conId args >>= ppExp pp
465−
466−-- Case expressions
467−mkExp pp (SCase up var alts) = mkCase pp True var alts
468−mkExp pp (SChkCase var alts) = mkCase pp False var alts
469−
470−-- Projections
471−mkExp pp (SProj var i) =
472− mkProjection var i >>= ppExp pp
473−
474−-- Constants
475−mkExp pp (SConst c) =
476− ppExp pp $ mkConstant c
477−
478−-- Foreign function calls
479−mkExp pp (SForeign lang resTy text params) =
480− mkForeign pp lang resTy text params
481−
482−-- Primitive functions
483−mkExp pp (SOp LFork [arg]) =
484− (mkThread arg) >>= ppExp pp
485−mkExp pp (SOp LPar [arg]) =
486− (Nothing <>@! arg) >>= ppExp pp
487−mkExp pp (SOp LRegisterPtr [ptr, i]) =
488− (Nothing <>@! ptr) >>= ppExp pp
489−mkExp pp (SOp LNoOp args) =
490− (Nothing <>@! (last args)) >>= ppExp pp
491−mkExp pp (SOp LNullPtr args) =
492− ppExp pp $ Lit Null
493−mkExp pp (SOp op args) =
494− (mkPrimitiveFunction op args) >>= ppExp pp
495−
496−-- Empty expressions
497−mkExp pp (SNothing) = ppExp pp $ Lit Null
498−
499−-- Errors
500−mkExp pp (SError err) = ppExp (throwRuntimeException pp) (jString err)
501−
502−-----------------------------------------------------------------------
503−-- Variable access
504−
505−(<>@!) :: Maybe J.Type -> LVar -> CodeGeneration Exp
506−(<>@!) Nothing var =
507− either ArrayAccess (\ n -> ExpName $ J.Name [n]) <$> varPos var
508−(<>@!) (Just castTo) var =
509− (castTo <>) <$> (Nothing <>@! var)
510−
511−-----------------------------------------------------------------------
512−-- Application (wrap method calls in tail call closures)
513−
514−mkApp :: Bool -> Name -> [LVar] -> CodeGeneration Exp
515−mkApp False name args =
516− (\ methodName params ->
517− (idrisClosureType ~> "unwrapTailCall") [call methodName params]
518− )
519− <$> mangleFull name
520− <*> mapM (Nothing <>@!) args
521−mkApp True name args = mkMethodCallClosure name args
522−
523−mkMethodCallClosure :: Name -> [LVar] -> CodeGeneration Exp
524−mkMethodCallClosure name args =
525− (\ name args -> closure (call name args))
526− <$> mangleFull name
527− <*> mapM (Nothing <>@!) args
528−
529−-----------------------------------------------------------------------
530−-- Updates (change context array) and Let bindings (Update, execute)
531−
532−mkUpdate :: BlockPostprocessor -> LVar -> SExp -> CodeGeneration [BlockStmt]
533−mkUpdate pp var exp =
534− mkExp
535− ( pp
536− { ppInnerBlock =
537− (\ blk rhs -> do
538− pos <- setVariable var
539− vExp <- Nothing <>@! var
540− ppInnerBlock pp (blk ++ [pos @:= rhs]) vExp
541− )
542− }
543− ) exp
544−
545−mkLet :: BlockPostprocessor -> LVar -> SExp -> SExp -> CodeGeneration [BlockStmt]
546−mkLet pp var@(Loc pos) newExp inExp =
547− mkUpdate (pp { ppInnerBlock =
548− (\ blk _ -> do
549− inBlk <- mkExp pp inExp
550− return (blk ++ inBlk)
551− )
552− }
553− ) var newExp
554−mkLet _ (Glob _) _ _ = T.lift $ Left "Cannot let bind to global variable"
555−
556−-----------------------------------------------------------------------
557−-- Object creation
558−
559−mkIdrisObject :: Int -> [LVar] -> CodeGeneration Exp
560−mkIdrisObject conId args =
561− (\ args ->
562− InstanceCreation [] (toClassType idrisObjectType) ((jInt conId):args) Nothing
563− )
564− <$> mapM (Nothing <>@!) args
565−
566−-----------------------------------------------------------------------
567−-- Case expressions
568−
569−mkCase :: BlockPostprocessor -> Bool -> LVar -> [SAlt] -> CodeGeneration [BlockStmt]
570−mkCase pp checked var cases
571− | isDefaultOnlyCase cases = mkDefaultMatch pp cases
572− | isConstCase cases = do
573− ifte <- mkConstMatch (ignoreOuter pp) (\ pp -> mkDefaultMatch pp cases) var cases
574− ppOuterBlock pp [BlockStmt ifte]
575− | otherwise = do
576− switchExp <- mkGetConstructorId checked var
577− matchBlocks <- mkConsMatch (ignoreOuter pp) (\ pp -> mkDefaultMatch pp cases) var cases
578− ppOuterBlock pp [BlockStmt $ Switch switchExp matchBlocks]
579−
580−isConstCase :: [SAlt] -> Bool
581−isConstCase ((SConstCase _ _):_) = True
582−isConstCase ((SDefaultCase _):cases) = isConstCase cases
583−isConstCase _ = False
584−
585−isDefaultOnlyCase :: [SAlt] -> Bool
586−isDefaultOnlyCase [SDefaultCase _] = True
587−isDefaultOnlyCase [] = True
588−isDefaultOnlyCase _ = False
589−
590−mkDefaultMatch :: BlockPostprocessor -> [SAlt] -> CodeGeneration [BlockStmt]
591−mkDefaultMatch pp (x@(SDefaultCase branchExpression):_) =
592− do pushScope
593− stmt <- mkExp pp branchExpression
594− popScope
595− return stmt
596−mkDefaultMatch pp (x:xs) = mkDefaultMatch pp xs
597−mkDefaultMatch pp [] =
598− ppExp (throwRuntimeException pp) (jString "Non-exhaustive pattern")
599−
600−mkMatchConstExp :: LVar -> Const -> CodeGeneration Exp
601−mkMatchConstExp var c
602− | isPrimitive cty =
603− (\ var -> (primFnType ~> opName (LEq undefined)) [var, jc] ~==~ jInt 1)
604− <$> (Just cty <>@! var)
605− | isArray cty =
606− (\ var -> (arraysType ~> "equals") [var, jc])
607− <$> (Just cty <>@! var)
608− | isString cty =
609− (\ var -> ((primFnType ~> opName (LStrEq)) [var, jc] ~==~ jInt 1))
610− <$> (Just cty <>@! var)
611− | otherwise =
612− (\ var -> (var ~> "equals") [jc])
613− <$> (Just cty <>@! var)
614− where
615− cty = constType c
616− jc = mkConstant c
617−
618−mkConstMatch :: BlockPostprocessor ->
619− (BlockPostprocessor -> CodeGeneration [BlockStmt]) ->
620− LVar ->
621− [SAlt] ->
622− CodeGeneration Stmt
623−mkConstMatch pp getDefaultStmts var ((SConstCase constant branchExpression):cases) = do
624− matchExp <- mkMatchConstExp var constant
625− pushScope
626− branchBlock <- mkExp pp branchExpression
627− popScope
628− otherBranches <- mkConstMatch pp getDefaultStmts var cases
629− return
630− $ IfThenElse matchExp (StmtBlock $ Block branchBlock) otherBranches
631−mkConstMatch pp getDefaultStmts var (c:cases) = mkConstMatch pp getDefaultStmts var cases
632−mkConstMatch pp getDefaultStmts _ [] = do
633− defaultBlock <- getDefaultStmts pp
634− return $ StmtBlock (Block defaultBlock)
635−
636−mkGetConstructorId :: Bool -> LVar -> CodeGeneration Exp
637−mkGetConstructorId True var =
638− (\ var -> ((idrisObjectType <> var) ~> "getConstructorId") [])
639− <$> (Nothing <>@! var)
640−mkGetConstructorId False var =
641− (\ var match ->
642− Cond (InstanceOf var (toRefType idrisObjectType)) match (jInt (-1))
643− )
644− <$> (Nothing <>@! var)
645− <*> mkGetConstructorId True var
646−
647−mkConsMatch :: BlockPostprocessor ->
648− (BlockPostprocessor -> CodeGeneration [BlockStmt]) ->
649− LVar ->
650− [SAlt] ->
651− CodeGeneration [SwitchBlock]
652−mkConsMatch pp getDefaultStmts var ((SConCase parentStackPos consIndex _ params branchExpression):cases) = do
653− pushScope
654− caseBranch <- mkCaseBinding pp var parentStackPos params branchExpression
655− popScope
656− otherBranches <- mkConsMatch pp getDefaultStmts var cases
657− return $
658− (SwitchBlock (SwitchCase $ jInt consIndex) caseBranch):otherBranches
659−mkConsMatch pp getDefaultStmts var (c:cases) = mkConsMatch pp getDefaultStmts var cases
660−mkConsMatch pp getDefaultStmts _ [] = do
661− defaultBlock <- getDefaultStmts pp
662− return $
663− [SwitchBlock Default defaultBlock]
664−
665−mkCaseBinding :: BlockPostprocessor -> LVar -> Int -> [Name] -> SExp -> CodeGeneration [BlockStmt]
666−mkCaseBinding pp var stackStart params branchExpression =
667− mkExp pp (toLetIn var stackStart params branchExpression)
668− where
669− toLetIn :: LVar -> Int -> [Name] -> SExp -> SExp
670− toLetIn var stackStart members start =
671− foldr
672− (\ pos inExp -> SLet (Loc (stackStart + pos)) (SProj var pos) inExp)
673− start
674− [0.. (length members - 1)]
675−
676−-----------------------------------------------------------------------
677−-- Projection (retrieve the n-th field of an object)
678−
679−mkProjection :: LVar -> Int -> CodeGeneration Exp
680−mkProjection var memberNr =
681− (\ var -> ArrayAccess $ ((var ~> "getData") []) @! memberNr)
682− <$> (Just idrisObjectType <>@! var)
683−
684−-----------------------------------------------------------------------
685−-- Constants
686−
687−mkConstantArray :: (V.Unbox a) => J.Type -> (a -> Const) -> V.Vector a -> Exp
688−mkConstantArray cty elemToConst elems =
689− ArrayCreateInit
690− cty
691− 0
692− (ArrayInit . map (InitExp . mkConstant . elemToConst) $ V.toList elems)
693−
694−mkConstant :: Const -> Exp
695−mkConstant c@(I x) = constType c <> (Lit . Word $ toInteger x)
696−mkConstant c@(BI x) = bigInteger (show x)
697−mkConstant c@(Fl x) = constType c <> (Lit . Double $ x)
698−mkConstant c@(Ch x) = constType c <> (Lit . Char $ x)
699−mkConstant c@(Str x) = constType c <> (Lit . String $ x)
700−mkConstant c@(B8 x) = constType c <> (Lit . Word $ toInteger x)
701−mkConstant c@(B16 x) = constType c <> (Lit . Word $ toInteger x)
702−mkConstant c@(B32 x) = constType c <> (Lit . Word $ toInteger x)
703−mkConstant c@(B64 x) = (bigInteger (show c) ~> "longValue") []
704−mkConstant c@(B8V x) = mkConstantArray (constType c) B8 x
705−mkConstant c@(B16V x) = mkConstantArray (constType c) B16 x
706−mkConstant c@(B32V x) = mkConstantArray (constType c) B32 x
707−mkConstant c@(B64V x) = mkConstantArray (constType c) B64 x
708−mkConstant c@(AType x) = ClassLit (Just $ box (constType c))
709−mkConstant c@(StrType ) = ClassLit (Just $ stringType)
710−mkConstant c@(PtrType ) = ClassLit (Just $ objectType)
711−mkConstant c@(ManagedPtrType) = ClassLit (Just $ objectType)
712−mkConstant c@(BufferType) = ClassLit (Just $ bufferType)
713−mkConstant c@(VoidType ) = ClassLit (Just $ voidType)
714−mkConstant c@(Forgot ) = ClassLit (Just $ objectType)
715−
716−-----------------------------------------------------------------------
717−-- Foreign function calls
718−
719−mkForeign :: BlockPostprocessor -> FLang -> FType -> String -> [(FType, LVar)] -> CodeGeneration [BlockStmt]
720−mkForeign pp (LANG_C) resTy text params = mkForeign pp (LANG_JAVA FStatic) resTy text params
721−mkForeign pp (LANG_JAVA callType) resTy text params
722− | callType <- FStatic = do
723− method <- liftParsed (parser name text)
724− args <- foreignVarAccess params
725− wrapReturn resTy (call method args)
726− | callType <- FObject = do
727− method <- liftParsed (parser ident text)
728− (tgt:args) <- foreignVarAccess params
729− wrapReturn resTy ((tgt ~> (show $ pretty method)) args)
730− | callType <- FConstructor = do
731− clsTy <- liftParsed (parser classType text)
732− args <- foreignVarAccess params
733− wrapReturn resTy (InstanceCreation [] clsTy args Nothing)
734− where
735− foreignVarAccess args =
736− mapM (\ (fty, var) -> (foreignType fty <>@! var)) args
737−
738− pp' = rethrowAsRuntimeException pp
739−
740− wrapReturn FUnit exp =
741− ((ppInnerBlock pp') [BlockStmt $ ExpStmt exp] (Lit Null)) >>= ppOuterBlock pp'
742− wrapReturn _ exp =
743− ((ppInnerBlock pp') [] exp) >>= ppOuterBlock pp'
744−
745−-----------------------------------------------------------------------
746−-- Primitive functions
747−
748−mkPrimitiveFunction :: PrimFn -> [LVar] -> CodeGeneration Exp
749−mkPrimitiveFunction op args =
750− (\ args -> (primFnType ~> opName op) (endiannessArguments op ++ args))
751− <$> sequence (zipWith (\ a t -> (Just t) <>@! a) args (sourceTypes op))
752−
753−mkThread :: LVar -> CodeGeneration Exp
754−mkThread arg =
755− (\ closure -> (closure ~> "fork") []) <$> mkMethodCallClosure (sMN 0 "EVAL") [arg]
756−
757−
src/IRTS/Compiler.hs−2
@@ -8,7 +8,6 @@ import IRTS.Defunctionalise
8import IRTS.Simplified
8import IRTS.Simplified
9import IRTS.CodegenCommon
9import IRTS.CodegenCommon
10import IRTS.CodegenC
10import IRTS.CodegenC
11−import IRTS.CodegenJava
12import IRTS.DumpBC
11import IRTS.DumpBC
13import IRTS.CodegenJavaScript
12import IRTS.CodegenJavaScript
14import IRTS.Inliner
13import IRTS.Inliner
@@ -121,7 +120,6 @@ generate codegen mainmod ir
121 = case codegen of
120 = case codegen of
122 -- Built-in code generators (FIXME: lift these out!)
121 -- Built-in code generators (FIXME: lift these out!)
123 Via "c" -> codegenC ir
122 Via "c" -> codegenC ir
124− Via "java" -> codegenJava ir
125 -- Any external code generator
123 -- Any external code generator
126 Via cg -> do let cmd = "idris-" ++ cg ++ " " ++ mainmod ++
124 Via cg -> do let cmd = "idris-" ++ cg ++ " " ++ mainmod ++
127 " -o " ++ outputFile ir
125 " -o " ++ outputFile ir
src/IRTS/Java/ASTBuilding.hsdeleted−141
@@ -1,141 +0,0 @@
1−module IRTS.Java.ASTBuilding where
2−
3−import IRTS.Java.JTypes
4−
5−import Language.Java.Syntax hiding (Name)
6−import qualified Language.Java.Syntax as J
7−
8−toClassType :: J.Type -> ClassType
9−toClassType (RefType (ClassRefType ct)) = ct
10−toClassType t = error $ "Not a class type: " ++ (show t)
11−
12−toRefType :: J.Type -> RefType
13−toRefType (RefType rt) = rt
14−toRefType t = error $ "Not a ref type: " ++ (show t)
15−
16−class InvocationTarget a where
17− (~>) :: a -> String -> [Argument] -> Exp
18−
19−instance InvocationTarget ClassType where
20− (~>) (ClassType ts) method args =
21− MethodInv $ TypeMethodCall
22− (J.Name $ map fst ts)
23− (concatMap (map fromActType . snd) ts)
24− (Ident method)
25− args
26− where
27− fromActType (ActualType refType) = refType
28−
29−instance InvocationTarget Exp where
30− (~>) exp method args =
31− MethodInv $ PrimaryMethodCall
32− exp
33− []
34− (Ident method)
35− args
36−
37−instance InvocationTarget J.Type where
38− (~>) t method args = ((toClassType t) ~> method) args
39−
40−class Callable a where
41− call :: a -> [Argument] -> Exp
42−
43−instance Callable String where
44− call method args =
45− MethodInv $ MethodCall (J.Name [Ident method]) args
46−
47−instance Callable Ident where
48− call method args =
49− MethodInv $ MethodCall (J.Name [method]) args
50−
51−instance Callable J.Name where
52− call method args =
53− MethodInv $ MethodCall method args
54−
55−(<>) :: Type -> Exp -> Exp
56−(<>) = Cast
57−
58−localVar :: Int -> Ident
59−localVar i = Ident $ "loc" ++ show i
60−
61−(@!) :: Exp -> Int -> ArrayIndex
62−(@!) target pos =
63− ArrayIndex target [Lit $ Int (toInteger pos)]
64−
65−(@:=) :: Either ArrayIndex Ident -> Exp -> BlockStmt
66−(@:=) (Right lhs) rhs =
67− LocalVars [Final] objectType [VarDecl (VarId lhs) (Just $ InitExp rhs)]
68−(@:=) (Left lhs) rhs =
69− BlockStmt . ExpStmt $ Assign (ArrayLhs lhs) EqualA rhs
70−
71−(~&&~) :: Exp -> Exp -> Exp
72−(~&&~) e1 e2 = BinOp e1 CAnd e2
73−
74−(~==~) :: Exp -> Exp -> Exp
75−(~==~) e1 e2 = BinOp e1 Equal e2
76−
77−addToBlock :: [BlockStmt] -> Exp -> [BlockStmt]
78−addToBlock blk exp = blk ++ [BlockStmt $ ExpStmt exp]
79−
80−jName :: String -> J.Name
81−jName n = J.Name [Ident n]
82−
83−jConst :: String -> Exp
84−jConst = ExpName . jName
85−
86−jReturn :: Exp -> BlockStmt
87−jReturn = BlockStmt . Return . Just
88−
89−jInt :: Int -> Exp
90−jInt = Lit . Int . toInteger
91−
92−jString :: String -> Exp
93−jString = Lit . String
94−
95−simpleMethod :: [Modifier] -> Maybe J.Type -> String -> [FormalParam] -> Block -> Decl
96−simpleMethod mods t name params body =
97− MemberDecl $ MethodDecl
98− mods
99− []
100− t
101− (Ident $ name)
102− params
103− []
104− (MethodBody . Just $ body)
105−
106−declareFinalObjectArray :: Ident -> Maybe VarInit -> BlockStmt
107−declareFinalObjectArray name init =
108− LocalVars [Final]
109− (array objectType)
110− [ VarDecl
111− (VarDeclArray . VarId $ name)
112− init
113− ]
114−
115−arrayInitExps :: [Exp] -> VarInit
116−arrayInitExps = InitArray . ArrayInit . map (InitExp)
117−
118−extendWithNull :: [Exp] -> Int -> [Exp]
119−extendWithNull exps additionalZeros =
120− exps ++ (replicate additionalZeros (Lit $ Null))
121−
122−closure :: Exp -> Exp
123−closure body =
124− InstanceCreation
125− []
126− (toClassType idrisClosureType)
127− []
128− (Just $ ClassBody
129− [ simpleMethod
130− [Public, Final] (Just objectType) "call" []
131− (Block [jReturn body])
132− ]
133− )
134−
135−bigInteger :: String -> Exp
136−bigInteger s =
137− InstanceCreation
138− []
139− (toClassType bigIntegerType)
140− [Lit $ String s]
141− Nothing
src/IRTS/Java/JTypes.hsdeleted−331
@@ -1,331 +0,0 @@
1−{-# LANGUAGE PatternGuards #-}
2−module IRTS.Java.JTypes where
3−
4−import Idris.Core.TT
5−import IRTS.Lang
6−import Language.Java.Syntax
7−import qualified Language.Java.Syntax as J
8−
9−import qualified Data.Vector.Unboxed as V
10−
11−-----------------------------------------------------------------------
12−-- Primitive types
13−
14−charType :: J.Type
15−charType =
16− PrimType CharT
17−
18−byteType :: J.Type
19−byteType = PrimType ByteT
20−
21−shortType :: J.Type
22−shortType = PrimType ShortT
23−
24−integerType :: J.Type
25−integerType = PrimType IntT
26−
27−longType :: J.Type
28−longType = PrimType LongT
29−
30−doubleType :: J.Type
31−doubleType = PrimType DoubleT
32−
33−array :: J.Type -> J.Type
34−array t = RefType . ArrayType $ t
35−
36−addressType :: J.Type
37−addressType = longType
38−
39−-----------------------------------------------------------------------
40−-- Boxed types
41−
42−objectType :: J.Type
43−objectType =
44− RefType . ClassRefType $ ClassType [(Ident "Object", [])]
45−
46−bigIntegerType :: J.Type
47−bigIntegerType =
48− RefType . ClassRefType $ ClassType [(Ident "BigInteger", [])]
49−
50−stringType :: J.Type
51−stringType =
52− RefType . ClassRefType $ ClassType [(Ident "String", [])]
53−
54−bufferType :: J.Type
55−bufferType =
56− RefType . ClassRefType $ ClassType [(Ident "ByteBuffer", [])]
57−
58−threadType :: J.Type
59−threadType =
60− RefType . ClassRefType $ ClassType [(Ident "Thread", [])]
61−
62−callableType :: J.Type
63−callableType =
64− RefType . ClassRefType $ ClassType [(Ident "Callable", [])]
65−
66−voidType :: J.Type
67−voidType =
68− RefType . ClassRefType $ ClassType [(Ident "Void", [])]
69−
70−box :: J.Type -> J.Type
71−box (PrimType CharT ) = RefType . ClassRefType $ ClassType [(Ident "Character", [])]
72−box (PrimType ByteT ) = RefType . ClassRefType $ ClassType [(Ident "Byte", [])]
73−box (PrimType ShortT ) = RefType . ClassRefType $ ClassType [(Ident "Short", [])]
74−box (PrimType IntT ) = RefType . ClassRefType $ ClassType [(Ident "Integer", [])]
75−box (PrimType LongT ) = RefType . ClassRefType $ ClassType [(Ident "Long", [])]
76−box (PrimType DoubleT) = RefType . ClassRefType $ ClassType [(Ident "Double", [])]
77−box t = t
78−
79−isFloating :: J.Type -> Bool
80−isFloating (PrimType DoubleT) = True
81−isFloating (PrimType FloatT) = True
82−isFloating _ = False
83−
84−isPrimitive :: J.Type -> Bool
85−isPrimitive (PrimType _) = True
86−isPrimitive _ = False
87−
88−isArray :: J.Type -> Bool
89−isArray (RefType (ArrayType _)) = True
90−isArray _ = False
91−
92−isString :: J.Type -> Bool
93−isString (RefType (ClassRefType (ClassType [(Ident "String", _)]))) = True
94−isString _ = False
95−
96−-----------------------------------------------------------------------
97−-- Idris rts classes
98−
99−idrisClosureType :: J.Type
100−idrisClosureType =
101− RefType . ClassRefType $ ClassType [(Ident "Closure", [])]
102−
103−idrisTailCallClosureType :: J.Type
104−idrisTailCallClosureType =
105− RefType . ClassRefType $ ClassType [(Ident "TailCallClosure", [])]
106−
107−idrisObjectType :: J.Type
108−idrisObjectType =
109− RefType . ClassRefType $ ClassType [(Ident "IdrisObject", [])]
110−
111−foreignWrapperType :: J.Type
112−foreignWrapperType =
113− RefType . ClassRefType $ ClassType [(Ident "ForeignWrapper", [])]
114−
115−primFnType :: J.Type
116−primFnType =
117− RefType . ClassRefType $ ClassType [(Ident "PrimFn", [])]
118−
119−-----------------------------------------------------------------------
120−-- Java utility classes
121−
122−arraysType :: J.Type
123−arraysType =
124− RefType . ClassRefType $ ClassType [(Ident "Arrays", [])]
125−
126−mathType :: J.Type
127−mathType =
128− RefType . ClassRefType $ ClassType [(Ident "Math", [])]
129−
130−
131−-----------------------------------------------------------------------
132−-- Exception types
133−
134−exceptionType :: J.Type
135−exceptionType =
136− RefType . ClassRefType $ ClassType [(Ident "Exception", [])]
137−
138−runtimeExceptionType :: J.Type
139−runtimeExceptionType =
140− RefType . ClassRefType $ ClassType [(Ident "RuntimeException", [])]
141−
142−-----------------------------------------------------------------------
143−-- Integer types
144−
145−nativeTyToJType :: NativeTy -> J.Type
146−nativeTyToJType IT8 = byteType
147−nativeTyToJType IT16 = shortType
148−nativeTyToJType IT32 = integerType
149−nativeTyToJType IT64 = longType
150−
151−intTyToJType :: IntTy -> J.Type
152−intTyToJType (ITFixed nt) = nativeTyToJType nt
153−intTyToJType (ITNative) = integerType
154−intTyToJType (ITBig) = bigIntegerType
155−intTyToJType (ITChar) = charType
156−intTyToJType (ITVec nt _) = array $ nativeTyToJType nt
157−
158−arithTyToJType :: ArithTy -> J.Type
159−arithTyToJType (ATInt it) = intTyToJType it
160−arithTyToJType (ATFloat) = doubleType
161−
162−-----------------------------------------------------------------------
163−-- Context variables
164−
165−localContextID :: Ident
166−localContextID = Ident "context"
167−
168−localContext :: Exp
169−localContext = ExpName $ Name [localContextID]
170−
171−globalContextID :: Ident
172−globalContextID = Ident "globalContext"
173−
174−globalContext :: Exp
175−globalContext = ExpName $ Name [globalContextID]
176−
177−newContextID :: Ident
178−newContextID = Ident "new_context"
179−
180−newContext :: Exp
181−newContext = ExpName $ Name [newContextID]
182−
183−contextArray :: LVar -> Exp
184−contextArray (Loc _) = localContext
185−contextArray (Glob _) = globalContext
186−
187−contextParam :: FormalParam
188−contextParam = FormalParam [Final] (array objectType) False (VarId localContextID)
189−
190−-----------------------------------------------------------------------
191−-- Constant types
192−
193−constType :: Const -> J.Type
194−constType (I _) = arithTyToJType (ATInt ITNative)
195−constType (BI _) = arithTyToJType (ATInt ITBig )
196−constType (Fl _) = arithTyToJType (ATFloat )
197−constType (Ch _) = arithTyToJType (ATInt ITChar )
198−constType (Str _) = stringType
199−constType (B8 _) = arithTyToJType (ATInt $ ITFixed IT8 )
200−constType (B16 _) = arithTyToJType (ATInt $ ITFixed IT16)
201−constType (B32 _) = arithTyToJType (ATInt $ ITFixed IT32)
202−constType (B64 _) = arithTyToJType (ATInt $ ITFixed IT64)
203−constType (B8V v) = arithTyToJType (ATInt . ITVec IT8 $ V.length v)
204−constType (B16V v) = arithTyToJType (ATInt . ITVec IT16 $ V.length v)
205−constType (B32V v) = arithTyToJType (ATInt . ITVec IT32 $ V.length v)
206−constType (B64V v) = arithTyToJType (ATInt . ITVec IT64 $ V.length v)
207−constType _ = objectType
208−
209−-----------------------------------------------------------------------
210−-- Foreign types
211−
212−foreignType :: FType -> Maybe J.Type
213−foreignType (FArith at) = Just $ arithTyToJType at
214−foreignType (FFunction ) = Just $ callableType
215−foreignType (FFunctionIO ) = Just $ callableType
216−foreignType (FString ) = Just $ stringType
217−foreignType (FUnit ) = Nothing
218−foreignType (FPtr ) = Just $ objectType
219−foreignType (FAny ) = Just $ objectType
220−
221−-----------------------------------------------------------------------
222−-- Primitive operation analysis
223−
224−opName :: PrimFn -> String
225−opName x
226− | (LSExt _ to) <- x = "LSExt" ++ (suffixFor to)
227− | (LZExt _ to) <- x = "LZExt" ++ (suffixFor to)
228− | (LTrunc _ to) <- x = "LTrunc" ++ (suffixFor to)
229− | (LFloatInt to) <- x = "LFloatInt" ++ (suffixFor to)
230− | (LStrInt to) <- x = "LStrInt" ++ (suffixFor to)
231− | (LChInt to) <- x = "LChInt" ++ (suffixFor to)
232− | (LPeek to _) <- x = "LPeek" ++ (suffixFor to)
233− | otherwise = takeWhile ((/=) ' ') $ show x
234− where
235− suffixFor (ITFixed nt) = show nt
236− suffixFor (ITNative) = show IT32
237− suffixFor (ITBig) = show ITBig
238− suffixFor (ITChar) = show ITChar
239− suffixFor (ITVec nt _) = "ITVec" ++ (show $ nativeTyWidth nt)
240−
241−sourceTypes :: PrimFn -> [J.Type]
242−sourceTypes (LPlus from) = [arithTyToJType from, arithTyToJType from]
243−sourceTypes (LMinus from) = [arithTyToJType from, arithTyToJType from]
244−sourceTypes (LTimes from) = [arithTyToJType from, arithTyToJType from]
245−sourceTypes (LUDiv from) = [intTyToJType from, intTyToJType from]
246−sourceTypes (LSDiv from) = [arithTyToJType from, arithTyToJType from]
247−sourceTypes (LURem from) = [intTyToJType from, intTyToJType from]
248−sourceTypes (LSRem from) = [arithTyToJType from, arithTyToJType from]
249−sourceTypes (LAnd from) = [intTyToJType from, intTyToJType from]
250−sourceTypes (LOr from) = [intTyToJType from, intTyToJType from]
251−sourceTypes (LXOr from) = [intTyToJType from, intTyToJType from]
252−sourceTypes (LCompl from) = [intTyToJType from]
253−sourceTypes (LSHL from) = [intTyToJType from, intTyToJType from]
254−sourceTypes (LLSHR from) = [intTyToJType from, intTyToJType from]
255−sourceTypes (LASHR from) = [intTyToJType from, intTyToJType from]
256−sourceTypes (LEq from) = [arithTyToJType from, arithTyToJType from]
257−sourceTypes (LSLt from) = [arithTyToJType from, arithTyToJType from]
258−sourceTypes (LSLe from) = [arithTyToJType from, arithTyToJType from]
259−sourceTypes (LSGt from) = [arithTyToJType from, arithTyToJType from]
260−sourceTypes (LSGe from) = [arithTyToJType from, arithTyToJType from]
261−sourceTypes (LLt from) = [intTyToJType from, intTyToJType from]
262−sourceTypes (LLe from) = [intTyToJType from, intTyToJType from]
263−sourceTypes (LGt from) = [intTyToJType from, intTyToJType from]
264−sourceTypes (LGe from) = [intTyToJType from, intTyToJType from]
265−sourceTypes (LSExt from _) = [intTyToJType from]
266−sourceTypes (LZExt from _) = [intTyToJType from]
267−sourceTypes (LTrunc from _) = [intTyToJType from]
268−sourceTypes (LStrConcat) = repeat stringType
269−sourceTypes (LStrLt) = [stringType, stringType]
270−sourceTypes (LStrEq) = [stringType, stringType]
271−sourceTypes (LStrLen) = [stringType]
272−sourceTypes (LIntFloat from) = [intTyToJType from]
273−sourceTypes (LFloatInt _) = [doubleType]
274−sourceTypes (LIntStr from) = [intTyToJType from]
275−sourceTypes (LStrInt from) = [stringType]
276−sourceTypes (LFloatStr) = [doubleType]
277−sourceTypes (LStrFloat) = [stringType]
278−sourceTypes (LChInt _) = [charType]
279−sourceTypes (LIntCh from) = [intTyToJType from]
280−sourceTypes (LPrintNum) = [objectType]
281−sourceTypes (LPrintStr) = [stringType]
282−sourceTypes (LReadStr) = [objectType]
283−sourceTypes (LFExp) = [doubleType]
284−sourceTypes (LFLog) = [doubleType]
285−sourceTypes (LFSin) = [doubleType]
286−sourceTypes (LFCos) = [doubleType]
287−sourceTypes (LFTan) = [doubleType]
288−sourceTypes (LFASin) = [doubleType]
289−sourceTypes (LFACos) = [doubleType]
290−sourceTypes (LFATan) = [doubleType]
291−sourceTypes (LFSqrt) = [doubleType]
292−sourceTypes (LFFloor) = [doubleType]
293−sourceTypes (LFCeil) = [doubleType]
294−sourceTypes (LMkVec nt n) = replicate n (nativeTyToJType nt)
295−sourceTypes (LIdxVec nt _) = [array $ nativeTyToJType nt, integerType]
296−sourceTypes (LUpdateVec nt _) = [array $ nativeTyToJType nt, integerType, nativeTyToJType nt]
297−sourceTypes (LStrHead) = [stringType]
298−sourceTypes (LStrTail) = [stringType]
299−sourceTypes (LStrCons) = [charType, stringType]
300−sourceTypes (LStrIndex) = [stringType, integerType]
301−sourceTypes (LStrRev) = [stringType]
302−sourceTypes (LStdIn) = []
303−sourceTypes (LStdOut) = []
304−sourceTypes (LStdErr) = []
305−sourceTypes (LAllocate) = [addressType]
306−sourceTypes (LAppendBuffer) =
307− [bufferType, addressType, addressType, addressType, addressType, bufferType]
308−sourceTypes (LSystemInfo) = [integerType]
309−sourceTypes (LAppend nt _) = [bufferType, addressType, addressType, intTyToJType nt]
310−sourceTypes (LPeek _ _) = [bufferType, addressType]
311−sourceTypes (LFork) = [objectType]
312−sourceTypes (LPar) = [objectType]
313−sourceTypes (LVMPtr) = []
314−sourceTypes (LNullPtr) = [objectType]
315−sourceTypes (LNoOp) = repeat objectType
316−
317−-----------------------------------------------------------------------
318−-- Endianess markers
319−
320−endiannessConstant :: Endianness -> Exp
321−endiannessConstant c =
322− ExpName . Name . map Ident $ ["java", "nio", "ByteOrder", endiannessConstant' c]
323− where
324− endiannessConstant' BE = "BIG_ENDIAN"
325− endiannessConstant' LE = "LITTLE_ENDIAN"
326− endiannessConstant' (IRTS.Lang.Native) = endiannessConstant' BE
327−
328−endiannessArguments :: PrimFn -> [Exp]
329−endiannessArguments (LAppend _ end) = [endiannessConstant end]
330−endiannessArguments (LPeek _ end) = [endiannessConstant end]
331−endiannessArguments _ = []
src/IRTS/Java/Mangling.hsdeleted−116
@@ -1,116 +0,0 @@
1−{-# LANGUAGE FlexibleContexts #-}
2−{-# LANGUAGE MultiParamTypeClasses #-}
3−
4−module IRTS.Java.Mangling where
5−
6−import Idris.Core.TT
7−import IRTS.Lang
8−import IRTS.Simplified
9−
10−import Control.Applicative
11−import Control.Monad
12−import Control.Monad.Error
13−import Data.Char
14−
15−import Language.Java.Parser
16−import Language.Java.Pretty
17−import Language.Java.Syntax hiding (Name)
18−import qualified Language.Java.Syntax as J
19−
20−import System.FilePath
21−import Debug.Trace
22−
23−prefixCallNamespaces :: Ident -> SDecl -> SDecl
24−prefixCallNamespaces name (SFun fname args i e) =
25− SFun fname args i (prefixCallNamespacesExp name e)
26− where
27− prefixCallNamespacesExp :: Ident -> SExp -> SExp
28− prefixCallNamespacesExp (Ident name) (SApp tail (NS n ns) args) =
29− SApp tail (NS n (txt name:ns)) args
30− prefixCallNamespacesExp name (SLet var e1 e2) =
31− SLet var (prefixCallNamespacesExp name e1) (prefixCallNamespacesExp name e2)
32− prefixCallNamespacesExp name (SUpdate var e) =
33− SUpdate var (prefixCallNamespacesExp name e)
34− prefixCallNamespacesExp name (SCase up var alts) =
35− SCase up var (map (prefixCallNamespacesCase name) alts)
36− prefixCallNamespacesExp name (SChkCase var alts) =
37− SChkCase var (map (prefixCallNamespacesCase name) alts)
38− prefixCallNamespacesExp _ exp = exp
39−
40− prefixCallNamespacesCase :: Ident -> SAlt -> SAlt
41− prefixCallNamespacesCase name (SConCase x y n ns e) =
42− SConCase x y n ns (prefixCallNamespacesExp name e)
43− prefixCallNamespacesCase name (SConstCase c e) =
44− SConstCase c (prefixCallNamespacesExp name e)
45− prefixCallNamespacesCase name (SDefaultCase e) =
46− SDefaultCase (prefixCallNamespacesExp name e)
47−
48−liftParsed :: (Show e, MonadError String m) => Either e a -> m a
49−liftParsed = either (\ err -> throwError $ "Parser error: " ++ (show err))
50− (return)
51−
52−mkClassName :: (MonadError String m) => FilePath -> m Ident
53−mkClassName path =
54− liftParsed . parser ident . takeBaseName $ takeFileName path
55−
56−mangleWithPrefix :: (Applicative m, MonadError String m) => String -> Name -> m Ident
57−mangleWithPrefix prefix (NS name _) = mangleWithPrefix prefix name
58−mangleWithPrefix prefix (MN i name) =
59− (\ (Ident x) -> Ident $ x ++ ('_' : show i))
60− <$> mangleWithPrefix prefix (UN name)
61−mangleWithPrefix prefix (UN name) =
62− liftParsed
63− . parser ident
64− . (prefix ++)
65− . cleanNonLetter
66− $ cleanWs False (str name)
67− where
68− cleanNonLetter (x:xs)
69− | x == '#' = "_Hash" ++ cleanNonLetter xs
70− | x == '@' = "_At" ++ cleanNonLetter xs
71− | x == '$' = "_Dollar" ++ cleanNonLetter xs
72− | x == '!' = "_Bang" ++ cleanNonLetter xs
73− | x == '.' = "_Dot" ++ cleanNonLetter xs
74− | x == '\'' = "_Prime" ++ cleanNonLetter xs
75− | x == '*' = "_Times" ++ cleanNonLetter xs
76− | x == '+' = "_Plus" ++ cleanNonLetter xs
77− | x == '/' = "_Divide" ++ cleanNonLetter xs
78− | x == '-' = "_Minus" ++ cleanNonLetter xs
79− | x == '%' = "_Mod" ++ cleanNonLetter xs
80− | x == '<' = "_LessThan" ++ cleanNonLetter xs
81− | x == '=' = "_Equals" ++ cleanNonLetter xs
82− | x == '>' = "_MoreThan" ++ cleanNonLetter xs
83− | x == '[' = "_LSBrace" ++ cleanNonLetter xs
84− | x == ']' = "_RSBrace" ++ cleanNonLetter xs
85− | x == '(' = "_LBrace" ++ cleanNonLetter xs
86− | x == ')' = "_RBrace" ++ cleanNonLetter xs
87− | x == ':' = "_Colon" ++ cleanNonLetter xs
88− | x == ' ' = "_Space" ++ cleanNonLetter xs
89− | x == ',' = "_Comma" ++ cleanNonLetter xs
90− | x == '_' = "__" ++ cleanNonLetter xs
91− -- 10 digits is the most possible to represent 2^32 (ie all of unicode)
92− | not (isAlphaNum x) = "_" ++ (padToWith 10 '0' . show $ ord x) ++ cleanNonLetter xs
93− | otherwise = x:cleanNonLetter xs
94− cleanNonLetter [] = []
95− cleanWs capitalize (x:xs)
96− | isSpace x = cleanWs True xs
97− | capitalize = (toUpper x) : (cleanWs False xs)
98− | otherwise = x : (cleanWs False xs)
99− cleanWs _ [] = []
100− padToWith :: Int -> a -> [a] -> [a]
101− padToWith n p xs = replicate (length xs - n) p ++ xs
102−mangleWithPrefix prefix s@(SN _) = mangleWithPrefix prefix (sUN (showCG s))
103−
104−mangle :: (Applicative m, MonadError String m) => Name -> m Ident
105−mangle = mangleWithPrefix "__IDRCG__"
106−
107−mangle' :: Name -> Ident
108−mangle' = either error id . mangleWithPrefix "__IDRCG__"
109−
110−mangleFull :: (Applicative m, MonadError String m) => Name -> m J.Name
111−mangleFull (NS name (rootns:nss)) =
112− (\ r n ns -> J.Name (r:(ns ++ [n])))
113− <$> mangleWithPrefix "" (UN rootns)
114− <*> mangle name
115− <*> mapM (mangle . UN) nss
116−mangleFull n = J.Name . (:[]) <$> mangle n
src/IRTS/Java/Pom.hsdeleted−95
@@ -1,95 +0,0 @@
1−module IRTS.Java.Pom (pomString) where
2−
3−import Data.List (unfoldr)
4−import Text.XML.Light
5−
6−-----------------------------------------------------------------------
7−-- String <-> XML processing
8−
9−uattr :: String -> String -> Attr
10−uattr k v = Attr (QName k Nothing Nothing) v
11−
12−-- from http://stackoverflow.com/a/4978733/283260
13−splitOn :: Eq a => a -> [a] -> [[a]]
14−splitOn chr = unfoldr sep where
15− sep [] = Nothing
16− sep l = Just . fmap (drop 1) . break (==chr) $ l
17−
18−parseToDep :: String -> Element
19−parseToDep tuple =
20− case splitOn ':' tuple of
21− [g, a, v] -> dependency g a v
22− _ -> blank_element
23−
24−dependency :: String -> String -> String -> Element
25−dependency g a v = unode "dependency" (groupArtifactVersion g a v)
26−
27−groupArtifactVersion :: String -> String -> String -> [Element]
28−groupArtifactVersion g a v = [
29− unode "groupId" g,
30− unode "artifactId" a,
31− unode "version" v
32− ]
33−
34−pomString :: String -> String -> [String] -> String
35−pomString c a d = ppElement $ pom c a d
36−
37−-----------------------------------------------------------------------
38−-- The pom template for idris projects
39−
40−pom :: String -> String -> [String] -> Element
41−pom clsName artifactName dependencies = unode "project" ([
42− uattr "xmlns" "http://maven.apache.org/POM/4.0.0",
43− uattr "xmlns:xsi" "http://www.w3.org/2001/XMLSchema-instance",
44− uattr "xsi:schemaLocation" "http://maven.apache.org/POM/4.0.0 http://maven.apache.org/maven-v4_0_0.xsd"
45− ],
46− [
47− unode "modelVersion" "4.0.0",
48− unode "groupId" "org.idris-lang",
49− unode "artifactId" artifactName,
50− unode "packaging" "jar",
51− unode "version" "1.0",
52− unode "name" artifactName,
53− unode "properties" [
54− unode "project.build.sourceEncoding" "UTF-8",
55− unode "skipTest" "true"
56− ],
57− unode "dependencies" (
58− dependency "org.idris-lang" "idris" "0.9.14" :
59− map parseToDep dependencies
60− ),
61− unode "build" [
62− unode "finalName" artifactName,
63− unode "plugins" [
64− unode "plugin" (
65− unode "configuration" [
66− unode "source" "1.7",
67− unode "target" "1.7"
68− ] : groupArtifactVersion "org.apache.maven.plugins" "maven-compiler-plugin" "3.0"
69− ),
70− unode "plugin" (
71− unode "configuration" (
72− unode "skipTests" "${skipTests}"
73− ) : groupArtifactVersion "org.apache.maven.plugins" "maven-surefile-plugin" "2.14"
74− ),
75− unode "plugin" (
76− unode "executions" [
77− unode "execution" [
78− unode "phase" "package",
79− unode "goals" (
80− unode "goal" "shade"
81− ),
82− unode "configuration" (
83− unode "transformers" (
84− unode "transformer" (
85− uattr "implementation" "org.apache.maven.plugins.shade.resource.ManifestResourceTransformer",
86− unode "mainClass" clsName
87− )
88− )
89− )
90− ]
91− ] : groupArtifactVersion "org.apache.maven.plugins" "maven-shade-plugin" "2.1"
92− )
93− ]
94− ]
95− ])