git.iko.soy/Idris-dev
on 228ffdb help sign in
Idris-dev/src/IRTS/CodegenJava.hs
1655 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"
422 cleanReserved x = x
424mkName :: Name -> CodeGeneration J.Name
425mkName (NS name nss) = (\ n ns -> J.Name (n:ns))
426 <$> mkIdentifier name
427 <*> mapM (mkIdentifier . UN) nss
428mkName n = J.Name . (:[]) <$> mkIdentifier n
430voidType :: ClassType
431voidType = ClassType [(Ident "Void", [])]
433objectType :: ClassType
434objectType = ClassType [(Ident "Object", [])]
436objectArrayType :: Language.Java.Syntax.Type
437objectArrayType = RefType . ArrayType . RefType . ClassRefType $ objectType
439idrisClosureType :: ClassType
440idrisClosureType = ClassType [(Ident "Closure", [])]
442idrisTailCallClosureType :: ClassType
443idrisTailCallClosureType = ClassType [(Ident "TailCallClosure", [])]
445idrisObjectType :: ClassType
446idrisObjectType = ClassType [(Ident "IdrisObject", [])]
448contextArray :: LVar -> Exp
449contextArray (Loc _) = ExpName $ J.Name [Ident "context"]
450contextArray (Glob _) = ExpName $ J.Name [Ident "globalContext"]
452charType :: ClassType
453charType = ClassType [(Ident "Character", [])]
455byteType :: ClassType
456byteType = ClassType [(Ident "Byte", [])]
458shortType :: ClassType
459shortType = ClassType [(Ident "Short", [])]
461integerType :: ClassType
462integerType = ClassType [(Ident "Integer", [])]
464longType :: ClassType
465longType = ClassType [(Ident "Integer", [])]
467bigIntegerType :: ClassType
468bigIntegerType = ClassType [(Ident "BigInteger", [])]
470doubleType :: ClassType
471doubleType = ClassType [(Ident "Double", [])]
473stringType :: ClassType
474stringType = ClassType [(Ident "String", [])]
476stringArrayType :: Language.Java.Syntax.Type
477stringArrayType = RefType . ArrayType . RefType . ClassRefType $ stringType
479exceptionType :: ClassType
480exceptionType = ClassType [(Ident "Throwable", [])]
482runtimeExceptionType :: ClassType
483runtimeExceptionType = ClassType [(Ident "RuntimeException", [])]
485comparableType :: ClassType
486comparableType = ClassType [(Ident "Comparable", [])]
488mkDecl :: (Name, SDecl) -> CodeGeneration Decl
489mkDecl ((NS n (ns:nss)), decl) =
490 (\ name body -> MemberDecl $ MemberClassDecl $ ClassDecl [Public, Static] name [] Nothing [] body)
491 <$> mkIdentifier (UN ns)
492 <*> mkClassBody [] [(NS n nss, decl)]
493mkDecl (_, SFun name params stackSize body) =
494 (\ name params paramNames methodBody ->
495 MemberDecl $ MethodDecl [Public, Static]
496 []
497 (Just . RefType $ ClassRefType objectType)
498 name
499 params
500 []
501 (MethodBody . Just $ Block
502 [ LocalVars [Final]
503 objectArrayType
504 [ VarDecl (VarDeclArray . VarId $ Ident "context")
505 (Just . InitArray . ArrayInit $
506 paramNames
507 ++ replicate stackSize (InitExp . Lit $ Null))
508 ]
509 , BlockStmt . Return $ Just methodBody
510 ]
511 )
512 )
513 <$> mkIdentifier name
514 <*> mapM mkFormalParam params
515 <*> mapM (\ p -> (InitExp . ExpName) <$> mkName p) params
516 <*> mkExp body
519mkClosure :: [Name] -> Int -> SExp -> CodeGeneration Exp
520mkClosure params stackSize body =
521 (\ paramArray body ->
522 InstanceCreation []
523 idrisClosureType
524 [paramArray]
525 (Just $ ClassBody [body])
526 )
527 <$> mkStackInit params stackSize
528 <*> mkClosureCall body
530mkFormalParam :: Name -> CodeGeneration FormalParam
531mkFormalParam name =
532 (\ name -> FormalParam [Final] (RefType . ClassRefType $ objectType) False (VarId name))
533 <$> mkIdentifier name
535mkClosureCall :: SExp -> CodeGeneration Decl
536mkClosureCall body =
537 (\ body -> MemberDecl $ MethodDecl [Public] [] (Just . RefType $ ClassRefType objectType) (Ident "call") [] [] body)
538 <$> mkMethodBody body
540mkMethodBody :: SExp -> CodeGeneration MethodBody
541mkMethodBody exp =
542 (\ exp -> MethodBody . Just . Block $ [BlockStmt . Return . Just $ exp])
543 <$> mkExp exp
545mkStackInit :: [Name] -> Int -> CodeGeneration Exp
546mkStackInit params stackSize =
547 (\ localVars -> ArrayCreateInit objectArrayType 0 . ArrayInit $
548 (map (InitExp . ExpName) localVars)
549 ++ (replicate (stackSize) (InitExp $ Lit Null)))
550 <$> mapM mkName params
552mkK :: Exp -> Exp -> Exp
553mkK result drop =
554 MethodInv $ MethodCall (J.Name [Ident "idris_K"]) [ result, drop ]
556mkFlipK :: Exp -> Exp -> Exp
557mkFlipK drop result =
558 MethodInv $ MethodCall (J.Name [Ident "idris_flipK"]) [ drop, result ]
560mkLet :: LVar -> SExp -> SExp -> CodeGeneration Exp
561mkLet (Loc pos) oldExp newExp =
562 (\ oldExp newExp ->
563 mkFlipK ( Assign ( ArrayLhs $ ArrayIndex (ExpName $ J.Name [Ident "context"])
564 (Lit $ Int (toInteger pos)))
565 EqualA
566 newExp
567 )
568 oldExp
569 )
570 <$> mkExp oldExp
571 <*> mkExp newExp
572mkLet (Glob _) _ _ = T.lift $ Left "Cannot let bind to global variable"
574reverseNameSpace :: J.Name -> J.Name
575reverseNameSpace (J.Name ids) =
576 J.Name ((tail ids) ++ [head ids])
578mkCase :: Bool -> LVar -> [SAlt] -> CodeGeneration Exp
579mkCase checked var ((SConCase parentStackPos consIndex _ params branchExpression):cases) =
580 mkConsCase checked
581 var
582 parentStackPos
583 consIndex
584 params
585 branchExpression
586 (SCase var cases)
587mkCase checked var (c@(SConstCase constant branchExpression):cases) =
588 (\ constant branchExpression alternative var->
589 Cond ( MethodInv $ PrimaryMethodCall (constant)
590 []
591 (Ident "equals")
592 [var]
593 )
594 branchExpression
595 alternative
596 )
597 <$> mkExp (SConst constant)
598 <*> mkExp branchExpression
599 <*> mkCase checked var cases
600 <*> mkVarAccess Nothing var
601mkCase checked var (SDefaultCase exp:cases) = mkExp exp
602mkCase checked _ [] = mkExp (SError "Non-exhaustive pattern")
604mkConsCase :: Bool -> LVar -> Int -> Int -> [Name] -> SExp -> SExp -> CodeGeneration Exp
605mkConsCase checked
606 toDeconstruct
607 parentStackStart
608 consIndex
609 params
610 branchExpression
611 alternative =
612 (\ caseBinding alternative var varCasted->
613 Cond (BinOp (InstanceOf (var)
614 (ClassRefType idrisObjectType)
615 )
616 CAnd
617 ( BinOp
618 ( MethodInv $ PrimaryMethodCall (varCasted)
619 []
620 (Ident "getConstructorId")
621 []
622 )
623 Equal
624 (Lit $ Int (toInteger consIndex))
625 )
626 )
627 (caseBinding)
628 alternative
629 )
630 <$> mkCaseBinding checked toDeconstruct parentStackStart params branchExpression
631 <*> mkExp alternative
632 <*> mkVarAccess (Nothing) toDeconstruct
633 <*> mkVarAccess (Just idrisObjectType) toDeconstruct
636mkCaseBinding :: Bool -> LVar -> Int -> [Name] -> SExp -> CodeGeneration Exp
637mkCaseBinding True var parentStackStart params branchExpression =
638 (\ branchExpression deconstruction ->
639 mkFlipK (MethodInv $ MethodCall (J.Name [Ident "idris_assignStack"])
640 ( (ExpName $ J.Name [Ident "context"])
641 : (Lit $ Int (toInteger parentStackStart))
642 : deconstruction
643 ))
644 (branchExpression)
645 )
646 <$> mkExp branchExpression
647 <*> mkCaseBindingDeconstruction var params
648mkCaseBinding False var parentStackStart params branchExpression =
649 (\ bindingMethod deconstruction ->
650 MethodInv $ PrimaryMethodCall
651 ( MethodInv $ PrimaryMethodCall (InstanceCreation []
652 (ClassType [(Ident "Object", [])])
653 []
654 (Just $ ClassBody [MemberDecl $ bindingMethod])
655 )
656 []
657 (Ident "apply")
658 ( contextArray (Loc undefined) : deconstruction )
659 )
660 []
661 (Ident "call")
662 []
663 )
664 <$> mkCaseBindingMethod parentStackStart params branchExpression
665 <*> mkCaseBindingDeconstruction var params
667mkCaseBindingDeconstruction :: LVar -> [Name] -> CodeGeneration [Exp]
668mkCaseBindingDeconstruction var members =
669 mapM (mkProjection var) ([0..(length members - 1)])
671mkCaseBindingMethod :: Int -> [Name] -> SExp -> CodeGeneration MemberDecl
672mkCaseBindingMethod parentStackStart params branchExpression =
673 (\ formalParams caseBindingStack branchExpression ->
674 MethodDecl [Final, Public]
675 []
676 (Just . RefType $ ClassRefType idrisClosureType)
677 (Ident "apply")
678 (mkContextParam:formalParams)
679 []
680 (MethodBody . Just . Block $
681 caseBindingStack ++
682 [BlockStmt . Return $ Just branchExpression]))
683 <$> mapM mkFormalParam params
684 <*> mkBindingStack False parentStackStart params
685 <*> mkBindingClosure branchExpression
687mkContextParam :: FormalParam
688mkContextParam =
689 FormalParam [Final] (objectArrayType) False (VarId (Ident "context"))
691mkBindingClosure :: SExp -> CodeGeneration Exp
692mkBindingClosure oldExp =
693 (\ oldCall ->
694 InstanceCreation []
695 idrisClosureType
696 [ ExpName $ J.Name [Ident "new_context"] ]
697 (Just $ ClassBody [oldCall])
698 )
699 <$> mkClosureCall oldExp
702mkBindingStack :: Bool -> Int -> [Name] -> CodeGeneration [BlockStmt]
703mkBindingStack checked parentStackStart params =
704 (\ paramNames ->
705 ( LocalVars [Final]
706 objectArrayType
707 [ VarDecl (VarDeclArray . VarId $ Ident "new_context")
708 (Just . InitExp $ mkContextCopy checked parentStackStart params)
709 ])
710 : ( map (\ (param, pos) ->
711 BlockStmt . ExpStmt $
712 Assign (ArrayLhs $ ArrayIndex (ExpName $ J.Name [Ident "new_context"])
713 (Lit $ Int (toInteger pos)))
714 EqualA
715 (ExpName param)) $ zip paramNames [parentStackStart..]
716 )
717 )
718 <$> mapM mkName params
720mkContextCopy :: Bool -> Int -> [Name] -> Exp
721mkContextCopy True parentStackStart params =
722 MethodInv $ PrimaryMethodCall (ExpName $ J.Name [Ident "context"])
723 []
724 (Ident "clone")
725 []
726mkContextCopy False parentStackStart params =
727 MethodInv $ TypeMethodCall (J.Name [Ident "Arrays"])
728 []
729 (Ident "copyOf")
730 [ ExpName $ J.Name [Ident "context"]
731 , MethodInv
732 $ TypeMethodCall (J.Name [Ident "Math"])
733 []
734 (Ident "max")
735 [ FieldAccess $ PrimaryFieldAccess (ExpName $ J.Name [Ident "context"])
736 (Ident "length")
737 , Lit . Int $ toInteger (parentStackStart + length params)
738 ]
739 ]
741mkProjection :: LVar -> Int -> CodeGeneration Exp
742mkProjection var memberNr =
743 (\ var -> ArrayAccess $ ArrayIndex ( MethodInv $ PrimaryMethodCall
744 (var)
745 []
746 (Ident "getData")
747 []
748 )
749 (Lit $ Int (toInteger memberNr))
750 )
751 <$> mkVarAccess (Just idrisObjectType) var
753type ClassName = String
755mkPrimitive :: ClassName -> Literal -> Exp
756mkPrimitive className value =
757 MethodInv $ TypeMethodCall (J.Name [Ident className])
758 []
759 (Ident "valueOf")
760 [Lit $ value]
762mkClass :: ClassType -> Exp
763mkClass classType =
764 ClassLit . Just . RefType .ClassRefType $ classType
766mkBinOpExp :: ClassType -> Op -> [LVar] -> CodeGeneration Exp
767mkBinOpExp castTo op (var:vars) = do
768 start <- mkVarAccess (Just castTo) var
769 foldM (\ exp var -> BinOp exp op <$> mkVarAccess (Just castTo) var) start vars
771mkBinOpExpTrans :: (Exp -> Exp) -> (Exp -> Exp) -> ClassType -> Op -> [LVar] -> CodeGeneration Exp
772mkBinOpExpTrans opTransformation resultTransformation castTo op (var:vars) = do
773 start <- (mkVarAccess (Just castTo) var)
774 foldM (\ exp var -> resultTransformation
775 . BinOp (opTransformation exp) op
776 . opTransformation
777 <$> mkVarAccess (Just castTo) var)
778 start
779 vars
781mkBinOpExpConv :: String -> PrimType -> ClassType -> Op -> [LVar] -> CodeGeneration Exp
782mkBinOpExpConv fromMethodName toType fromType@(ClassType [(cls@(Ident _), [])]) op args =
783 mkBinOpExpTrans (\ exp -> MethodInv $ TypeMethodCall (J.Name [cls])
784 []
785 (Ident fromMethodName)
786 [exp]
787 )
788 (\ exp -> MethodInv $ TypeMethodCall (J.Name [cls])
789 []
790 (Ident "valueOf")
791 [Cast (PrimType $ toType) exp]
792 )
793 fromType
794 op
795 args
797mkLogicalBinOpExp :: ClassType -> Op -> [LVar] -> CodeGeneration Exp
798mkLogicalBinOpExp castTo op (var:vars) = do
799 start <- mkVarAccess (Just castTo) var
800 foldM (\ exp var -> mkBoolToNumber castTo . BinOp exp op <$> mkVarAccess (Just castTo) var)
801 start
802 vars
804mkMethodOpChain1 :: (Exp -> Exp) -> ClassType -> String -> [LVar] -> CodeGeneration Exp
805mkMethodOpChain1 = mkMethodOpChain id
807mkMethodOpChain :: (Exp -> Exp) -> (Exp -> Exp) -> ClassType -> String -> [LVar] -> CodeGeneration Exp
808mkMethodOpChain initialTransformation resultTransformation castTo method (arg:args) = do
809 start <- initialTransformation <$> mkVarAccess (Just $ castTo) arg
810 foldM (\ exp arg' ->
811 resultTransformation
812 . MethodInv
813 . PrimaryMethodCall exp [] (Ident method)
814 . (:[])
815 <$> mkVarAccess (Just $ castTo) arg'
816 )
817 start
818 args
820mkBoolToNumber :: ClassType -> Exp -> Exp
821mkBoolToNumber (ClassType [(Ident name, [])]) boolExp =
822 Cond boolExp (mkPrimitive name (Int 1)) (mkPrimitive name (Int 0))
824mkZeroExt :: String -> Int -> ClassType -> ClassType -> LVar -> CodeGeneration Exp
825mkZeroExt toMethod bits fromType toType@(ClassType [(toTypeName, [])]) var = do
826 (\ var sext ->
827 MethodInv $ TypeMethodCall (J.Name [toTypeName])
828 []
829 (Ident "valueOf")
830 [ Cond ( BinOp (var)
831 LThan
832 (Lit $ Int 0)
833 )
834 ( BinOp (Lit $ Int (2^bits))
835 Add
836 (sext)
837 )
838 sext
839 ]
840 )
841 <$> mkVarAccess (Just $ fromType) var
842 <*> mkSignedExt' toMethod fromType var
844mkSignedExt :: String -> ClassType -> ClassType -> LVar -> CodeGeneration Exp
845mkSignedExt toMethod fromType (ClassType [(toTypeName, [])]) var =
846 (\ sext -> MethodInv $ TypeMethodCall (J.Name [toTypeName])
847 []
848 (Ident "valueOf")
849 [ sext ]
850 )
851 <$> mkSignedExt' toMethod fromType var
853mkSignedExt' :: String -> ClassType -> LVar -> CodeGeneration Exp
854mkSignedExt' toMethod fromType var =
855 (\ var -> MethodInv $ PrimaryMethodCall (var)
856 []
857 (Ident toMethod)
858 []
859 )
860 <$> mkVarAccess (Just $ fromType) var
862data SPartialOrder
863 = SLt
864 | SLe
865 | SEq
866 | SGe
867 | SGt
869mkPartialOrder :: SPartialOrder -> Exp -> Exp
870mkPartialOrder SLt x = (BinOp (Lit $ Int (-1)) Equal x)
871mkPartialOrder SLe x =
872 BinOp (BinOp (Lit $ Int (-1)) Equal x)
873 COr
874 (BinOp (Lit $ Int 0) Equal x)
875mkPartialOrder SEq x = BinOp (Lit $ Int 0) Equal x
876mkPartialOrder SGe x =
877 BinOp (BinOp (Lit $ Int 1) Equal x)
878 COr
879 (BinOp (Lit $ Int 0) Equal x)
880mkPartialOrder SGt x = (BinOp (Lit $ Int 1) Equal x)
882varPos :: LVar -> CodeGeneration Integer
883varPos (Loc i) = return (toInteger i)
884varPos (Glob name) = do
885 positions <- globalVariablePositions <$> get
886 case lookup name positions of
887 (Just pos) -> return pos
888 Nothing -> T.lift . Left $ "Invalid global variable id: " ++ show name
890mkVarAccess :: Maybe ClassType -> LVar -> CodeGeneration Exp
891mkVarAccess Nothing var =
892 (\ pos -> ArrayAccess $ ArrayIndex (contextArray var) (Lit $ Int pos))
893 <$> varPos var
894mkVarAccess (Just castTo) var =
895 Cast (RefType . ClassRefType $ castTo) <$> (mkVarAccess Nothing var)
897mkPrimitiveCast :: ClassType -> ClassType -> LVar -> CodeGeneration Exp
898mkPrimitiveCast fromType (ClassType [(toType, [])]) var =
899 (\ var ->
900 MethodInv $ TypeMethodCall (J.Name [toType])
901 []
902 (Ident "valueOf")
903 [var]
904 )
905 <$> mkVarAccess (Just fromType) var
907mkToString :: ClassType -> LVar -> CodeGeneration Exp
908mkToString castTo var =
909 (\ var -> MethodInv $ PrimaryMethodCall (var)
910 []
911 (Ident "toString")
912 []
913 )
914 <$> mkVarAccess (Just castTo) var
915data Std = In | Out | Err
917instance Show Std where
918 show In = "in"
919 show Out = "out"
920 show Err = "err"
922mkSystemStd :: Std -> Exp
923mkSystemStd std = FieldAccess $ PrimaryFieldAccess (ExpName $ J.Name [Ident "System"]) (Ident $ show std)
925mkSystemOutPrint :: Exp -> Exp
926mkSystemOutPrint value =
927 MethodInv $ PrimaryMethodCall (mkSystemStd Out)
928 []
929 (Ident "print")
930 [value]
932mkMathFun :: String -> LVar -> CodeGeneration Exp
933mkMathFun funName var =
934 (\ var -> MethodInv $ TypeMethodCall (J.Name [Ident "Double"])
935 []
936 (Ident "valueOf")
937 [ MethodInv $ TypeMethodCall (J.Name [Ident "Math"])
938 []
939 (Ident funName)
940 [var]
941 ]
942 )
943 <$> mkVarAccess (Just doubleType) var
945mkStringAtIndex :: LVar -> Exp -> CodeGeneration Exp
946mkStringAtIndex var indexExp =
947 (\ var -> MethodInv $ TypeMethodCall (J.Name [Ident "Integer"])
948 []
949 (Ident "valueOf")
950 [ MethodInv $ PrimaryMethodCall (var)
951 []
952 (Ident "charAt")
953 [indexExp]
954 ]
955 )
956 <$> mkVarAccess (Just stringType) var
958mkForeignType :: FType -> Maybe ClassType
959mkForeignType FInt = return integerType
960mkForeignType FChar = return integerType
961mkForeignType FString = return stringType
962mkForeignType FPtr = return objectType
963mkForeignType FDouble = return doubleType
964mkForeignType FAny = return objectType
965mkForeignType FUnit = Nothing
967mkForeignVarAccess :: FType -> LVar -> CodeGeneration Exp
968mkForeignVarAccess FInt var =
969 (\ var -> MethodInv $ PrimaryMethodCall (var)
970 []
971 (Ident "intValue")
972 []
973 )
974 <$> mkVarAccess (Just integerType) var
975mkForeignVarAccess FChar var = Cast (PrimType CharT) <$> mkForeignVarAccess FInt var
976mkForeignVarAccess FDouble var =
977 (\ var -> MethodInv $ PrimaryMethodCall (var)
978 []
979 (Ident "doubleValue")
980 []
981 )
982 <$> mkVarAccess (Just doubleType) var
983mkForeignVarAccess otherType var = mkVarAccess (mkForeignType otherType) var
985mkFromForeignType :: FType -> Exp -> Exp
986mkFromForeignType FInt from =
987 MethodInv $ TypeMethodCall (J.Name [Ident "Integer"])
988 []
989 (Ident "valueOf")
990 [from]
991mkFromForeignType FChar from = mkFromForeignType FInt from
992mkFromForeignType FDouble from =
993 MethodInv $ TypeMethodCall (J.Name [Ident "Double"])
994 []
995 (Ident "valueOf")
996 [from]
997mkFromForeignType _ from = from
999mkForeignInvoke :: FType -> String -> [(FType, LVar)] -> CodeGeneration Exp
1000mkForeignInvoke fType method args =
1001 (\ foreignInvokeMeth ->
1002 MethodInv $ PrimaryMethodCall (InstanceCreation []
1003 objectType
1004 []
1005 (Just $ ClassBody [ MemberDecl $ foreignInvokeMeth ])
1007 []
1008 (Ident "foreignInvoke")
1009 []
1011 <$> mkForeignInvokeMethod fType method args
1014mkForeignInvokeMethod :: FType -> String -> [(FType, LVar)] -> CodeGeneration MemberDecl
1015mkForeignInvokeMethod fType method args =
1016 (\ tryBlock ->
1017 MethodDecl [Public, Final]
1018 []
1019 (Just . RefType $ ClassRefType objectType)
1020 (Ident "foreignInvoke")
1021 []
1022 []
1023 (MethodBody . Just $ Block
1024 [ BlockStmt
1025 $ Try tryBlock
1026 [ Catch (FormalParam []
1027 (RefType $ ClassRefType exceptionType)
1028 False
1029 (VarId $ Ident "ex")
1031 (Block [ BlockStmt
1032 . Throw
1033 $ InstanceCreation []
1034 runtimeExceptionType
1035 [ExpName $ J.Name [Ident "ex"]]
1036 Nothing
1040 Nothing
1044 <$> mkForeignInvokeTryBlock fType method args
1047mkForeignInvokeTryBlock :: FType -> String -> [(FType, LVar)] -> CodeGeneration Block
1048mkForeignInvokeTryBlock FUnit method args =
1049 (\ method args -> Block [ BlockStmt . ExpStmt . MethodInv $ MethodCall method args
1050 , BlockStmt $ Return (Just $ Lit Null)
1053 <$> ( T.lift $ left (\ err -> "Error parsing name \"" ++ method ++ "\" :" ++ (show err))
1054 (parser name method)
1056 <*> mapM (uncurry mkForeignVarAccess) args
1057mkForeignInvokeTryBlock fType method args =
1058 (\ method args -> Block [ BlockStmt . Return
1059 . Just
1060 . mkFromForeignType fType
1061 . MethodInv
1062 $ MethodCall method args
1065 <$> ( T.lift $ left (\ err -> "Error parsing name \"" ++ method ++ "\" :" ++ (show err))
1066 (parser name method)
1068 <*> mapM (uncurry mkForeignVarAccess) args
1070mkMethodClosure :: Name -> [LVar] -> CodeGeneration Exp
1071mkMethodClosure name args =
1072 (\ name args ->
1073 InstanceCreation []
1074 idrisClosureType
1075 [ (ExpName $ J.Name [Ident "context"]) ]
1076 ( Just
1077 $ ClassBody
1078 [ MemberDecl
1079 $ MethodDecl [Public, Final]
1080 []
1081 (Just . RefType $ ClassRefType objectType)
1082 (Ident "call")
1083 []
1084 []
1085 ( MethodBody
1086 . Just
1087 $ Block [ BlockStmt
1088 . Return
1089 . Just
1090 . MethodInv
1091 $ MethodCall (reverseNameSpace name)
1092 args
1098 <$> mkName name
1099 <*> mapM (mkExp . SV) args
1101mkThread :: LVar -> CodeGeneration Exp
1102mkThread arg =
1103 (\ eval ->
1104 MethodInv
1105 $ PrimaryMethodCall (InstanceCreation []
1106 (ClassType [(Ident "Thread", [])])
1107 [ eval ]
1108 ( Just
1109 $ ClassBody [ MemberDecl
1110 $ MethodDecl [Public, Final]
1111 []
1112 (Just . RefType $ ClassRefType objectType)
1113 (Ident "_start")
1114 []
1115 []
1116 ( MethodBody
1117 . Just
1118 $ Block [ BlockStmt
1119 . ExpStmt
1120 . MethodInv
1121 $ MethodCall (J.Name [Ident "start"])
1122 []
1123 , BlockStmt
1124 . Return
1125 . Just
1126 $ This
1132 []
1133 (Ident "_start")
1134 []
1136 <$> mkThreadBinding arg
1138mkThreadBinding :: LVar -> CodeGeneration Exp
1139mkThreadBinding var =
1140 (\ bindingMethod var ->
1141 MethodInv $ PrimaryMethodCall ( InstanceCreation []
1142 objectType
1143 []
1144 (Just $ ClassBody [MemberDecl $ bindingMethod])
1146 []
1147 (Ident "apply")
1148 [ var ]
1150 <$> mkThreadBindingMethod
1151 <*> mkVarAccess Nothing var
1154mkThreadBindingMethod :: CodeGeneration MemberDecl
1155mkThreadBindingMethod =
1156 (\ compute ->
1157 MethodDecl [Final, Public]
1158 []
1159 (Just . RefType $ ClassRefType idrisClosureType)
1160 (Ident "apply")
1161 [ FormalParam [Final] (RefType . ClassRefType $ objectType) False (VarId $ Ident "param") ]
1162 []
1163 (MethodBody . Just $ Block
1164 [ mkThreadBindingStack
1165 , BlockStmt . Return $ Just compute
1169 <$> mkBindingClosure (SUpdate (Loc 0) (SApp False (MN 0 "EVAL") [Loc 0]))
1172mkThreadBindingStack :: BlockStmt
1173mkThreadBindingStack =
1174 LocalVars [Final]
1175 objectArrayType
1176 [ VarDecl (VarDeclArray . VarId $ Ident "new_context")
1177 (Just . InitArray $ ArrayInit [InitExp . ExpName $ J.Name [Ident "param"]])
1181mkExp :: SExp -> CodeGeneration Exp
1182mkExp (SV var) = mkVarAccess Nothing var
1183mkExp (SApp False name args) =
1184 (\ methClosure ->
1185 MethodInv $ PrimaryMethodCall ( InstanceCreation []
1186 idrisTailCallClosureType
1187 [ methClosure ]
1188 Nothing
1190 []
1191 (Ident "call")
1192 []
1194 <$> mkMethodClosure name args
1195mkExp (SApp True name args) =
1196 (\ methClosure ->
1197 ( InstanceCreation []
1198 idrisTailCallClosureType
1199 [ methClosure ]
1200 Nothing
1203 <$> mkMethodClosure name args
1204mkExp (SLet var new old) =
1205 mkLet var old new
1206mkExp (SUpdate var exp) =
1207 (\ rhs varPos -> Assign (ArrayLhs $ ArrayIndex (contextArray var) (Lit $ Int varPos))
1208 EqualA
1209 rhs
1211 <$> mkExp exp
1212 <*> varPos var
1213mkExp (SCon conId name args) =
1214 (\ args -> InstanceCreation []
1215 idrisObjectType
1216 ((Lit $ Int (toInteger conId)):args)
1217 Nothing)
1218 <$> mapM (mkExp .SV) args
1219mkExp (SCase var alts) = mkCase False var alts
1220mkExp (SChkCase var alts) = mkCase True var alts
1221mkExp (SProj var i) = mkProjection var i
1222mkExp (SConst (I x)) = return $ mkPrimitive "Integer" (Int (toInteger x))
1223mkExp (SConst (BI x)) =
1224 return $ InstanceCreation []
1225 (ClassType [(Ident "BigInteger", [])])
1226 [Lit $ String (show x)]
1227 Nothing
1228mkExp (SConst (Fl x)) = return $ mkPrimitive "Double" (Double x)
1229mkExp (SConst (Ch x)) = return $ mkPrimitive "Integer" (Char x)
1230mkExp (SConst (Str x)) = return $ Lit $ String x
1231mkExp (SConst IType) = return $ mkClass integerType
1232mkExp (SConst BIType) = return $ mkClass bigIntegerType
1233mkExp (SConst FlType) = return $ mkClass doubleType
1234mkExp (SConst ChType) = return $ mkClass charType
1235mkExp (SConst StrType) = return $ mkClass stringType
1236mkExp (SConst (B8 x)) = return $ mkPrimitive "Byte" (Int (toInteger x))
1237mkExp (SConst (B16 x)) = return $ mkPrimitive "Short" (Int (toInteger x))
1238mkExp (SConst (B32 x)) = return $ mkPrimitive "Integer" (Int (toInteger x))
1239mkExp (SConst (B64 x)) = return $ mkPrimitive "Long" (Int (toInteger x))
1240mkExp (SConst (B8Type))= return $ mkClass byteType
1241mkExp (SConst (B16Type)) = return $ mkClass shortType
1242mkExp (SConst (B32Type)) = return $ mkClass integerType
1243mkExp (SConst (B64Type)) = return $ mkClass longType
1244mkExp (SConst (PtrType)) = return $ mkClass objectType
1245mkExp (SConst (VoidType)) = return $ mkClass voidType
1246mkExp (SConst (Forgot)) = return $ mkClass objectType
1247mkExp (SForeign _ fType meth args) = mkForeignInvoke fType meth args
1248mkExp (SOp LPlus args) = mkBinOpExp integerType Add args
1249mkExp (SOp LMinus args) = mkBinOpExp integerType Sub args
1250mkExp (SOp LTimes args) = mkBinOpExp integerType Mult args
1251mkExp (SOp LDiv args) = mkBinOpExp integerType Div args
1252mkExp (SOp LMod args) = mkBinOpExp integerType Rem args
1253mkExp (SOp LAnd args) = mkBinOpExp integerType And args
1254mkExp (SOp LOr args) = mkBinOpExp integerType Or args
1255mkExp (SOp LXOr args) = mkBinOpExp integerType Xor args
1256mkExp (SOp LCompl [var]) =
1257 PreBitCompl <$> mkVarAccess (Just $ integerType) var
1258mkExp (SOp LSHL args) = mkBinOpExp integerType LShift args
1259mkExp (SOp LSHR args) = mkBinOpExp integerType RShift args
1260mkExp (SOp LEq args) =
1261 mkMethodOpChain1 (mkBoolToNumber integerType) objectType "equals" args
1262mkExp (SOp LLt args) = mkLogicalBinOpExp integerType LThan args
1263mkExp (SOp LLe args) = mkLogicalBinOpExp integerType LThanE args
1264mkExp (SOp LGt args) = mkLogicalBinOpExp integerType GThan args
1265mkExp (SOp LGe args) = mkLogicalBinOpExp integerType GThanE args
1266mkExp (SOp LFPlus args) = mkBinOpExp doubleType Add args
1267mkExp (SOp LFMinus args) = mkBinOpExp doubleType Sub args
1268mkExp (SOp LFTimes args) = mkBinOpExp doubleType Mult args
1269mkExp (SOp LFDiv args) = mkBinOpExp doubleType Div args
1270mkExp (SOp LFEq args) =
1271 mkMethodOpChain1 (mkBoolToNumber doubleType) doubleType "equals" args
1272mkExp (SOp LFLt args) = mkLogicalBinOpExp integerType LThan args
1273mkExp (SOp LFLe args) = mkLogicalBinOpExp integerType LThanE args
1274mkExp (SOp LFGt args) = mkLogicalBinOpExp integerType GThan args
1275mkExp (SOp LFGe args) = mkLogicalBinOpExp integerType GThanE args
1276mkExp (SOp LBPlus args) = mkMethodOpChain1 id bigIntegerType "add" args
1277mkExp (SOp LBMinus args) = mkMethodOpChain1 id bigIntegerType "subtract" args
1278mkExp (SOp LBTimes args) = mkMethodOpChain1 id bigIntegerType "multiply" args
1279mkExp (SOp LBDiv args) = mkMethodOpChain1 id bigIntegerType "divide" args
1280mkExp (SOp LBMod args) = mkMethodOpChain1 id bigIntegerType "mod" args
1281mkExp (SOp LBEq args) =
1282 mkMethodOpChain1 (mkBoolToNumber bigIntegerType) bigIntegerType "equals" args
1283mkExp (SOp LBLt args) =
1284 mkMethodOpChain1 ( mkBoolToNumber bigIntegerType
1285 . mkPartialOrder SLt
1286 )
1287 bigIntegerType
1288 "compare"
1289 args
1290mkExp (SOp LBLe args) =
1291 mkMethodOpChain1 ( mkBoolToNumber bigIntegerType
1292 . mkPartialOrder SLe
1293 )
1294 bigIntegerType
1295 "compare"
1296 args
1297mkExp (SOp LBGt args) =
1298 mkMethodOpChain1 ( mkBoolToNumber bigIntegerType
1299 . mkPartialOrder SGt
1300 )
1301 bigIntegerType
1302 "compare"
1303 args
1304mkExp (SOp LBGe args) =
1305 mkMethodOpChain1 ( mkBoolToNumber bigIntegerType
1306 . mkPartialOrder SGe
1307 )
1308 bigIntegerType
1309 "compare"
1310 args
1311mkExp (SOp LStrConcat args) =
1312 mkMethodOpChain (\ exp -> InstanceCreation []
1313 (ClassType [(Ident "StringBuilder", [])])
1314 [exp]
1315 Nothing
1317 (\ exp -> MethodInv $ PrimaryMethodCall exp [] (Ident "toString") [])
1318 stringType
1319 "append"
1320 args
1321mkExp (SOp LStrLt args@[_, _]) =
1322 mkMethodOpChain1 ( mkBoolToNumber integerType
1323 . mkPartialOrder SLt
1325 stringType
1326 "compare"
1327 args
1328mkExp (SOp LStrEq args@[_, _]) =
1329 mkMethodOpChain1 ( mkBoolToNumber integerType)
1330 stringType
1331 "equals"
1332 args
1333mkExp (SOp LStrLen [arg]) =
1334 (\ var -> MethodInv $ PrimaryMethodCall var [] (Ident "length") [])
1335 <$> mkVarAccess (Just stringType) arg
1336mkExp (SOp LIntFloat [arg]) =
1337 mkPrimitiveCast integerType doubleType arg
1338mkExp (SOp LFloatInt [arg]) =
1339 mkPrimitiveCast doubleType integerType arg
1340mkExp (SOp LIntStr [arg]) =
1341 mkToString integerType arg
1342mkExp (SOp LStrInt [arg]) =
1343 mkPrimitiveCast stringType integerType arg
1344mkExp (SOp LFloatStr [arg]) =
1345 mkToString doubleType arg
1346mkExp (SOp LStrFloat [arg]) =
1347 mkPrimitiveCast doubleType stringType arg
1348mkExp (SOp LIntBig [arg]) =
1349 mkPrimitiveCast integerType bigIntegerType arg
1350mkExp (SOp LBigInt [arg]) =
1351 mkPrimitiveCast bigIntegerType integerType arg
1352mkExp (SOp LStrBig [arg]) =
1353 (\ var -> InstanceCreation [] bigIntegerType [var] Nothing)
1354 <$> mkVarAccess (Just stringType) arg
1355mkExp (SOp LBigStr [arg]) =
1356 mkToString bigIntegerType arg
1357mkExp (SOp LChInt [arg]) =
1358 mkVarAccess (Just integerType) arg
1359mkExp (SOp LIntCh [arg]) =
1360 mkVarAccess (Just integerType) arg
1361mkExp (SOp LPrintNum [arg]) =
1362 mkSystemOutPrint <$> (mkVarAccess Nothing arg)
1363mkExp (SOp LPrintStr [arg]) =
1364 mkSystemOutPrint <$> (mkVarAccess (Just stringType) arg)
1365mkExp (SOp LReadStr [arg]) = mkExp (SForeign LANG_C FString "idris_readStr" [(FPtr, arg)])
1366mkExp (SOp LB8Lt args) = mkLogicalBinOpExp byteType LThan args
1367mkExp (SOp LB8Lte args) = mkLogicalBinOpExp byteType LThanE args
1368mkExp (SOp LB8Eq args) =
1369 mkMethodOpChain1 (mkBoolToNumber byteType) byteType "equals" args
1370mkExp (SOp LB8Gt args) = mkLogicalBinOpExp byteType GThan args
1371mkExp (SOp LB8Gte args) = mkLogicalBinOpExp byteType GThanE args
1372mkExp (SOp LB8Plus args) = mkBinOpExp byteType Add args
1373mkExp (SOp LB8Minus args) = mkBinOpExp byteType Sub args
1374mkExp (SOp LB8Times args) = mkBinOpExp byteType Mult args
1375mkExp (SOp LB8UDiv args) = mkBinOpExpConv "shortValue" ShortT byteType Div args
1376mkExp (SOp LB8SDiv args) = mkBinOpExp byteType Div args
1377mkExp (SOp LB8URem args) = mkBinOpExpConv "shortValue" ShortT byteType Rem args
1378mkExp (SOp LB8SRem args) = mkBinOpExp byteType Rem args
1379mkExp (SOp LB8Shl args) = mkBinOpExp byteType LShift args
1380mkExp (SOp LB8LShr args) = mkBinOpExp byteType RRShift args
1381mkExp (SOp LB8AShr args) = mkBinOpExp byteType RShift args
1382mkExp (SOp LB8And args) = mkBinOpExp byteType And args
1383mkExp (SOp LB8Or args) = mkBinOpExp byteType Or args
1384mkExp (SOp LB8Xor args) = mkBinOpExp byteType Xor args
1385mkExp (SOp LB8Compl [var]) =
1386 PreBitCompl <$> mkVarAccess (Just $ byteType) var
1387mkExp (SOp LB8Z16 [var]) = mkZeroExt "shortValue" 8 byteType shortType var
1388mkExp (SOp LB8Z32 [var]) = mkZeroExt "intValue" 8 byteType integerType var
1389mkExp (SOp LB8Z64 [var]) = mkZeroExt "longValue" 8 byteType longType var
1390mkExp (SOp LB8S16 [var]) = mkSignedExt "shortValue" byteType shortType var
1391mkExp (SOp LB8S32 [var]) = mkSignedExt "intValue" byteType integerType var
1392mkExp (SOp LB8S64 [var]) = mkSignedExt "longValue" byteType longType var
1393mkExp (SOp LB16Lt args) = mkLogicalBinOpExp shortType LThan args
1394mkExp (SOp LB16Lte args) = mkLogicalBinOpExp shortType LThanE args
1395mkExp (SOp LB16Eq args) =
1396 mkMethodOpChain1 (mkBoolToNumber shortType) shortType "equals" args
1397mkExp (SOp LB16Gt args) = mkLogicalBinOpExp shortType GThan args
1398mkExp (SOp LB16Gte args) = mkLogicalBinOpExp shortType GThanE args
1399mkExp (SOp LB16Plus args) = mkBinOpExp shortType Add args
1400mkExp (SOp LB16Minus args) = mkBinOpExp shortType Sub args
1401mkExp (SOp LB16Times args) = mkBinOpExp shortType Mult args
1402mkExp (SOp LB16UDiv args) = mkBinOpExpConv "intValue" IntT shortType Div args
1403mkExp (SOp LB16SDiv args) = mkBinOpExp shortType Div args
1404mkExp (SOp LB16URem args) = mkBinOpExpConv "intValue" IntT shortType Rem args
1405mkExp (SOp LB16SRem args) = mkBinOpExp shortType Rem args
1406mkExp (SOp LB16Shl args) = mkBinOpExp shortType LShift args
1407mkExp (SOp LB16LShr args) = mkBinOpExp shortType RRShift args
1408mkExp (SOp LB16AShr args) = mkBinOpExp shortType RShift args
1409mkExp (SOp LB16And args) = mkBinOpExp shortType And args
1410mkExp (SOp LB16Or args) = mkBinOpExp shortType Or args
1411mkExp (SOp LB16Xor args) = mkBinOpExp shortType Xor args
1412mkExp (SOp LB16Compl [var]) =
1413 PreBitCompl <$> mkVarAccess (Just $ shortType) var
1414mkExp (SOp LB16Z32 [var]) = mkZeroExt "intValue" 16 shortType integerType var
1415mkExp (SOp LB16Z64 [var]) = mkZeroExt "longValue" 16 shortType longType var
1416mkExp (SOp LB16S32 [var]) = mkSignedExt "intValue" shortType integerType var
1417mkExp (SOp LB16S64 [var]) = mkSignedExt "longValue" shortType longType var
1418mkExp (SOp LB16T8 [var]) =
1419 (\ var -> MethodInv $
1420 TypeMethodCall (J.Name [Ident "Byte"])
1421 []
1422 (Ident "valueOf")
1423 [ MethodInv
1424 $ PrimaryMethodCall var [] (Ident "byteValue") [] ]
1426 <$> mkVarAccess (Just $ shortType) var
1427mkExp (SOp LB32Lt args) = mkLogicalBinOpExp integerType LThan args
1428mkExp (SOp LB32Lte args) = mkLogicalBinOpExp integerType LThanE args
1429mkExp (SOp LB32Eq args) =
1430 mkMethodOpChain1 (mkBoolToNumber integerType) integerType "equals" args
1431mkExp (SOp LB32Gt args) = mkLogicalBinOpExp integerType GThan args
1432mkExp (SOp LB32Gte args) = mkLogicalBinOpExp integerType GThanE args
1433mkExp (SOp LB32Plus args) = mkBinOpExp integerType Add args
1434mkExp (SOp LB32Minus args) = mkBinOpExp integerType Sub args
1435mkExp (SOp LB32Times args) = mkBinOpExp integerType Mult args
1436mkExp (SOp LB32UDiv args) = mkBinOpExpConv "longValue" LongT integerType Div args
1437mkExp (SOp LB32SDiv args) = mkBinOpExp integerType Div args
1438mkExp (SOp LB32URem args) = mkBinOpExpConv "longValue" LongT integerType Rem args
1439mkExp (SOp LB32SRem args) = mkBinOpExp integerType Rem args
1440mkExp (SOp LB32Shl args) = mkBinOpExp integerType LShift args
1441mkExp (SOp LB32LShr args) = mkBinOpExp integerType RRShift args
1442mkExp (SOp LB32AShr args) = mkBinOpExp integerType RShift args
1443mkExp (SOp LB32And args) = mkBinOpExp integerType And args
1444mkExp (SOp LB32Or args) = mkBinOpExp integerType Or args
1445mkExp (SOp LB32Xor args) = mkBinOpExp integerType Xor args
1446mkExp (SOp LB32Compl [var]) =
1447 PreBitCompl <$> mkVarAccess (Just $ integerType) var
1448mkExp (SOp LB32Z64 [var]) = mkZeroExt "longValue" 32 integerType longType var
1449mkExp (SOp LB32S64 [var]) = mkSignedExt "longValue" integerType longType var
1450mkExp (SOp LB32T8 [var]) =
1451 (\ var -> MethodInv
1452 $ TypeMethodCall (J.Name [Ident "Byte"])
1453 []
1454 (Ident "valueOf")
1455 [ MethodInv $ PrimaryMethodCall var [] (Ident "byteValue") [] ]
1457 <$> mkVarAccess (Just $ integerType) var
1458mkExp (SOp LB32T16 [var]) =
1459 (\ var -> MethodInv
1460 $ TypeMethodCall (J.Name [Ident "Short"])
1461 []
1462 (Ident "valueOf")
1463 [ MethodInv $ PrimaryMethodCall var [] (Ident "shortValue") [] ]
1465 <$> mkVarAccess (Just $ integerType) var
1466mkExp (SOp LB64Lt args) = mkLogicalBinOpExp longType LThan args
1467mkExp (SOp LB64Lte args) = mkLogicalBinOpExp longType LThanE args
1468mkExp (SOp LB64Eq args) =
1469 mkMethodOpChain1 (mkBoolToNumber longType) longType "equals" args
1470mkExp (SOp LB64Gt args) = mkLogicalBinOpExp longType GThan args
1471mkExp (SOp LB64Gte args) = mkLogicalBinOpExp longType GThanE args
1472mkExp (SOp LB64Plus args) = mkBinOpExp longType Add args
1473mkExp (SOp LB64Minus args) = mkBinOpExp longType Sub args
1474mkExp (SOp LB64Times args) = mkBinOpExp longType Mult args
1475mkExp (SOp LB64UDiv (arg:args)) = do
1476 (arg:args) <- mapM (mkVarAccess (Just longType)) (arg:args)
1477 return $ foldl (\ exp arg ->
1478 MethodInv $ PrimaryMethodCall
1479 ( MethodInv $ PrimaryMethodCall
1480 ( MethodInv $ TypeMethodCall (J.Name [Ident "BigInteger"])
1481 []
1482 (Ident "valueOf")
1483 [ exp ]
1485 []
1486 (Ident "divide")
1487 [ MethodInv $ TypeMethodCall (J.Name [Ident "BigInteger"])
1488 []
1489 (Ident "valueOf")
1490 [ arg ]
1493 []
1494 (Ident "longValue")
1495 []
1496 )
1497 arg
1498 args
1499mkExp (SOp LB64SDiv args) = mkBinOpExp longType Div args
1500mkExp (SOp LB64URem (arg:args)) = do
1501 (arg:args) <- mapM (mkVarAccess (Just longType)) (arg:args)
1502 return $ foldl (\ exp arg ->
1503 MethodInv $ PrimaryMethodCall
1504 ( MethodInv $ PrimaryMethodCall
1505 ( MethodInv $ TypeMethodCall (J.Name [Ident "BigInteger"])
1506 []
1507 (Ident "valueOf")
1508 [ exp ]
1510 []
1511 (Ident "remainder")
1512 [ MethodInv $ TypeMethodCall (J.Name [Ident "BigInteger"])
1513 []
1514 (Ident "valueOf")
1515 [ arg ]
1518 []
1519 (Ident "longValue")
1520 []
1521 )
1522 arg
1523 args
1524mkExp (SOp LB64SRem args) = mkBinOpExp longType Rem args
1525mkExp (SOp LB64Shl args) = mkBinOpExp longType LShift args
1526mkExp (SOp LB64LShr args) = mkBinOpExp longType RRShift args
1527mkExp (SOp LB64AShr args) = mkBinOpExp longType RShift args
1528mkExp (SOp LB64And args) = mkBinOpExp longType And args
1529mkExp (SOp LB64Or args) = mkBinOpExp longType Or args
1530mkExp (SOp LB64Xor args) = mkBinOpExp longType Xor args
1531mkExp (SOp LB64Compl [var]) =
1532 PreBitCompl <$> mkVarAccess (Just $ longType) var
1533mkExp (SOp LB64T8 [var]) =
1534 (\ var -> MethodInv
1535 $ TypeMethodCall (J.Name [Ident "Byte"])
1536 []
1537 (Ident "valueOf")
1538 [ MethodInv
1539 $ PrimaryMethodCall var [] (Ident "byteValue") []
1542 <$> mkVarAccess (Just $ longType) var
1543mkExp (SOp LB64T16 [var]) =
1544 (\ var -> MethodInv
1545 $ TypeMethodCall (J.Name [Ident "Short"])
1546 []
1547 (Ident "valueOf")
1548 [ MethodInv $ PrimaryMethodCall var [] (Ident "shortValue") [] ]
1550 <$> mkVarAccess (Just $ longType) var
1551mkExp (SOp LB64T32 [var]) =
1552 (\ var -> MethodInv
1553 $ TypeMethodCall (J.Name [Ident "Integer"])
1554 []
1555 (Ident "valueOf")
1556 [ MethodInv $ PrimaryMethodCall var [] (Ident "intValue") [] ]
1558 <$> mkVarAccess (Just $ longType) var
1559mkExp (SOp LIntB8 [arg]) = mkExp (SOp LB32T8 [arg])
1560mkExp (SOp LIntB16 [arg]) = mkExp (SOp LB32T16 [arg])
1561mkExp (SOp LIntB32 [arg]) = mkExp (SV arg)
1562mkExp (SOp LIntB64 [arg]) = mkExp (SOp LB32S64 [arg])
1563mkExp (SOp LB32Int [arg]) = mkExp (SV arg)
1564mkExp (SOp LFExp [arg]) = mkMathFun "exp" arg
1565mkExp (SOp LFLog [arg]) = mkMathFun "log" arg
1566mkExp (SOp LFSin [arg]) = mkMathFun "sin" arg
1567mkExp (SOp LFCos [arg]) = mkMathFun "cos" arg
1568mkExp (SOp LFTan [arg]) = mkMathFun "tan" arg
1569mkExp (SOp LFASin [arg]) = mkMathFun "asin" arg
1570mkExp (SOp LFACos [arg]) = mkMathFun "acos" arg
1571mkExp (SOp LFATan [arg]) = mkMathFun "atan" arg
1572mkExp (SOp LFSqrt [arg]) = mkMathFun "sqrt" arg
1573mkExp (SOp LFFloor [arg]) = mkMathFun "floor" arg
1574mkExp (SOp LFCeil [arg]) = mkMathFun "ceil" arg
1575mkExp (SOp LStrHead [arg]) = mkStringAtIndex arg (Lit $ Int 0)
1576mkExp (SOp LStrTail [arg]) =
1577 (\ var -> MethodInv $ PrimaryMethodCall (var)
1578 []
1579 (Ident "substring")
1580 [Lit $ Int 1]
1581 )
1582 <$> mkVarAccess (Just stringType) arg
1583mkExp (SOp LStrCons [c, cs]) =
1584 (\ cVar csVar -> MethodInv $
1585 PrimaryMethodCall ( MethodInv $ PrimaryMethodCall (InstanceCreation []
1586 (ClassType [(Ident "StringBuilder", [])])
1587 [csVar]
1588 Nothing
1590 []
1591 (Ident "insert")
1592 [ Lit $ Int 0,
1593 Cast (PrimType CharT)
1594 (MethodInv $ PrimaryMethodCall
1595 (cVar)
1596 []
1597 (Ident "intValue")
1598 []
1602 []
1603 (Ident "toString")
1604 []
1606 <$> mkVarAccess (Just integerType) c
1607 <*> mkVarAccess (Just stringType) cs
1608mkExp (SOp LStrIndex [str, i]) = mkVarAccess (Just integerType) i >>= mkStringAtIndex str
1609mkExp (SOp LStrRev [str]) =
1610 (\ var -> MethodInv $
1611 PrimaryMethodCall ( MethodInv $ PrimaryMethodCall (InstanceCreation []
1612 (ClassType [(Ident "StringBuffer", [])])
1613 [var]
1614 Nothing
1616 []
1617 (Ident "reverse")
1618 []
1620 []
1621 (Ident "toString")
1622 []
1624 <$> mkVarAccess (Just stringType) str
1625mkExp (SOp LStdIn []) = return $ mkSystemStd In
1626mkExp (SOp LStdOut []) = return $ mkSystemStd Out
1627mkExp (SOp LStdErr []) = return $ mkSystemStd Err
1628mkExp (SOp LFork [arg]) = mkThread arg
1629mkExp (SOp LPar [arg]) = mkExp (SV arg)
1630mkExp (SOp LVMPtr []) =
1631 return $ MethodInv $ TypeMethodCall (J.Name [Ident "Thread"]) [] (Ident "currentThread") []
1632mkExp (SOp LNoOp args) = mkExp . SV $ last args
1633mkExp (SNothing) = return $ Lit Null
1634mkExp (SError err) =
1635 return . MethodInv $
1636 PrimaryMethodCall (InstanceCreation []
1637 runtimeExceptionType
1638 [Lit $ String err]
1639 ( Just $ ClassBody
1640 [ MemberDecl $ MethodDecl [Public, Final]
1641 []
1642 (Just . RefType $ ClassRefType objectType)
1643 (Ident "throwSelf")
1644 []
1645 []
1646 ( MethodBody . Just $
1647 Block [ BlockStmt (Throw This) ]
1652 []
1653 (Ident "throwSelf")
1654 []
1655mkExp other = error (show other)