git.iko.soy/Idris-dev
on 809683b help sign in
Idris-dev/src/IRTS/CodegenJava.hs
1661 lines 74 kB history raw
1module IRTS.CodegenJava (codegenJava) where
3import Core.TT
4import IRTS.BCImp
5import IRTS.CodegenCommon
6import IRTS.Lang
7import IRTS.Simplified
8import Paths_idris
9import Util.System
11import Control.Applicative
12import Control.Arrow
13import Control.Monad
14import qualified Control.Monad.Trans as T
15import Control.Monad.Trans.State
16import Data.Char
17import Data.Maybe (fromJust)
18import Data.List (isPrefixOf, isSuffixOf, intercalate)
19import qualified Data.Text as T
20import qualified Data.Text.IO as TIO
21import Language.Java.Parser
22import Language.Java.Pretty
23import Language.Java.Syntax hiding (Name)
24import qualified Language.Java.Syntax as J
25import System.Directory
26import System.Exit
27import System.FilePath
28import System.IO
29import System.Process
31data CodeGenerationEnv = CodeGenerationEnv { globalVariablePositions :: [(Name, Integer)] }
33type CodeGeneration = StateT (CodeGenerationEnv) (Either String)
35codegenJava :: [(Name, SExp)] -> -- initialization of globals
36 [(Name, SDecl)] ->
37 FilePath -> -- output file name
38 [String] -> -- headers
39 [String] -> -- libs
40 OutputType ->
41 IO ()
42codegenJava globalInit defs out hdrs libs exec = do
43 withTempdir (takeBaseName out) $ \ tmpDir -> do
44 let srcdir = tmpDir </> "src" </> "main" </> "java"
45 createDirectoryIfMissing True srcdir
46 let (Ident clsName) =
47 either error id (evalStateT (mkClassName out) (mkCodeGenEnv globalInit))
48 let outjava = srcdir </> clsName <.> "java"
49 let jout = either error
50 (flatIndent . prettyPrint)
51 (evalStateT (mkCompilationUnit globalInit defs hdrs out) (mkCodeGenEnv globalInit))
52 writeFile outjava jout
53 if (exec == Raw)
54 then copyFile outjava (takeDirectory out </> clsName <.> "java")
55 else do
56 execPom <- getExecutablePom
57 execPomTemplate <- TIO.readFile execPom
58 let execPom = T.replace (T.pack "$MAIN-CLASS$")
59 (T.pack clsName)
60 (T.replace (T.pack "$ARTIFACT-NAME$")
61 (T.pack $ takeBaseName out)
62 (T.replace (T.pack "$DEPENDENCIES$")
63 (mkPomDependencies libs)
64 execPomTemplate
65 )
66 )
67 TIO.writeFile (tmpDir </> "pom.xml") execPom
68 mvnCmd <- getMvn
69 let args = ["-f", (tmpDir </> "pom.xml")]
70 (exit, mvout, err) <- readProcessWithExitCode mvnCmd (args ++ ["compile"]) ""
71 when (exit /= ExitSuccess) $ error ("FAILURE: " ++ mvnCmd ++ " compile\n" ++ err ++ mvout)
72 if (exec == Object)
73 then do
74 classFiles <-
75 map (\ clsFile -> tmpDir </> "target" </> "classes" </> clsFile)
76 . filter ((".class" ==) . takeExtension)
77 <$> getDirectoryContents (tmpDir </> "target" </> "classes")
78 mapM_ (\ clsFile -> copyFile clsFile (takeDirectory out </> takeFileName clsFile))
79 classFiles
80 else do
81 (exit, mvout, err) <- readProcessWithExitCode mvnCmd (args ++ ["package"]) ""
82 when (exit /= ExitSuccess) (error ("FAILURE: " ++ mvnCmd ++ " package\n" ++ err ++ mvout))
83 copyFile (tmpDir </> "target" </> (takeBaseName out) <.> "jar") out
84 handle <- openBinaryFile out ReadMode
85 contents <- TIO.hGetContents handle
86 hClose handle
87 handle <- openBinaryFile out WriteMode
88 TIO.hPutStr handle (T.append (T.pack jarHeader) contents)
89 hFlush handle
90 hClose handle
91 perms <- getPermissions out
92 setPermissions out (setOwnerExecutable True perms)
93 readProcess mvnCmd (args ++ ["clean"]) ""
94 removeFile (tmpDir </> "pom.xml")
96jarHeader :: String
97jarHeader =
98 "#!/bin/sh\n"
99 ++ "MYSELF=`which \"$0\" 2>/dev/null`\n"
100 ++ "[ $? -gt 0 -a -f \"$0\" ] && MYSELF=\"./$0\"\n"
101 ++ "java=java\n"
102 ++ "if test -n \"$JAVA_HOME\"; then\n"
103 ++ " java=\"$JAVA_HOME/bin/java\"\n"
104 ++ "fi\n"
105 ++ "exec \"$java\" $java_args -jar $MYSELF \"$@\""
106 ++ "exit 1\n"
108mkPomDependencies :: [String] -> T.Text
109mkPomDependencies deps =
110 T.concat $ map (T.concat . map (T.append (T.pack " ")) . mkDependency . T.pack) deps
111 where
112 mkDependency s =
113 case T.splitOn (T.pack ":") s of
114 [g, a, v] ->
115 [ T.pack $ "<dependency>\n"
116 , T.append (T.pack " ") $ mkGroupId g
117 , T.append (T.pack " ") $ mkArtifactId a
118 , T.append (T.pack " ") $ mkVersion v
119 , T.pack $ "</dependency>\n"
120 ]
121 _ -> []
122 mkGroupId g = T.append (T.pack $ "<groupId>") (T.append g $ T.pack "</groupId>\n")
123 mkArtifactId a = T.append (T.pack $ "<artifactId>") (T.append a $ T.pack "</artifactId>\n")
124 mkVersion v = T.append (T.pack $ "<version>") (T.append v $ T.pack "</version>\n")
126mkCodeGenEnv :: [(Name, SExp)] -> CodeGenerationEnv
127mkCodeGenEnv globalInit =
128 CodeGenerationEnv $ zipWith (\ (name, _) pos -> (name, pos)) globalInit [0..]
130mkCompilationUnit :: [(Name, SExp)] -> [(Name, SDecl)] -> [String] -> FilePath -> CodeGeneration CompilationUnit
131mkCompilationUnit globalInit defs hdrs out =
132 CompilationUnit Nothing ( [ ImportDecl False idrisRts True
133 , ImportDecl True idrisForeign True
134 , ImportDecl False bigInteger False
135 , ImportDecl False stringBuffer False
136 , ImportDecl False runtimeException False
137 , ImportDecl False scanner False
138 , ImportDecl False arrays False
139 ] ++ otherHdrs
140 )
141 <$> mkTypeDecl globalInit defs out
142 where
143 idrisRts = J.Name $ map Ident ["org", "idris", "rts"]
144 idrisForeign = J.Name $ map Ident ["org", "idris", "rts", "ForeignPrimitives"]
145 bigInteger = J.Name $ map Ident ["java", "math", "BigInteger"]
146 stringBuffer = J.Name $ map Ident ["java", "lang", "StringBuffer"]
147 runtimeException = J.Name $ map Ident ["java", "lang", "RuntimeException"]
148 scanner = J.Name $ map Ident ["java", "util", "Scanner"]
149 arrays = J.Name $ map Ident ["java", "util", "Arrays"]
150 otherHdrs = map ( (\ name -> ImportDecl False name False)
151 . J.Name
152 . map (Ident . T.unpack)
153 . T.splitOn (T.pack ".")
154 . T.pack)
155 $ filter (not . isSuffixOf ".h") hdrs
157flatIndent :: String -> String
158flatIndent (' ' : ' ' : xs) = flatIndent xs
159flatIndent (x:xs) = x:flatIndent xs
160flatIndent [] = []
162prefixCallNamespaces :: Ident -> SExp -> SExp
163prefixCallNamespaces (Ident name) (SApp tail (NS n ns) args) = SApp tail (NS n (name:ns)) args
164prefixCallNamespaces name (SLet var e1 e2) = SLet var (prefixCallNamespaces name e1) (prefixCallNamespaces name e2)
165prefixCallNamespaces name (SUpdate var e) = SUpdate var (prefixCallNamespaces name e)
166prefixCallNamespaces name (SCase var alts) = SCase var (map (prefixCallNamespacesCase name) alts)
167prefixCallNamespaces name (SChkCase var alts) = SChkCase var (map (prefixCallNamespacesCase name) alts)
168prefixCallNamespaces _ exp = exp
170prefixCallNamespacesCase :: Ident -> SAlt -> SAlt
171prefixCallNamespacesCase name (SConCase x y n ns e) = SConCase x y n ns (prefixCallNamespaces name e)
172prefixCallNamespacesCase name (SConstCase c e) = SConstCase c (prefixCallNamespaces name e)
173prefixCallNamespacesCase name (SDefaultCase e) = SDefaultCase (prefixCallNamespaces name e)
175prefixCallNamespacesDecl :: Ident -> SDecl -> SDecl
176prefixCallNamespacesDecl name (SFun fname args i e) = SFun fname args i (prefixCallNamespaces name e)
178mkTypeDecl :: [(Name, SExp)] -> [(Name, SDecl)] -> FilePath -> CodeGeneration [TypeDecl]
179mkTypeDecl globalInit defs out =
180 (\ name body -> [ClassTypeDecl $ ClassDecl [ Public
181 , Annotation $ SingleElementAnnotation
182 (J.Name [Ident "SuppressWarnings"])
183 (EVVal . InitExp . Lit $ String "unchecked")
184 ]
185 name
186 []
187 Nothing
188 []
189 body])
190 <$> mkClassName out
191 <*> ( mkClassName out
192 >>= (\ ident -> mkClassBody globalInit (map (second (prefixCallNamespacesDecl ident)) defs))
193 )
195mkClassName :: FilePath -> CodeGeneration Ident
196mkClassName path =
197 T.lift $ left (\ err -> "Parser error in \"" ++ path ++ "\": " ++ (show err))
198 (parser ident . takeBaseName $ takeFileName path)
200mkClassBody :: [(Name, SExp)] -> [(Name, SDecl)] -> CodeGeneration ClassBody
201mkClassBody globalInit defs =
202 (\ globals defs -> ClassBody . (globals++) . addMainMethod . mergeInnerClasses $ defs)
203 <$> mkGlobalContext globalInit
204 <*> mapM mkDecl defs
206mkGlobalContext :: [(Name, SExp)] -> CodeGeneration [Decl]
207mkGlobalContext [] = return []
208mkGlobalContext initExps =
209 (\ exps -> [ MemberDecl $ FieldDecl [Private, Static, Final]
210 objectArrayType
211 [VarDecl (VarId $ Ident "globalContext")
212 (Just . InitArray $ ArrayInit exps)
213 ]
214 ]
215 )
216 <$> mapM (\ (_, exp) -> InitExp <$> mkExp exp) initExps
220addMainMethod :: [Decl] -> [Decl]
221addMainMethod decls
222 | findMain decls = mkMainMethod : decls
223 | otherwise = decls
224 where
225 findMain ((MemberDecl (MemberClassDecl (ClassDecl _ (Ident "Main") _ _ _ (ClassBody body)))):_) =
226 findMainMethod body
227 findMain (_:decls) = findMain decls
228 findMain [] = False
230 findMainMethod ((MemberDecl (MethodDecl _ _ _ (Ident "main") [] _ _)):_) = True
231 findMainMethod (_:decls) = findMainMethod decls
232 findMainMethod [] = False
234mkMainMethod :: Decl
235mkMainMethod =
236 MemberDecl $ MethodDecl [Public, Static]
237 []
238 Nothing
239 (Ident "main")
240 [FormalParam [] stringArrayType False (VarId $ Ident "args")]
241 []
242 (MethodBody . Just $ Block [ BlockStmt . ExpStmt . MethodInv $
243 MethodCall (J.Name [Ident "idris_initArgs"])
244 [ MethodInv $ TypeMethodCall
245 (J.Name [Ident "Thread"])
246 []
247 (Ident "currentThread")
248 []
249 , ExpName $ J.Name [Ident "args"]
250 ]
251 , BlockStmt . ExpStmt . MethodInv $
252 MethodCall (J.Name [Ident "runMain_0"])
253 []
254 ]
255 )
257mergeInnerClasses :: [Decl] -> [Decl]
258mergeInnerClasses = foldl mergeInner []
259 where
260 mergeInner ((decl@(MemberDecl (MemberClassDecl (ClassDecl priv name targs ext imp (ClassBody body))))):decls)
261 decl'@(MemberDecl (MemberClassDecl (ClassDecl _ name' _ ext' imp' (ClassBody body'))))
262 | name == name' =
263 (MemberDecl $ MemberClassDecl $
264 ClassDecl priv
265 name
266 targs
267 (mplus ext ext')
268 (imp ++ imp')
269 (ClassBody $ mergeInnerClasses (body ++ body')))
270 : decls
271 | otherwise = decl:(mergeInner decls decl')
272 mergeInner (decl:decls) decl' = decl:(mergeInner decls decl')
273 mergeInner [] decl' = [decl']
276mkIdentifier :: Name -> CodeGeneration Ident
277mkIdentifier (NS name _) = mkIdentifier name
278mkIdentifier (MN i name) = (\ (Ident x) -> Ident $ x ++ ('_' : show i))
279 <$> mkIdentifier (UN name)
280mkIdentifier (UN name) =
281 T.lift $ left (\ err -> "Parser error in \"" ++ name ++ "\": " ++ (show err))
282 ( parser ident
283 . cleanReserved
284 . cleanNonLetter
285 . cleanStart
286 $ cleanWs False name)
287 where
288 cleanStart (x:xs)
289 | isNumber x = '_' : (x:xs)
290 | otherwise = (x:xs)
291 cleanStart [] = []
292 cleanNonLetter (x:xs)
293 | x == '#' = "_Hash" ++ cleanNonLetter xs
294 | x == '@' = "_At" ++ cleanNonLetter xs
295 | x == '$' = "_Dollar" ++ cleanNonLetter xs
296 | x == '!' = "_Bang" ++ cleanNonLetter xs
297 | x == '.' = "_Dot" ++ cleanNonLetter xs
298 | x == '\'' = "_Prime" ++ cleanNonLetter xs
299 | x == '*' = "_Times" ++ cleanNonLetter xs
300 | x == '+' = "_Plus" ++ cleanNonLetter xs
301 | x == '/' = "_Divide" ++ cleanNonLetter xs
302 | x == '-' = "_Minus" ++ cleanNonLetter xs
303 | x == '%' = "_Mod" ++ cleanNonLetter xs
304 | x == '<' = "_LessThan" ++ cleanNonLetter xs
305 | x == '=' = "_Equals" ++ cleanNonLetter xs
306 | x == '>' = "_MoreThan" ++ cleanNonLetter xs
307 | x == '[' = "_LSBrace" ++ cleanNonLetter xs
308 | x == ']' = "_RSBrace" ++ cleanNonLetter xs
309 | x == '(' = "_LBrace" ++ cleanNonLetter xs
310 | x == ')' = "_RBrace" ++ cleanNonLetter xs
311 | x == '_' = "__" ++ cleanNonLetter xs
312 | not (isAlphaNum x) = "_" ++ (show $ ord x) ++ xs
313 | otherwise = x:cleanNonLetter xs
314 cleanNonLetter [] = []
315 cleanWs capitalize (x:xs)
316 | isSpace x = cleanWs True xs
317 | capitalize = (toUpper x) : (cleanWs False xs)
318 | otherwise = x : (cleanWs False xs)
319 cleanWs _ [] = []
322 cleanReserved "param" = "_param"
323 cleanReserved "globalContext" = "_globalContext"
324 cleanReserved "context" = "_context"
325 cleanReserved "newcontext" = "_newcontext"
327 cleanReserved "void" = "_void"
328 cleanReserved "null" = "_null"
329 cleanReserved "int" = "_int"
330 cleanReserved "long" = "_long"
331 cleanReserved "char" = "_char"
332 cleanReserved "byte" = "_byte"
333 cleanReserved "double" = "_double"
334 cleanReserved "float" = "_float"
335 cleanReserved "boolean" = "_boolean"
336 cleanReserved "Object" = "_Object"
337 cleanReserved "String" = "_String"
338 cleanReserved "StringBuilder" = "_StringBuilder"
339 cleanReserved "StringBuffer" = "_StringBuffer"
340 cleanReserved "Scanner" = "_Scanner"
341 cleanReserved "Integer" = "_Integer"
342 cleanReserved "Double" = "_Double"
343 cleanReserved "Byte" = "_Byte"
344 cleanReserved "Character" = "_Character"
345 cleanReserved "BigInteger" = "_BigInteger"
346 cleanReserved "Boolean" = "_Boolean"
347 cleanReserved "Closure" = "_Closure"
348 cleanReserved "IdrisObject" = "_IdrisObject"
349 cleanReserved "TailCallClosure" = "_TailCallClosure"
350 cleanReserved "System" = "_System"
351 cleanReserved "Math" = "_Math"
352 cleanReserved "Arrays" = "_Arrays"
353 cleanReserved "RuntimeException" = "_RuntimeException"
354 cleanReserved "Comparable" = "_Comparable"
356 cleanReserved "class" = "_class"
357 cleanReserved "enum" = "_enum"
358 cleanReserved "interface" = "_interface"
359 cleanReserved "extends" = "_extends"
360 cleanReserved "implements" = "_implements"
361 cleanReserved "public" = "_public"
362 cleanReserved "private" = "_private"
363 cleanReserved "protected" = "_protected"
364 cleanReserved "static" = "_static"
365 cleanReserved "final" = "_final"
366 cleanReserved "abstract" = "_abstract"
367 cleanReserved "strict" = "_strict"
368 cleanReserved "volatile" = "_volatile"
369 cleanReserved "transient" = "_transient"
370 cleanReserved "native" = "_native"
371 cleanReserved "const" = "_const"
373 cleanReserved "import" = "_import"
374 cleanReserved "package" = "_package"
376 cleanReserved "throw" = "_throw"
377 cleanReserved "throws" = "_throws"
378 cleanReserved "try" = "_try"
379 cleanReserved "catch" = "_catch"
381 cleanReserved "synchronized" = "_synchronized"
383 cleanReserved "if" = "_if"
384 cleanReserved "else" = "_else"
385 cleanReserved "switch" = "_switch"
386 cleanReserved "case" = "_case"
387 cleanReserved "default" = "_default"
389 cleanReserved "while" = "_while"
390 cleanReserved "for" = "_for"
391 cleanReserved "do" = "_do"
392 cleanReserved "break" = "_break"
393 cleanReserved "continue" = "_continue"
394 cleanReserved "goto" = "_goto"
396 cleanReserved "this" = "_this"
397 cleanReserved "super" = "_super"
398 cleanReserved "new" = "_new"
399 cleanReserved "return" = "_return"
401 cleanReserved "idris_initArgs" = "_idris_initArgs"
402 cleanReserved "idris_numArgs" = "_idris_numArgs"
403 cleanReserved "idris_getArg" = "_idris_getArg"
404 cleanReserved "getenv" = "_getenv"
405 cleanReserved "exit" = "_exit"
406 cleanReserved "usleep" = "_usleep"
407 cleanReserved "idris_sendMessage" = "_idris_sendMessage"
408 cleanReserved "idris_checkMessage" = "_idris_checkMessage"
409 cleanReserved "idris_recvMessage" = "_idris_recvMessage"
410 cleanReserved "putStr" = "_putStr"
411 cleanReserved "putchar" = "_putchar"
412 cleanReserved "getchar" = "_getchar"
413 cleanReserved "fileOpen" = "_fileOpen"
414 cleanReserved "fileClose" = "_fileClose"
415 cleanReserved "fputStr" = "_fputStr"
416 cleanReserved "fileEOF" = "_fileEOF"
417 cleanReserved "isNull" = "_isNull"
418 cleanReserved "idris_K" = "_idris_K"
419 cleanReserved "idris_flipK" = "_idris_flipK"
420 cleanReserved "idris_assignStack" = "_idris_assignStack"
421 cleanReserved "free" = "_free"
422 cleanReserved "malloc" = "_malloc"
423 cleanReserved "idris_memset" = "_idris_memset"
424 cleanReserved "idris_peek" = "_idris_peek"
425 cleanReserved "idris_poke" = "_idris_poke"
426 cleanReserved "idris_memmove" = "_idris_memmove"
428 cleanReserved x = x
430mkName :: Name -> CodeGeneration J.Name
431mkName (NS name nss) = (\ n ns -> J.Name (n:ns))
432 <$> mkIdentifier name
433 <*> mapM (mkIdentifier . UN) nss
434mkName n = J.Name . (:[]) <$> mkIdentifier n
436voidType :: ClassType
437voidType = ClassType [(Ident "Void", [])]
439objectType :: ClassType
440objectType = ClassType [(Ident "Object", [])]
442objectArrayType :: Language.Java.Syntax.Type
443objectArrayType = RefType . ArrayType . RefType . ClassRefType $ objectType
445idrisClosureType :: ClassType
446idrisClosureType = ClassType [(Ident "Closure", [])]
448idrisTailCallClosureType :: ClassType
449idrisTailCallClosureType = ClassType [(Ident "TailCallClosure", [])]
451idrisObjectType :: ClassType
452idrisObjectType = ClassType [(Ident "IdrisObject", [])]
454contextArray :: LVar -> Exp
455contextArray (Loc _) = ExpName $ J.Name [Ident "context"]
456contextArray (Glob _) = ExpName $ J.Name [Ident "globalContext"]
458charType :: ClassType
459charType = ClassType [(Ident "Character", [])]
461byteType :: ClassType
462byteType = ClassType [(Ident "Byte", [])]
464shortType :: ClassType
465shortType = ClassType [(Ident "Short", [])]
467integerType :: ClassType
468integerType = ClassType [(Ident "Integer", [])]
470longType :: ClassType
471longType = ClassType [(Ident "Integer", [])]
473bigIntegerType :: ClassType
474bigIntegerType = ClassType [(Ident "BigInteger", [])]
476doubleType :: ClassType
477doubleType = ClassType [(Ident "Double", [])]
479stringType :: ClassType
480stringType = ClassType [(Ident "String", [])]
482stringArrayType :: Language.Java.Syntax.Type
483stringArrayType = RefType . ArrayType . RefType . ClassRefType $ stringType
485exceptionType :: ClassType
486exceptionType = ClassType [(Ident "Throwable", [])]
488runtimeExceptionType :: ClassType
489runtimeExceptionType = ClassType [(Ident "RuntimeException", [])]
491comparableType :: ClassType
492comparableType = ClassType [(Ident "Comparable", [])]
494mkDecl :: (Name, SDecl) -> CodeGeneration Decl
495mkDecl ((NS n (ns:nss)), decl) =
496 (\ name body -> MemberDecl $ MemberClassDecl $ ClassDecl [Public, Static] name [] Nothing [] body)
497 <$> mkIdentifier (UN ns)
498 <*> mkClassBody [] [(NS n nss, decl)]
499mkDecl (_, SFun name params stackSize body) =
500 (\ name params paramNames methodBody ->
501 MemberDecl $ MethodDecl [Public, Static]
502 []
503 (Just . RefType $ ClassRefType objectType)
504 name
505 params
506 []
507 (MethodBody . Just $ Block
508 [ LocalVars [Final]
509 objectArrayType
510 [ VarDecl (VarDeclArray . VarId $ Ident "context")
511 (Just . InitArray . ArrayInit $
512 paramNames
513 ++ replicate stackSize (InitExp . Lit $ Null))
514 ]
515 , BlockStmt . Return $ Just methodBody
516 ]
517 )
518 )
519 <$> mkIdentifier name
520 <*> mapM mkFormalParam params
521 <*> mapM (\ p -> (InitExp . ExpName) <$> mkName p) params
522 <*> mkExp body
525mkClosure :: [Name] -> Int -> SExp -> CodeGeneration Exp
526mkClosure params stackSize body =
527 (\ paramArray body ->
528 InstanceCreation []
529 idrisClosureType
530 [paramArray]
531 (Just $ ClassBody [body])
532 )
533 <$> mkStackInit params stackSize
534 <*> mkClosureCall body
536mkFormalParam :: Name -> CodeGeneration FormalParam
537mkFormalParam name =
538 (\ name -> FormalParam [Final] (RefType . ClassRefType $ objectType) False (VarId name))
539 <$> mkIdentifier name
541mkClosureCall :: SExp -> CodeGeneration Decl
542mkClosureCall body =
543 (\ body -> MemberDecl $ MethodDecl [Public] [] (Just . RefType $ ClassRefType objectType) (Ident "call") [] [] body)
544 <$> mkMethodBody body
546mkMethodBody :: SExp -> CodeGeneration MethodBody
547mkMethodBody exp =
548 (\ exp -> MethodBody . Just . Block $ [BlockStmt . Return . Just $ exp])
549 <$> mkExp exp
551mkStackInit :: [Name] -> Int -> CodeGeneration Exp
552mkStackInit params stackSize =
553 (\ localVars -> ArrayCreateInit objectArrayType 0 . ArrayInit $
554 (map (InitExp . ExpName) localVars)
555 ++ (replicate (stackSize) (InitExp $ Lit Null)))
556 <$> mapM mkName params
558mkK :: Exp -> Exp -> Exp
559mkK result drop =
560 MethodInv $ MethodCall (J.Name [Ident "idris_K"]) [ result, drop ]
562mkFlipK :: Exp -> Exp -> Exp
563mkFlipK drop result =
564 MethodInv $ MethodCall (J.Name [Ident "idris_flipK"]) [ drop, result ]
566mkLet :: LVar -> SExp -> SExp -> CodeGeneration Exp
567mkLet (Loc pos) oldExp newExp =
568 (\ oldExp newExp ->
569 mkFlipK ( Assign ( ArrayLhs $ ArrayIndex (ExpName $ J.Name [Ident "context"])
570 (Lit $ Int (toInteger pos)))
571 EqualA
572 newExp
573 )
574 oldExp
575 )
576 <$> mkExp oldExp
577 <*> mkExp newExp
578mkLet (Glob _) _ _ = T.lift $ Left "Cannot let bind to global variable"
580reverseNameSpace :: J.Name -> J.Name
581reverseNameSpace (J.Name ids) =
582 J.Name ((tail ids) ++ [head ids])
584mkCase :: Bool -> LVar -> [SAlt] -> CodeGeneration Exp
585mkCase checked var ((SConCase parentStackPos consIndex _ params branchExpression):cases) =
586 mkConsCase checked
587 var
588 parentStackPos
589 consIndex
590 params
591 branchExpression
592 (SCase var cases)
593mkCase checked var (c@(SConstCase constant branchExpression):cases) =
594 (\ constant branchExpression alternative var->
595 Cond ( MethodInv $ PrimaryMethodCall (constant)
596 []
597 (Ident "equals")
598 [var]
599 )
600 branchExpression
601 alternative
602 )
603 <$> mkExp (SConst constant)
604 <*> mkExp branchExpression
605 <*> mkCase checked var cases
606 <*> mkVarAccess Nothing var
607mkCase checked var (SDefaultCase exp:cases) = mkExp exp
608mkCase checked _ [] = mkExp (SError "Non-exhaustive pattern")
610mkConsCase :: Bool -> LVar -> Int -> Int -> [Name] -> SExp -> SExp -> CodeGeneration Exp
611mkConsCase checked
612 toDeconstruct
613 parentStackStart
614 consIndex
615 params
616 branchExpression
617 alternative =
618 (\ caseBinding alternative var varCasted->
619 Cond (BinOp (InstanceOf (var)
620 (ClassRefType idrisObjectType)
621 )
622 CAnd
623 ( BinOp
624 ( MethodInv $ PrimaryMethodCall (varCasted)
625 []
626 (Ident "getConstructorId")
627 []
628 )
629 Equal
630 (Lit $ Int (toInteger consIndex))
631 )
632 )
633 (caseBinding)
634 alternative
635 )
636 <$> mkCaseBinding checked toDeconstruct parentStackStart params branchExpression
637 <*> mkExp alternative
638 <*> mkVarAccess (Nothing) toDeconstruct
639 <*> mkVarAccess (Just idrisObjectType) toDeconstruct
642mkCaseBinding :: Bool -> LVar -> Int -> [Name] -> SExp -> CodeGeneration Exp
643mkCaseBinding True var parentStackStart params branchExpression =
644 (\ branchExpression deconstruction ->
645 mkFlipK (MethodInv $ MethodCall (J.Name [Ident "idris_assignStack"])
646 ( (ExpName $ J.Name [Ident "context"])
647 : (Lit $ Int (toInteger parentStackStart))
648 : deconstruction
649 ))
650 (branchExpression)
651 )
652 <$> mkExp branchExpression
653 <*> mkCaseBindingDeconstruction var params
654mkCaseBinding False var parentStackStart params branchExpression =
655 (\ bindingMethod deconstruction ->
656 MethodInv $ PrimaryMethodCall
657 ( MethodInv $ PrimaryMethodCall (InstanceCreation []
658 (ClassType [(Ident "Object", [])])
659 []
660 (Just $ ClassBody [MemberDecl $ bindingMethod])
661 )
662 []
663 (Ident "apply")
664 ( contextArray (Loc undefined) : deconstruction )
665 )
666 []
667 (Ident "call")
668 []
669 )
670 <$> mkCaseBindingMethod parentStackStart params branchExpression
671 <*> mkCaseBindingDeconstruction var params
673mkCaseBindingDeconstruction :: LVar -> [Name] -> CodeGeneration [Exp]
674mkCaseBindingDeconstruction var members =
675 mapM (mkProjection var) ([0..(length members - 1)])
677mkCaseBindingMethod :: Int -> [Name] -> SExp -> CodeGeneration MemberDecl
678mkCaseBindingMethod parentStackStart params branchExpression =
679 (\ formalParams caseBindingStack branchExpression ->
680 MethodDecl [Final, Public]
681 []
682 (Just . RefType $ ClassRefType idrisClosureType)
683 (Ident "apply")
684 (mkContextParam:formalParams)
685 []
686 (MethodBody . Just . Block $
687 caseBindingStack ++
688 [BlockStmt . Return $ Just branchExpression]))
689 <$> mapM mkFormalParam params
690 <*> mkBindingStack False parentStackStart params
691 <*> mkBindingClosure branchExpression
693mkContextParam :: FormalParam
694mkContextParam =
695 FormalParam [Final] (objectArrayType) False (VarId (Ident "context"))
697mkBindingClosure :: SExp -> CodeGeneration Exp
698mkBindingClosure oldExp =
699 (\ oldCall ->
700 InstanceCreation []
701 idrisClosureType
702 [ ExpName $ J.Name [Ident "new_context"] ]
703 (Just $ ClassBody [oldCall])
704 )
705 <$> mkClosureCall oldExp
708mkBindingStack :: Bool -> Int -> [Name] -> CodeGeneration [BlockStmt]
709mkBindingStack checked parentStackStart params =
710 (\ paramNames ->
711 ( LocalVars [Final]
712 objectArrayType
713 [ VarDecl (VarDeclArray . VarId $ Ident "new_context")
714 (Just . InitExp $ mkContextCopy checked parentStackStart params)
715 ])
716 : ( map (\ (param, pos) ->
717 BlockStmt . ExpStmt $
718 Assign (ArrayLhs $ ArrayIndex (ExpName $ J.Name [Ident "new_context"])
719 (Lit $ Int (toInteger pos)))
720 EqualA
721 (ExpName param)) $ zip paramNames [parentStackStart..]
722 )
723 )
724 <$> mapM mkName params
726mkContextCopy :: Bool -> Int -> [Name] -> Exp
727mkContextCopy True parentStackStart params =
728 MethodInv $ PrimaryMethodCall (ExpName $ J.Name [Ident "context"])
729 []
730 (Ident "clone")
731 []
732mkContextCopy False parentStackStart params =
733 MethodInv $ TypeMethodCall (J.Name [Ident "Arrays"])
734 []
735 (Ident "copyOf")
736 [ ExpName $ J.Name [Ident "context"]
737 , MethodInv
738 $ TypeMethodCall (J.Name [Ident "Math"])
739 []
740 (Ident "max")
741 [ FieldAccess $ PrimaryFieldAccess (ExpName $ J.Name [Ident "context"])
742 (Ident "length")
743 , Lit . Int $ toInteger (parentStackStart + length params)
744 ]
745 ]
747mkProjection :: LVar -> Int -> CodeGeneration Exp
748mkProjection var memberNr =
749 (\ var -> ArrayAccess $ ArrayIndex ( MethodInv $ PrimaryMethodCall
750 (var)
751 []
752 (Ident "getData")
753 []
754 )
755 (Lit $ Int (toInteger memberNr))
756 )
757 <$> mkVarAccess (Just idrisObjectType) var
759type ClassName = String
761mkPrimitive :: ClassName -> Literal -> Exp
762mkPrimitive className value =
763 MethodInv $ TypeMethodCall (J.Name [Ident className])
764 []
765 (Ident "valueOf")
766 [Lit $ value]
768mkClass :: ClassType -> Exp
769mkClass classType =
770 ClassLit . Just . RefType .ClassRefType $ classType
772mkBinOpExp :: ClassType -> Op -> [LVar] -> CodeGeneration Exp
773mkBinOpExp castTo op (var:vars) = do
774 start <- mkVarAccess (Just castTo) var
775 foldM (\ exp var -> BinOp exp op <$> mkVarAccess (Just castTo) var) start vars
777mkBinOpExpTrans :: (Exp -> Exp) -> (Exp -> Exp) -> ClassType -> Op -> [LVar] -> CodeGeneration Exp
778mkBinOpExpTrans opTransformation resultTransformation castTo op (var:vars) = do
779 start <- (mkVarAccess (Just castTo) var)
780 foldM (\ exp var -> resultTransformation
781 . BinOp (opTransformation exp) op
782 . opTransformation
783 <$> mkVarAccess (Just castTo) var)
784 start
785 vars
787mkBinOpExpConv :: String -> PrimType -> ClassType -> Op -> [LVar] -> CodeGeneration Exp
788mkBinOpExpConv fromMethodName toType fromType@(ClassType [(cls@(Ident _), [])]) op args =
789 mkBinOpExpTrans (\ exp -> MethodInv $ TypeMethodCall (J.Name [cls])
790 []
791 (Ident fromMethodName)
792 [exp]
793 )
794 (\ exp -> MethodInv $ TypeMethodCall (J.Name [cls])
795 []
796 (Ident "valueOf")
797 [Cast (PrimType $ toType) exp]
798 )
799 fromType
800 op
801 args
803mkLogicalBinOpExp :: ClassType -> Op -> [LVar] -> CodeGeneration Exp
804mkLogicalBinOpExp castTo op (var:vars) = do
805 start <- mkVarAccess (Just castTo) var
806 foldM (\ exp var -> mkBoolToNumber castTo . BinOp exp op <$> mkVarAccess (Just castTo) var)
807 start
808 vars
810mkMethodOpChain1 :: (Exp -> Exp) -> ClassType -> String -> [LVar] -> CodeGeneration Exp
811mkMethodOpChain1 = mkMethodOpChain id
813mkMethodOpChain :: (Exp -> Exp) -> (Exp -> Exp) -> ClassType -> String -> [LVar] -> CodeGeneration Exp
814mkMethodOpChain initialTransformation resultTransformation castTo method (arg:args) = do
815 start <- initialTransformation <$> mkVarAccess (Just $ castTo) arg
816 foldM (\ exp arg' ->
817 resultTransformation
818 . MethodInv
819 . PrimaryMethodCall exp [] (Ident method)
820 . (:[])
821 <$> mkVarAccess (Just $ castTo) arg'
822 )
823 start
824 args
826mkBoolToNumber :: ClassType -> Exp -> Exp
827mkBoolToNumber (ClassType [(Ident name, [])]) boolExp =
828 Cond boolExp (mkPrimitive name (Int 1)) (mkPrimitive name (Int 0))
830mkZeroExt :: String -> Int -> ClassType -> ClassType -> LVar -> CodeGeneration Exp
831mkZeroExt toMethod bits fromType toType@(ClassType [(toTypeName, [])]) var = do
832 (\ var sext ->
833 MethodInv $ TypeMethodCall (J.Name [toTypeName])
834 []
835 (Ident "valueOf")
836 [ Cond ( BinOp (var)
837 LThan
838 (Lit $ Int 0)
839 )
840 ( BinOp (Lit $ Int (2^bits))
841 Add
842 (sext)
843 )
844 sext
845 ]
846 )
847 <$> mkVarAccess (Just $ fromType) var
848 <*> mkSignedExt' toMethod fromType var
850mkSignedExt :: String -> ClassType -> ClassType -> LVar -> CodeGeneration Exp
851mkSignedExt toMethod fromType (ClassType [(toTypeName, [])]) var =
852 (\ sext -> MethodInv $ TypeMethodCall (J.Name [toTypeName])
853 []
854 (Ident "valueOf")
855 [ sext ]
856 )
857 <$> mkSignedExt' toMethod fromType var
859mkSignedExt' :: String -> ClassType -> LVar -> CodeGeneration Exp
860mkSignedExt' toMethod fromType var =
861 (\ var -> MethodInv $ PrimaryMethodCall (var)
862 []
863 (Ident toMethod)
864 []
865 )
866 <$> mkVarAccess (Just $ fromType) var
868data SPartialOrder
869 = SLt
870 | SLe
871 | SEq
872 | SGe
873 | SGt
875mkPartialOrder :: SPartialOrder -> Exp -> Exp
876mkPartialOrder SLt x = (BinOp (Lit $ Int (-1)) Equal x)
877mkPartialOrder SLe x =
878 BinOp (BinOp (Lit $ Int (-1)) Equal x)
879 COr
880 (BinOp (Lit $ Int 0) Equal x)
881mkPartialOrder SEq x = BinOp (Lit $ Int 0) Equal x
882mkPartialOrder SGe x =
883 BinOp (BinOp (Lit $ Int 1) Equal x)
884 COr
885 (BinOp (Lit $ Int 0) Equal x)
886mkPartialOrder SGt x = (BinOp (Lit $ Int 1) Equal x)
888varPos :: LVar -> CodeGeneration Integer
889varPos (Loc i) = return (toInteger i)
890varPos (Glob name) = do
891 positions <- globalVariablePositions <$> get
892 case lookup name positions of
893 (Just pos) -> return pos
894 Nothing -> T.lift . Left $ "Invalid global variable id: " ++ show name
896mkVarAccess :: Maybe ClassType -> LVar -> CodeGeneration Exp
897mkVarAccess Nothing var =
898 (\ pos -> ArrayAccess $ ArrayIndex (contextArray var) (Lit $ Int pos))
899 <$> varPos var
900mkVarAccess (Just castTo) var =
901 Cast (RefType . ClassRefType $ castTo) <$> (mkVarAccess Nothing var)
903mkPrimitiveCast :: ClassType -> ClassType -> LVar -> CodeGeneration Exp
904mkPrimitiveCast fromType (ClassType [(toType, [])]) var =
905 (\ var ->
906 MethodInv $ TypeMethodCall (J.Name [toType])
907 []
908 (Ident "valueOf")
909 [var]
910 )
911 <$> mkVarAccess (Just fromType) var
913mkToString :: ClassType -> LVar -> CodeGeneration Exp
914mkToString castTo var =
915 (\ var -> MethodInv $ PrimaryMethodCall (var)
916 []
917 (Ident "toString")
918 []
919 )
920 <$> mkVarAccess (Just castTo) var
921data Std = In | Out | Err
923instance Show Std where
924 show In = "in"
925 show Out = "out"
926 show Err = "err"
928mkSystemStd :: Std -> Exp
929mkSystemStd std = FieldAccess $ PrimaryFieldAccess (ExpName $ J.Name [Ident "System"]) (Ident $ show std)
931mkSystemOutPrint :: Exp -> Exp
932mkSystemOutPrint value =
933 MethodInv $ PrimaryMethodCall (mkSystemStd Out)
934 []
935 (Ident "print")
936 [value]
938mkMathFun :: String -> LVar -> CodeGeneration Exp
939mkMathFun funName var =
940 (\ var -> MethodInv $ TypeMethodCall (J.Name [Ident "Double"])
941 []
942 (Ident "valueOf")
943 [ MethodInv $ TypeMethodCall (J.Name [Ident "Math"])
944 []
945 (Ident funName)
946 [var]
947 ]
948 )
949 <$> mkVarAccess (Just doubleType) var
951mkStringAtIndex :: LVar -> Exp -> CodeGeneration Exp
952mkStringAtIndex var indexExp =
953 (\ var -> MethodInv $ TypeMethodCall (J.Name [Ident "Integer"])
954 []
955 (Ident "valueOf")
956 [ MethodInv $ PrimaryMethodCall (var)
957 []
958 (Ident "charAt")
959 [indexExp]
960 ]
961 )
962 <$> mkVarAccess (Just stringType) var
964mkForeignType :: FType -> Maybe ClassType
965mkForeignType FInt = return integerType
966mkForeignType FChar = return integerType
967mkForeignType FString = return stringType
968mkForeignType FPtr = return objectType
969mkForeignType FDouble = return doubleType
970mkForeignType FAny = return objectType
971mkForeignType FUnit = Nothing
973mkForeignVarAccess :: FType -> LVar -> CodeGeneration Exp
974mkForeignVarAccess FInt var =
975 (\ var -> MethodInv $ PrimaryMethodCall (var)
976 []
977 (Ident "intValue")
978 []
979 )
980 <$> mkVarAccess (Just integerType) var
981mkForeignVarAccess FChar var = Cast (PrimType CharT) <$> mkForeignVarAccess FInt var
982mkForeignVarAccess FDouble var =
983 (\ var -> MethodInv $ PrimaryMethodCall (var)
984 []
985 (Ident "doubleValue")
986 []
987 )
988 <$> mkVarAccess (Just doubleType) var
989mkForeignVarAccess otherType var = mkVarAccess (mkForeignType otherType) var
991mkFromForeignType :: FType -> Exp -> Exp
992mkFromForeignType FInt from =
993 MethodInv $ TypeMethodCall (J.Name [Ident "Integer"])
994 []
995 (Ident "valueOf")
996 [from]
997mkFromForeignType FChar from = mkFromForeignType FInt from
998mkFromForeignType FDouble from =
999 MethodInv $ TypeMethodCall (J.Name [Ident "Double"])
1000 []
1001 (Ident "valueOf")
1002 [from]
1003mkFromForeignType _ from = from
1005mkForeignInvoke :: FType -> String -> [(FType, LVar)] -> CodeGeneration Exp
1006mkForeignInvoke fType method args =
1007 (\ foreignInvokeMeth ->
1008 MethodInv $ PrimaryMethodCall (InstanceCreation []
1009 objectType
1010 []
1011 (Just $ ClassBody [ MemberDecl $ foreignInvokeMeth ])
1013 []
1014 (Ident "foreignInvoke")
1015 []
1017 <$> mkForeignInvokeMethod fType method args
1020mkForeignInvokeMethod :: FType -> String -> [(FType, LVar)] -> CodeGeneration MemberDecl
1021mkForeignInvokeMethod fType method args =
1022 (\ tryBlock ->
1023 MethodDecl [Public, Final]
1024 []
1025 (Just . RefType $ ClassRefType objectType)
1026 (Ident "foreignInvoke")
1027 []
1028 []
1029 (MethodBody . Just $ Block
1030 [ BlockStmt
1031 $ Try tryBlock
1032 [ Catch (FormalParam []
1033 (RefType $ ClassRefType exceptionType)
1034 False
1035 (VarId $ Ident "ex")
1037 (Block [ BlockStmt
1038 . Throw
1039 $ InstanceCreation []
1040 runtimeExceptionType
1041 [ExpName $ J.Name [Ident "ex"]]
1042 Nothing
1046 Nothing
1050 <$> mkForeignInvokeTryBlock fType method args
1053mkForeignInvokeTryBlock :: FType -> String -> [(FType, LVar)] -> CodeGeneration Block
1054mkForeignInvokeTryBlock FUnit method args =
1055 (\ method args -> Block [ BlockStmt . ExpStmt . MethodInv $ MethodCall method args
1056 , BlockStmt $ Return (Just $ Lit Null)
1059 <$> ( T.lift $ left (\ err -> "Error parsing name \"" ++ method ++ "\" :" ++ (show err))
1060 (parser name method)
1062 <*> mapM (uncurry mkForeignVarAccess) args
1063mkForeignInvokeTryBlock fType method args =
1064 (\ method args -> Block [ BlockStmt . Return
1065 . Just
1066 . mkFromForeignType fType
1067 . MethodInv
1068 $ MethodCall method args
1071 <$> ( T.lift $ left (\ err -> "Error parsing name \"" ++ method ++ "\" :" ++ (show err))
1072 (parser name method)
1074 <*> mapM (uncurry mkForeignVarAccess) args
1076mkMethodClosure :: Name -> [LVar] -> CodeGeneration Exp
1077mkMethodClosure name args =
1078 (\ name args ->
1079 InstanceCreation []
1080 idrisClosureType
1081 [ (ExpName $ J.Name [Ident "context"]) ]
1082 ( Just
1083 $ ClassBody
1084 [ MemberDecl
1085 $ MethodDecl [Public, Final]
1086 []
1087 (Just . RefType $ ClassRefType objectType)
1088 (Ident "call")
1089 []
1090 []
1091 ( MethodBody
1092 . Just
1093 $ Block [ BlockStmt
1094 . Return
1095 . Just
1096 . MethodInv
1097 $ MethodCall (reverseNameSpace name)
1098 args
1104 <$> mkName name
1105 <*> mapM (mkExp . SV) args
1107mkThread :: LVar -> CodeGeneration Exp
1108mkThread arg =
1109 (\ eval ->
1110 MethodInv
1111 $ PrimaryMethodCall (InstanceCreation []
1112 (ClassType [(Ident "Thread", [])])
1113 [ eval ]
1114 ( Just
1115 $ ClassBody [ MemberDecl
1116 $ MethodDecl [Public, Final]
1117 []
1118 (Just . RefType $ ClassRefType objectType)
1119 (Ident "_start")
1120 []
1121 []
1122 ( MethodBody
1123 . Just
1124 $ Block [ BlockStmt
1125 . ExpStmt
1126 . MethodInv
1127 $ MethodCall (J.Name [Ident "start"])
1128 []
1129 , BlockStmt
1130 . Return
1131 . Just
1132 $ This
1138 []
1139 (Ident "_start")
1140 []
1142 <$> mkThreadBinding arg
1144mkThreadBinding :: LVar -> CodeGeneration Exp
1145mkThreadBinding var =
1146 (\ bindingMethod var ->
1147 MethodInv $ PrimaryMethodCall ( InstanceCreation []
1148 objectType
1149 []
1150 (Just $ ClassBody [MemberDecl $ bindingMethod])
1152 []
1153 (Ident "apply")
1154 [ var ]
1156 <$> mkThreadBindingMethod
1157 <*> mkVarAccess Nothing var
1160mkThreadBindingMethod :: CodeGeneration MemberDecl
1161mkThreadBindingMethod =
1162 (\ compute ->
1163 MethodDecl [Final, Public]
1164 []
1165 (Just . RefType $ ClassRefType idrisClosureType)
1166 (Ident "apply")
1167 [ FormalParam [Final] (RefType . ClassRefType $ objectType) False (VarId $ Ident "param") ]
1168 []
1169 (MethodBody . Just $ Block
1170 [ mkThreadBindingStack
1171 , BlockStmt . Return $ Just compute
1175 <$> mkBindingClosure (SUpdate (Loc 0) (SApp False (MN 0 "EVAL") [Loc 0]))
1178mkThreadBindingStack :: BlockStmt
1179mkThreadBindingStack =
1180 LocalVars [Final]
1181 objectArrayType
1182 [ VarDecl (VarDeclArray . VarId $ Ident "new_context")
1183 (Just . InitArray $ ArrayInit [InitExp . ExpName $ J.Name [Ident "param"]])
1187mkExp :: SExp -> CodeGeneration Exp
1188mkExp (SV var) = mkVarAccess Nothing var
1189mkExp (SApp False name args) =
1190 (\ methClosure ->
1191 MethodInv $ PrimaryMethodCall ( InstanceCreation []
1192 idrisTailCallClosureType
1193 [ methClosure ]
1194 Nothing
1196 []
1197 (Ident "call")
1198 []
1200 <$> mkMethodClosure name args
1201mkExp (SApp True name args) =
1202 (\ methClosure ->
1203 ( InstanceCreation []
1204 idrisTailCallClosureType
1205 [ methClosure ]
1206 Nothing
1209 <$> mkMethodClosure name args
1210mkExp (SLet var new old) =
1211 mkLet var old new
1212mkExp (SUpdate var exp) =
1213 (\ rhs varPos -> Assign (ArrayLhs $ ArrayIndex (contextArray var) (Lit $ Int varPos))
1214 EqualA
1215 rhs
1217 <$> mkExp exp
1218 <*> varPos var
1219mkExp (SCon conId name args) =
1220 (\ args -> InstanceCreation []
1221 idrisObjectType
1222 ((Lit $ Int (toInteger conId)):args)
1223 Nothing)
1224 <$> mapM (mkExp .SV) args
1225mkExp (SCase var alts) = mkCase False var alts
1226mkExp (SChkCase var alts) = mkCase True var alts
1227mkExp (SProj var i) = mkProjection var i
1228mkExp (SConst (I x)) = return $ mkPrimitive "Integer" (Int (toInteger x))
1229mkExp (SConst (BI x)) =
1230 return $ InstanceCreation []
1231 (ClassType [(Ident "BigInteger", [])])
1232 [Lit $ String (show x)]
1233 Nothing
1234mkExp (SConst (Fl x)) = return $ mkPrimitive "Double" (Double x)
1235mkExp (SConst (Ch x)) = return $ mkPrimitive "Integer" (Char x)
1236mkExp (SConst (Str x)) = return $ Lit $ String x
1237mkExp (SConst IType) = return $ mkClass integerType
1238mkExp (SConst BIType) = return $ mkClass bigIntegerType
1239mkExp (SConst FlType) = return $ mkClass doubleType
1240mkExp (SConst ChType) = return $ mkClass charType
1241mkExp (SConst StrType) = return $ mkClass stringType
1242mkExp (SConst (B8 x)) = return $ mkPrimitive "Byte" (String (show x))
1243mkExp (SConst (B16 x)) = return $ mkPrimitive "Short" (String (show x))
1244mkExp (SConst (B32 x)) = return $ mkPrimitive "Integer" (Int (toInteger x))
1245mkExp (SConst (B64 x)) = return $ mkPrimitive "Long" (String (show x))
1246mkExp (SConst (B8Type))= return $ mkClass byteType
1247mkExp (SConst (B16Type)) = return $ mkClass shortType
1248mkExp (SConst (B32Type)) = return $ mkClass integerType
1249mkExp (SConst (B64Type)) = return $ mkClass longType
1250mkExp (SConst (PtrType)) = return $ mkClass objectType
1251mkExp (SConst (VoidType)) = return $ mkClass voidType
1252mkExp (SConst (Forgot)) = return $ mkClass objectType
1253mkExp (SForeign _ fType meth args) = mkForeignInvoke fType meth args
1254mkExp (SOp LPlus args) = mkBinOpExp integerType Add args
1255mkExp (SOp LMinus args) = mkBinOpExp integerType Sub args
1256mkExp (SOp LTimes args) = mkBinOpExp integerType Mult args
1257mkExp (SOp LDiv args) = mkBinOpExp integerType Div args
1258mkExp (SOp LMod args) = mkBinOpExp integerType Rem args
1259mkExp (SOp LAnd args) = mkBinOpExp integerType And args
1260mkExp (SOp LOr args) = mkBinOpExp integerType Or args
1261mkExp (SOp LXOr args) = mkBinOpExp integerType Xor args
1262mkExp (SOp LCompl [var]) =
1263 PreBitCompl <$> mkVarAccess (Just $ integerType) var
1264mkExp (SOp LSHL args) = mkBinOpExp integerType LShift args
1265mkExp (SOp LSHR args) = mkBinOpExp integerType RShift args
1266mkExp (SOp LEq args) =
1267 mkMethodOpChain1 (mkBoolToNumber integerType) objectType "equals" args
1268mkExp (SOp LLt args) = mkLogicalBinOpExp integerType LThan args
1269mkExp (SOp LLe args) = mkLogicalBinOpExp integerType LThanE args
1270mkExp (SOp LGt args) = mkLogicalBinOpExp integerType GThan args
1271mkExp (SOp LGe args) = mkLogicalBinOpExp integerType GThanE args
1272mkExp (SOp LFPlus args) = mkBinOpExp doubleType Add args
1273mkExp (SOp LFMinus args) = mkBinOpExp doubleType Sub args
1274mkExp (SOp LFTimes args) = mkBinOpExp doubleType Mult args
1275mkExp (SOp LFDiv args) = mkBinOpExp doubleType Div args
1276mkExp (SOp LFEq args) =
1277 mkMethodOpChain1 (mkBoolToNumber doubleType) doubleType "equals" args
1278mkExp (SOp LFLt args) = mkLogicalBinOpExp integerType LThan args
1279mkExp (SOp LFLe args) = mkLogicalBinOpExp integerType LThanE args
1280mkExp (SOp LFGt args) = mkLogicalBinOpExp integerType GThan args
1281mkExp (SOp LFGe args) = mkLogicalBinOpExp integerType GThanE args
1282mkExp (SOp LBPlus args) = mkMethodOpChain1 id bigIntegerType "add" args
1283mkExp (SOp LBMinus args) = mkMethodOpChain1 id bigIntegerType "subtract" args
1284mkExp (SOp LBTimes args) = mkMethodOpChain1 id bigIntegerType "multiply" args
1285mkExp (SOp LBDiv args) = mkMethodOpChain1 id bigIntegerType "divide" args
1286mkExp (SOp LBMod args) = mkMethodOpChain1 id bigIntegerType "mod" args
1287mkExp (SOp LBEq args) =
1288 mkMethodOpChain1 (mkBoolToNumber bigIntegerType) bigIntegerType "equals" args
1289mkExp (SOp LBLt args) =
1290 mkMethodOpChain1 ( mkBoolToNumber bigIntegerType
1291 . mkPartialOrder SLt
1292 )
1293 bigIntegerType
1294 "compare"
1295 args
1296mkExp (SOp LBLe args) =
1297 mkMethodOpChain1 ( mkBoolToNumber bigIntegerType
1298 . mkPartialOrder SLe
1299 )
1300 bigIntegerType
1301 "compare"
1302 args
1303mkExp (SOp LBGt args) =
1304 mkMethodOpChain1 ( mkBoolToNumber bigIntegerType
1305 . mkPartialOrder SGt
1306 )
1307 bigIntegerType
1308 "compare"
1309 args
1310mkExp (SOp LBGe args) =
1311 mkMethodOpChain1 ( mkBoolToNumber bigIntegerType
1312 . mkPartialOrder SGe
1313 )
1314 bigIntegerType
1315 "compare"
1316 args
1317mkExp (SOp LStrConcat args) =
1318 mkMethodOpChain (\ exp -> InstanceCreation []
1319 (ClassType [(Ident "StringBuilder", [])])
1320 [exp]
1321 Nothing
1323 (\ exp -> MethodInv $ PrimaryMethodCall exp [] (Ident "toString") [])
1324 stringType
1325 "append"
1326 args
1327mkExp (SOp LStrLt args@[_, _]) =
1328 mkMethodOpChain1 ( mkBoolToNumber integerType
1329 . mkPartialOrder SLt
1331 stringType
1332 "compare"
1333 args
1334mkExp (SOp LStrEq args@[_, _]) =
1335 mkMethodOpChain1 ( mkBoolToNumber integerType)
1336 stringType
1337 "equals"
1338 args
1339mkExp (SOp LStrLen [arg]) =
1340 (\ var -> MethodInv $ PrimaryMethodCall var [] (Ident "length") [])
1341 <$> mkVarAccess (Just stringType) arg
1342mkExp (SOp LIntFloat [arg]) =
1343 mkPrimitiveCast integerType doubleType arg
1344mkExp (SOp LFloatInt [arg]) =
1345 mkPrimitiveCast doubleType integerType arg
1346mkExp (SOp LIntStr [arg]) =
1347 mkToString integerType arg
1348mkExp (SOp LStrInt [arg]) =
1349 mkPrimitiveCast stringType integerType arg
1350mkExp (SOp LFloatStr [arg]) =
1351 mkToString doubleType arg
1352mkExp (SOp LStrFloat [arg]) =
1353 mkPrimitiveCast doubleType stringType arg
1354mkExp (SOp LIntBig [arg]) =
1355 mkPrimitiveCast integerType bigIntegerType arg
1356mkExp (SOp LBigInt [arg]) =
1357 mkPrimitiveCast bigIntegerType integerType arg
1358mkExp (SOp LStrBig [arg]) =
1359 (\ var -> InstanceCreation [] bigIntegerType [var] Nothing)
1360 <$> mkVarAccess (Just stringType) arg
1361mkExp (SOp LBigStr [arg]) =
1362 mkToString bigIntegerType arg
1363mkExp (SOp LChInt [arg]) =
1364 mkVarAccess (Just integerType) arg
1365mkExp (SOp LIntCh [arg]) =
1366 mkVarAccess (Just integerType) arg
1367mkExp (SOp LPrintNum [arg]) =
1368 mkSystemOutPrint <$> (mkVarAccess Nothing arg)
1369mkExp (SOp LPrintStr [arg]) =
1370 mkSystemOutPrint <$> (mkVarAccess (Just stringType) arg)
1371mkExp (SOp LReadStr [arg]) = mkExp (SForeign LANG_C FString "idris_readStr" [(FPtr, arg)])
1372mkExp (SOp LB8Lt args) = mkLogicalBinOpExp byteType LThan args
1373mkExp (SOp LB8Lte args) = mkLogicalBinOpExp byteType LThanE args
1374mkExp (SOp LB8Eq args) =
1375 mkMethodOpChain1 (mkBoolToNumber byteType) byteType "equals" args
1376mkExp (SOp LB8Gt args) = mkLogicalBinOpExp byteType GThan args
1377mkExp (SOp LB8Gte args) = mkLogicalBinOpExp byteType GThanE args
1378mkExp (SOp LB8Plus args) = mkBinOpExp byteType Add args
1379mkExp (SOp LB8Minus args) = mkBinOpExp byteType Sub args
1380mkExp (SOp LB8Times args) = mkBinOpExp byteType Mult args
1381mkExp (SOp LB8UDiv args) = mkBinOpExpConv "shortValue" ShortT byteType Div args
1382mkExp (SOp LB8SDiv args) = mkBinOpExp byteType Div args
1383mkExp (SOp LB8URem args) = mkBinOpExpConv "shortValue" ShortT byteType Rem args
1384mkExp (SOp LB8SRem args) = mkBinOpExp byteType Rem args
1385mkExp (SOp LB8Shl args) = mkBinOpExp byteType LShift args
1386mkExp (SOp LB8LShr args) = mkBinOpExp byteType RRShift args
1387mkExp (SOp LB8AShr args) = mkBinOpExp byteType RShift args
1388mkExp (SOp LB8And args) = mkBinOpExp byteType And args
1389mkExp (SOp LB8Or args) = mkBinOpExp byteType Or args
1390mkExp (SOp LB8Xor args) = mkBinOpExp byteType Xor args
1391mkExp (SOp LB8Compl [var]) =
1392 PreBitCompl <$> mkVarAccess (Just $ byteType) var
1393mkExp (SOp LB8Z16 [var]) = mkZeroExt "shortValue" 8 byteType shortType var
1394mkExp (SOp LB8Z32 [var]) = mkZeroExt "intValue" 8 byteType integerType var
1395mkExp (SOp LB8Z64 [var]) = mkZeroExt "longValue" 8 byteType longType var
1396mkExp (SOp LB8S16 [var]) = mkSignedExt "shortValue" byteType shortType var
1397mkExp (SOp LB8S32 [var]) = mkSignedExt "intValue" byteType integerType var
1398mkExp (SOp LB8S64 [var]) = mkSignedExt "longValue" byteType longType var
1399mkExp (SOp LB16Lt args) = mkLogicalBinOpExp shortType LThan args
1400mkExp (SOp LB16Lte args) = mkLogicalBinOpExp shortType LThanE args
1401mkExp (SOp LB16Eq args) =
1402 mkMethodOpChain1 (mkBoolToNumber shortType) shortType "equals" args
1403mkExp (SOp LB16Gt args) = mkLogicalBinOpExp shortType GThan args
1404mkExp (SOp LB16Gte args) = mkLogicalBinOpExp shortType GThanE args
1405mkExp (SOp LB16Plus args) = mkBinOpExp shortType Add args
1406mkExp (SOp LB16Minus args) = mkBinOpExp shortType Sub args
1407mkExp (SOp LB16Times args) = mkBinOpExp shortType Mult args
1408mkExp (SOp LB16UDiv args) = mkBinOpExpConv "intValue" IntT shortType Div args
1409mkExp (SOp LB16SDiv args) = mkBinOpExp shortType Div args
1410mkExp (SOp LB16URem args) = mkBinOpExpConv "intValue" IntT shortType Rem args
1411mkExp (SOp LB16SRem args) = mkBinOpExp shortType Rem args
1412mkExp (SOp LB16Shl args) = mkBinOpExp shortType LShift args
1413mkExp (SOp LB16LShr args) = mkBinOpExp shortType RRShift args
1414mkExp (SOp LB16AShr args) = mkBinOpExp shortType RShift args
1415mkExp (SOp LB16And args) = mkBinOpExp shortType And args
1416mkExp (SOp LB16Or args) = mkBinOpExp shortType Or args
1417mkExp (SOp LB16Xor args) = mkBinOpExp shortType Xor args
1418mkExp (SOp LB16Compl [var]) =
1419 PreBitCompl <$> mkVarAccess (Just $ shortType) var
1420mkExp (SOp LB16Z32 [var]) = mkZeroExt "intValue" 16 shortType integerType var
1421mkExp (SOp LB16Z64 [var]) = mkZeroExt "longValue" 16 shortType longType var
1422mkExp (SOp LB16S32 [var]) = mkSignedExt "intValue" shortType integerType var
1423mkExp (SOp LB16S64 [var]) = mkSignedExt "longValue" shortType longType var
1424mkExp (SOp LB16T8 [var]) =
1425 (\ var -> MethodInv $
1426 TypeMethodCall (J.Name [Ident "Byte"])
1427 []
1428 (Ident "valueOf")
1429 [ MethodInv
1430 $ PrimaryMethodCall var [] (Ident "byteValue") [] ]
1432 <$> mkVarAccess (Just $ shortType) var
1433mkExp (SOp LB32Lt args) = mkLogicalBinOpExp integerType LThan args
1434mkExp (SOp LB32Lte args) = mkLogicalBinOpExp integerType LThanE args
1435mkExp (SOp LB32Eq args) =
1436 mkMethodOpChain1 (mkBoolToNumber integerType) integerType "equals" args
1437mkExp (SOp LB32Gt args) = mkLogicalBinOpExp integerType GThan args
1438mkExp (SOp LB32Gte args) = mkLogicalBinOpExp integerType GThanE args
1439mkExp (SOp LB32Plus args) = mkBinOpExp integerType Add args
1440mkExp (SOp LB32Minus args) = mkBinOpExp integerType Sub args
1441mkExp (SOp LB32Times args) = mkBinOpExp integerType Mult args
1442mkExp (SOp LB32UDiv args) = mkBinOpExpConv "longValue" LongT integerType Div args
1443mkExp (SOp LB32SDiv args) = mkBinOpExp integerType Div args
1444mkExp (SOp LB32URem args) = mkBinOpExpConv "longValue" LongT integerType Rem args
1445mkExp (SOp LB32SRem args) = mkBinOpExp integerType Rem args
1446mkExp (SOp LB32Shl args) = mkBinOpExp integerType LShift args
1447mkExp (SOp LB32LShr args) = mkBinOpExp integerType RRShift args
1448mkExp (SOp LB32AShr args) = mkBinOpExp integerType RShift args
1449mkExp (SOp LB32And args) = mkBinOpExp integerType And args
1450mkExp (SOp LB32Or args) = mkBinOpExp integerType Or args
1451mkExp (SOp LB32Xor args) = mkBinOpExp integerType Xor args
1452mkExp (SOp LB32Compl [var]) =
1453 PreBitCompl <$> mkVarAccess (Just $ integerType) var
1454mkExp (SOp LB32Z64 [var]) = mkZeroExt "longValue" 32 integerType longType var
1455mkExp (SOp LB32S64 [var]) = mkSignedExt "longValue" integerType longType var
1456mkExp (SOp LB32T8 [var]) =
1457 (\ var -> MethodInv
1458 $ TypeMethodCall (J.Name [Ident "Byte"])
1459 []
1460 (Ident "valueOf")
1461 [ MethodInv $ PrimaryMethodCall var [] (Ident "byteValue") [] ]
1463 <$> mkVarAccess (Just $ integerType) var
1464mkExp (SOp LB32T16 [var]) =
1465 (\ var -> MethodInv
1466 $ TypeMethodCall (J.Name [Ident "Short"])
1467 []
1468 (Ident "valueOf")
1469 [ MethodInv $ PrimaryMethodCall var [] (Ident "shortValue") [] ]
1471 <$> mkVarAccess (Just $ integerType) var
1472mkExp (SOp LB64Lt args) = mkLogicalBinOpExp longType LThan args
1473mkExp (SOp LB64Lte args) = mkLogicalBinOpExp longType LThanE args
1474mkExp (SOp LB64Eq args) =
1475 mkMethodOpChain1 (mkBoolToNumber longType) longType "equals" args
1476mkExp (SOp LB64Gt args) = mkLogicalBinOpExp longType GThan args
1477mkExp (SOp LB64Gte args) = mkLogicalBinOpExp longType GThanE args
1478mkExp (SOp LB64Plus args) = mkBinOpExp longType Add args
1479mkExp (SOp LB64Minus args) = mkBinOpExp longType Sub args
1480mkExp (SOp LB64Times args) = mkBinOpExp longType Mult args
1481mkExp (SOp LB64UDiv (arg:args)) = do
1482 (arg:args) <- mapM (mkVarAccess (Just longType)) (arg:args)
1483 return $ foldl (\ exp arg ->
1484 MethodInv $ PrimaryMethodCall
1485 ( MethodInv $ PrimaryMethodCall
1486 ( MethodInv $ TypeMethodCall (J.Name [Ident "BigInteger"])
1487 []
1488 (Ident "valueOf")
1489 [ exp ]
1491 []
1492 (Ident "divide")
1493 [ MethodInv $ TypeMethodCall (J.Name [Ident "BigInteger"])
1494 []
1495 (Ident "valueOf")
1496 [ arg ]
1499 []
1500 (Ident "longValue")
1501 []
1502 )
1503 arg
1504 args
1505mkExp (SOp LB64SDiv args) = mkBinOpExp longType Div args
1506mkExp (SOp LB64URem (arg:args)) = do
1507 (arg:args) <- mapM (mkVarAccess (Just longType)) (arg:args)
1508 return $ foldl (\ exp arg ->
1509 MethodInv $ PrimaryMethodCall
1510 ( MethodInv $ PrimaryMethodCall
1511 ( MethodInv $ TypeMethodCall (J.Name [Ident "BigInteger"])
1512 []
1513 (Ident "valueOf")
1514 [ exp ]
1516 []
1517 (Ident "remainder")
1518 [ MethodInv $ TypeMethodCall (J.Name [Ident "BigInteger"])
1519 []
1520 (Ident "valueOf")
1521 [ arg ]
1524 []
1525 (Ident "longValue")
1526 []
1527 )
1528 arg
1529 args
1530mkExp (SOp LB64SRem args) = mkBinOpExp longType Rem args
1531mkExp (SOp LB64Shl args) = mkBinOpExp longType LShift args
1532mkExp (SOp LB64LShr args) = mkBinOpExp longType RRShift args
1533mkExp (SOp LB64AShr args) = mkBinOpExp longType RShift args
1534mkExp (SOp LB64And args) = mkBinOpExp longType And args
1535mkExp (SOp LB64Or args) = mkBinOpExp longType Or args
1536mkExp (SOp LB64Xor args) = mkBinOpExp longType Xor args
1537mkExp (SOp LB64Compl [var]) =
1538 PreBitCompl <$> mkVarAccess (Just $ longType) var
1539mkExp (SOp LB64T8 [var]) =
1540 (\ var -> MethodInv
1541 $ TypeMethodCall (J.Name [Ident "Byte"])
1542 []
1543 (Ident "valueOf")
1544 [ MethodInv
1545 $ PrimaryMethodCall var [] (Ident "byteValue") []
1548 <$> mkVarAccess (Just $ longType) var
1549mkExp (SOp LB64T16 [var]) =
1550 (\ var -> MethodInv
1551 $ TypeMethodCall (J.Name [Ident "Short"])
1552 []
1553 (Ident "valueOf")
1554 [ MethodInv $ PrimaryMethodCall var [] (Ident "shortValue") [] ]
1556 <$> mkVarAccess (Just $ longType) var
1557mkExp (SOp LB64T32 [var]) =
1558 (\ var -> MethodInv
1559 $ TypeMethodCall (J.Name [Ident "Integer"])
1560 []
1561 (Ident "valueOf")
1562 [ MethodInv $ PrimaryMethodCall var [] (Ident "intValue") [] ]
1564 <$> mkVarAccess (Just $ longType) var
1565mkExp (SOp LIntB8 [arg]) = mkExp (SOp LB32T8 [arg])
1566mkExp (SOp LIntB16 [arg]) = mkExp (SOp LB32T16 [arg])
1567mkExp (SOp LIntB32 [arg]) = mkExp (SV arg)
1568mkExp (SOp LIntB64 [arg]) = mkExp (SOp LB32S64 [arg])
1569mkExp (SOp LB32Int [arg]) = mkExp (SV arg)
1570mkExp (SOp LFExp [arg]) = mkMathFun "exp" arg
1571mkExp (SOp LFLog [arg]) = mkMathFun "log" arg
1572mkExp (SOp LFSin [arg]) = mkMathFun "sin" arg
1573mkExp (SOp LFCos [arg]) = mkMathFun "cos" arg
1574mkExp (SOp LFTan [arg]) = mkMathFun "tan" arg
1575mkExp (SOp LFASin [arg]) = mkMathFun "asin" arg
1576mkExp (SOp LFACos [arg]) = mkMathFun "acos" arg
1577mkExp (SOp LFATan [arg]) = mkMathFun "atan" arg
1578mkExp (SOp LFSqrt [arg]) = mkMathFun "sqrt" arg
1579mkExp (SOp LFFloor [arg]) = mkMathFun "floor" arg
1580mkExp (SOp LFCeil [arg]) = mkMathFun "ceil" arg
1581mkExp (SOp LStrHead [arg]) = mkStringAtIndex arg (Lit $ Int 0)
1582mkExp (SOp LStrTail [arg]) =
1583 (\ var -> MethodInv $ PrimaryMethodCall (var)
1584 []
1585 (Ident "substring")
1586 [Lit $ Int 1]
1587 )
1588 <$> mkVarAccess (Just stringType) arg
1589mkExp (SOp LStrCons [c, cs]) =
1590 (\ cVar csVar -> MethodInv $
1591 PrimaryMethodCall ( MethodInv $ PrimaryMethodCall (InstanceCreation []
1592 (ClassType [(Ident "StringBuilder", [])])
1593 [csVar]
1594 Nothing
1596 []
1597 (Ident "insert")
1598 [ Lit $ Int 0,
1599 Cast (PrimType CharT)
1600 (MethodInv $ PrimaryMethodCall
1601 (cVar)
1602 []
1603 (Ident "intValue")
1604 []
1608 []
1609 (Ident "toString")
1610 []
1612 <$> mkVarAccess (Just integerType) c
1613 <*> mkVarAccess (Just stringType) cs
1614mkExp (SOp LStrIndex [str, i]) = mkVarAccess (Just integerType) i >>= mkStringAtIndex str
1615mkExp (SOp LStrRev [str]) =
1616 (\ var -> MethodInv $
1617 PrimaryMethodCall ( MethodInv $ PrimaryMethodCall (InstanceCreation []
1618 (ClassType [(Ident "StringBuffer", [])])
1619 [var]
1620 Nothing
1622 []
1623 (Ident "reverse")
1624 []
1626 []
1627 (Ident "toString")
1628 []
1630 <$> mkVarAccess (Just stringType) str
1631mkExp (SOp LStdIn []) = return $ mkSystemStd In
1632mkExp (SOp LStdOut []) = return $ mkSystemStd Out
1633mkExp (SOp LStdErr []) = return $ mkSystemStd Err
1634mkExp (SOp LFork [arg]) = mkThread arg
1635mkExp (SOp LPar [arg]) = mkExp (SV arg)
1636mkExp (SOp LVMPtr []) =
1637 return $ MethodInv $ TypeMethodCall (J.Name [Ident "Thread"]) [] (Ident "currentThread") []
1638mkExp (SOp LNoOp args) = mkExp . SV $ last args
1639mkExp (SNothing) = return $ Lit Null
1640mkExp (SError err) =
1641 return . MethodInv $
1642 PrimaryMethodCall (InstanceCreation []
1643 runtimeExceptionType
1644 [Lit $ String err]
1645 ( Just $ ClassBody
1646 [ MemberDecl $ MethodDecl [Public, Final]
1647 []
1648 (Just . RefType $ ClassRefType objectType)
1649 (Ident "throwSelf")
1650 []
1651 []
1652 ( MethodBody . Just $
1653 Block [ BlockStmt (Throw This) ]
1658 []
1659 (Ident "throwSelf")
1660 []
1661mkExp other = error (show other)