content: #!/usr/bin/env runhaskell
  
  {-
  /*
   * Copyright (c) 2011, 2013, Oracle and/or its affiliates. All rights reserved.
   * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
   *
   * This code is free software; you can redistribute it and/or modify it
   * under the terms of the GNU General Public License version 2 only, as
   * published by the Free Software Foundation.  Oracle designates this
   * particular file as subject to the "Classpath" exception as provided
   * by Oracle in the LICENSE file that accompanied this code.
   *
   * This code is distributed in the hope that it will be useful, but WITHOUT
   * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
   * FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
   * version 2 for more details (a copy is included in the LICENSE file that
   * accompanied this code).
   *
   * You should have received a copy of the GNU General Public License version
   * 2 along with this work; if not, write to the Free Software Foundation,
   * Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA.
   *
   * Please contact Oracle, 500 Oracle Parkway, Redwood Shores, CA 94065 USA
   * or visit www.oracle.com if you need additional information or have any
   * questions.
   */
  -}
  {-
  The simplest way to get Haskell is through MacPorts: sudo port install ghc
  
  Otherwise, see http://www.haskell.org/ghc/
  -}
  
  import Data.List
  import Data.Maybe
  import Data.Char
  
  data Width = W32 | W64
               deriving (Show, Eq, Bounded, Enum)
  
  data NType = NBOOL | Nschar | Nuchar | Nsshort | Nushort | Nsint | Nuint
             | Nslong | Nulong | Nslonglong | Nulonglong | Nfloat | Ndouble
               deriving (Show, Eq, Bounded, Enum)
  
  data JPrim = Jboolean | Jbyte | Jchar | Jshort | Jint | Jlong | Jfloat | Jdouble
               deriving (Show, Eq, Bounded, Enum)
  
  data JClass = JBoolean | JByte | JCharacter | JShort | JInteger | JLong
              | JFloat | JDouble
                deriving (Show, Eq, Bounded, Enum)
  
  data FFIType = SINT8 | UINT8 | SINT16 | UINT16 | SINT32 | UINT32
               | SINT64 | UINT64 | FLOAT | DOUBLE
               deriving (Show, Eq, Bounded, Enum)
  
  widths = [minBound..maxBound] :: [Width]
  ntypes = [minBound..maxBound] :: [NType]
  jprims = [minBound..maxBound] :: [JPrim]
  jclasses = [minBound..maxBound] :: [JClass]
  ffitypes = [minBound..maxBound] :: [FFIType]
  
  -- What's the FFIType for a given Width and NType? For example: W32 NBOOL -> SINT8
  ffitype :: Width -> NType -> FFIType
  ffitype _ NBOOL   = SINT8
  ffitype _ Nschar  = SINT8
  ffitype _ Nuchar  = UINT8
  ffitype _ Nsshort = SINT16
  ffitype _ Nushort = UINT16
  ffitype _ Nsint   = SINT32
  ffitype _ Nuint   = UINT32
  ffitype W32 Nslong = SINT32
  ffitype W64 Nslong = SINT64
  ffitype W32 Nulong = UINT32
  ffitype W64 Nulong = UINT64
  ffitype _ Nslonglong = SINT64
  ffitype _ Nulonglong = UINT64
  ffitype _ Nfloat  = FLOAT
  ffitype _ Ndouble = DOUBLE
  
  sizeof :: FFIType -> Int
  sizeof SINT8  = 1
  sizeof UINT8  = 1
  sizeof SINT16 = 2
  sizeof UINT16 = 2
  sizeof SINT32 = 4
  sizeof UINT32 = 4
  sizeof SINT64 = 8
  sizeof UINT64 = 8
  sizeof FLOAT  = 4
  sizeof DOUBLE = 8
  
  -- What's the Obj-C encoding for a given NType? For example: unsigned char -> 'C'
  encoding nt = fromJust $ lookup nt $
                [(NBOOL, 'B'), (Nschar, 'c'), (Nuchar, 'C'), (Nsshort, 's'),
                 (Nushort, 'S'), (Nsint, 'i'), (Nuint, 'I'), (Nslong, 'l'),
                 (Nulong, 'L'), (Nslonglong, 'q'), (Nulonglong, 'Q'),
                 (Nfloat, 'f'), (Ndouble, 'd')]
  
  -- What's the JPrim for a given NType? For example: native signed long long -> java long
  ntype2jprim nt = fromJust $ lookup nt $
                   [(NBOOL, Jboolean), (Nschar, Jbyte), (Nuchar, Jbyte),
                    (Nsshort, Jshort), (Nushort, Jshort), (Nsint, Jint), (Nuint, Jint),
                    (Nslong, Jlong), (Nulong, Jlong),
                    (Nslonglong, Jlong), (Nulonglong, Jlong),
                    (Nfloat, Jfloat), (Ndouble, Jdouble)]
  
  -- What's the JClass for a given JPrim? For example: int -> Integer
  jprim2jclass jp = fromJust $ lookup jp $
                    [(Jboolean, JBoolean), (Jbyte, JByte), (Jchar, JCharacter),
                     (Jshort, JShort), (Jint, JInteger), (Jlong, JLong),
                     (Jfloat, JFloat), (Jdouble, JDouble)]
  
  -- Convert a type to something suitable for Java code. For example: Jboolean -> boolean
  ntype2js nt = tail $ show nt
  jclass2js t = tail $ show t
  jprim2js p = tail $ show p
  ffitype2js f = "FFI_" ++ (show f)
  
  -- Capitalize the first letter of a String
  capitalize [] = []
  capitalize s = [toUpper $ head s] ++ tail s
  
  -- Given an Width and NType, return the Java code for reading said NType from memory.
  popAddr :: Width -> NType -> String
  popAddr _ NBOOL   = "rt.unsafe.getByte(addr) != 0"
  popAddr _ Nschar  = "rt.unsafe.getByte(addr)"
  popAddr _ Nuchar  = "rt.unsafe.getByte(addr)"
  popAddr W32 Nslong = "rt.unsafe.getInt(addr)"
  popAddr W32 Nulong = "rt.unsafe.getInt(addr)"
  popAddr _ ntype = "rt.unsafe.get" ++ (capitalize.jprim2js.ntype2jprim $ ntype) ++ "(addr)"
  
  -- Given an Width and NType, return the Java code for writing said NType to memory.
  pushAddr :: Width -> NType -> String
  pushAddr _ NBOOL   = "rt.unsafe.putByte(addr, (byte) (x ? 1 : 0));"
  pushAddr _ Nschar  = "rt.unsafe.putByte(addr, x);"
  pushAddr _ Nuchar  = "rt.unsafe.putByte(addr, x);"
  pushAddr W32 Nslong = "rt.unsafe.putInt(addr, (int) x);"
  pushAddr W32 Nulong = "rt.unsafe.putInt(addr, (int) x);"
  pushAddr _ ntype = "rt.unsafe.put" ++ (capitalize jprimS) ++ "(addr, (" ++ jprimS ++ ") x);"
      where jprimS = jprim2js.ntype2jprim $ ntype
  
  -- Helpers for generating Java ternarnies and conditionals.
  archExpr x32 x64 = if x32 /= x64 then retdiff else x32
      where retdiff = "(JObjCRuntime.IS64 ? (" ++ x64 ++ ") : (" ++ x32 ++ "))"
  
  archStmt x32 x64 = if x32 /= x64 then retdiff else x32
      where retdiff = "if(JObjCRuntime.IS64){ " ++ x64 ++ " }else{ " ++ x32 ++ " }"
  
  -- Get a Java expression for the correct FFIType at runtime. For example: (JObjCRuntime.IS64 ? FFI_SINT64 : FFI_SINT32)
  ffitypeVal nt = archExpr (ffitype2js $ ffitype W32 nt)
                           (ffitype2js $ ffitype W64 nt)
  
  -- Similar to ffiTypeVal. Get the correct pop expression and push statement.
  popAddrVal nt = archExpr (popAddr W32 nt) (popAddr W64 nt)
  pushAddrVal nt = archStmt (pushAddr W32 nt) (pushAddr W64 nt)
  
  -- What's the Coder class name we're using for a given NType?
  coderName nt = aux nt ++ "Coder"
      where
        aux NBOOL   = "Bool"
        aux Nschar  = "SChar"
        aux Nuchar  = "UChar"
        aux Nsshort = "SShort"
        aux Nushort = "UShort"
        aux Nsint   = "SInt"
        aux Nuint   = "UInt"
        aux Nslong  = "SLong"
        aux Nulong  = "ULong"
        aux Nslonglong   = "SLongLong"
        aux Nulonglong   = "ULongLong"
        aux Nfloat  = "Float"
        aux Ndouble = "Double"
  
  -- Operation for converting between primitives. Usually it just casts, but booleans are special.
  jconvertPrims sym Jboolean Jboolean = sym
  jconvertPrims sym Jboolean b = "((" ++ jprim2js b ++ ")(" ++ sym ++ " ? 1 : 0))"
  jconvertPrims sym a Jboolean = "(" ++ sym ++ " != 0)"
  jconvertPrims sym a b = if a == b then sym else "((" ++ jprim2js b ++ ")" ++ sym ++ ")"
  
  sizeofRet nt =
      let ffitypes = map (\w -> ffitype w nt) widths
          sizes = map sizeof ffitypes in
      if (length $ nub sizes) == 1
      then "\t\treturn " ++ (show.head $ sizes) ++ ";"
      else unlines [
                "\t\tswitch(w){",
                (unlines $ map casestmt widths),
                "\t\tdefault: return -1;",
                 "\t\t}"]
      where
        casestmt w = "\t\t\tcase " ++ (show w) ++ ": return " ++
                     (show.sizeof $ ffitype w nt) ++ ";"
  
  -- Generate a coder class for a given NType.
  c2java ntype =
      unlines [
   "// native " ++ ntypeS ++ " -> java " ++ jprimS,
   "public static final class " ++ className ++ " extends PrimitiveCoder<" ++ jclassS ++ ">{",
   "\tpublic static final " ++ className ++ " INST = new " ++ className ++ "();",
   "\tpublic " ++ className ++ "(){ super("++ffitypeVal ntype++", \"" ++ [encoding ntype] ++ "\", "++jclassS++".class, "++jprimS++".class); }",
   "\t// compile time",
   "\t@Override public void push(JObjCRuntime rt, long addr, " ++ jprimS ++ " x){",
   "\t\t" ++ pushAddrVal ntype,
   "\t}",
   "\t@Override public " ++ jprimS ++ " pop" ++ capitalize jprimS ++ "(JObjCRuntime rt, long addr){",
   "\t\treturn " ++ popAddrVal ntype ++ ";",
   "\t}",
   "\t// for runtime coding",
   "\t@Override public int sizeof(Width w){",
   sizeofRet ntype,
   "\t}",
   "\t@Override public void push(JObjCRuntime rt, long addr, " ++ jclassS ++ " x){ " ++
   "push(rt, addr, (" ++ jprimS ++ ") x); }",
   "\t@Override public " ++ jclassS ++ " pop(JObjCRuntime rt, long addr){ " ++
   "return pop" ++ capitalize jprimS ++ "(rt, addr); }",
   "\t// proxies for mixed encoding",
   makeProxyMethods ntype,
   "}"
   ]
       where
         jprim = ntype2jprim ntype
         jclass = jprim2jclass jprim
         jprimS = jprim2js jprim
         jclassS = jclass2js jclass
         ntypeS = ntype2js ntype
         className = coderName ntype
  
  -- Generate push and pop methods that convert and proxy to actual implementation.
  makeProxyMethods nt = unlines $ map aux jprims
      where
        targetJPrim = ntype2jprim nt
        targetJPrimS = jprim2js targetJPrim
        aux jprim = if targetJPrim == jprim then "" else unlines [
                     "\t@Override public void push(JObjCRuntime rt, long addr, " ++ jprimS ++ " x){ " ++
                     "push(rt, addr, " ++ pushConversion "x" ++ "); }",
                     "\t@Override public " ++ jprimS ++ " pop" ++ capitalize jprimS ++ "(JObjCRuntime rt, long addr){ " ++
                     "return " ++ (popConversion ("pop" ++ capitalize targetJPrimS ++ "(rt, addr)")) ++ "; }"
                    ]
            where
              jprimS = jprim2js jprim
              pushConversion sym = jconvertPrims sym jprim targetJPrim
              popConversion sym = jconvertPrims sym targetJPrim jprim
  
  main = do
    putStrLn "package com.apple.jobjc;"
  
    putStrLn "import com.apple.jobjc.JObjCRuntime.Width;"
  
    putStrLn "// Auto generated by PrimitiveCoder.hs"
    putStrLn "// Do not edit by hand."
  
    putStrLn "public abstract class PrimitiveCoder<T> extends Coder<T>{"
  
    putStrLn "\tpublic PrimitiveCoder(int ffiTypeCode, String objCEncoding, Class jclass, Class jprim){"
    putStrLn "\t\tsuper(ffiTypeCode, objCEncoding, jclass, jprim);"
    putStrLn "\t}"
  
    mapM_ (\p -> putStrLn $ unlines [makePopI p, makePushI p]) jprims
  
    mapM_ (putStrLn . c2java) ntypes
  
    putStrLn "}"
      where
        makePopI jprim = unlines ["\tpublic final " ++ jprim2js jprim ++ " pop" ++ (capitalize.jprim2js $ jprim)
                                     ++ "(NativeArgumentBuffer args){\n"
                                     ++ "\t\treturn pop" ++ (capitalize.jprim2js $ jprim) ++ "(args.runtime, args.retValPtr);\n"
                                     ++ "\t}",
                                  "\tpublic abstract " ++ jprim2js jprim ++ " pop" ++ (capitalize.jprim2js $ jprim) ++ "(JObjCRuntime runtime, long addr);"]
        makePushI jprim = unlines ["\tpublic final void push"
            ++ "(NativeArgumentBuffer args, " ++ jprim2js jprim ++ " x){\n"
            ++ "\t\tpush(args.runtime, args.argValuesPtr, x);\n"
            ++ "\t\targs.didPutArgValue(sizeof());\n"
            ++ "\t}",
          "\tpublic abstract void push(JObjCRuntime runtime, long addr, " ++ jprim2js jprim ++ " x);"]
  