{-
    Utility for generating GHCJS.Prim.Internal.Build:

        Helpers for constructing objects and arrays that
        can be efficiently inlined as literals.

    Template Haskell is not available in ghcjs-prim, therefore
    this module is generated with this external generator.
 -}

module Main where

import Control.Monad
import Data.List (intercalate)

sizes :: [Int]
sizes = [1..32]

moduleName = "GHCJS.Prim.Internal.Build"

main :: IO ()
main = mapM_ putStr [ genHeader, genExportList, "\n"
                    , genImports, "\n", genDefns, "\n"
                    , genImmutableA, genMutableA
                    , genImmutableO, genMutableO
                    , "\n#endif"
                    ]

genHeader = unlines
  [ "-- helpers for constructing JS objects that can be efficiently inlined as literals"
  , "-- no Template Haskell available yet, generated by utils/genBuildObject.hs"
  , "{-# LANGUAGE CPP #-}"
  , "#ifndef ghcjs_HOST_OS"
  , "module " ++ moduleName ++ " () where"
  , "#else"
  , "{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI, GHCForeignImportPrim #-}"
  , "module " ++ moduleName
  ]

genExportList = unlines $ ("  ( "++e) : map ("  , " ++) es ++ ["  ) where"]
   where
     (e:es) = funs ++ ((\f n -> f ++ show n) <$> funs <*> sizes)
     funs   = ["buildArrayI", "buildArrayM", "buildObjectI", "buildObjectM"]

genImports = unlines
  [ "import GHCJS.Prim"
  , "import GHC.Prim"
  , "import Unsafe.Coerce"
  , "import System.IO.Unsafe"
  ]

genDefns = unlines
  [ "type O = JSVal -- object"
  , "type K = JSVal -- key"
  , "type V = JSVal -- value"
  , "type J = JSVal -- some JS value"
  , "type A = JSVal -- array"
  , ""
  , "seqTupList :: [(a,b)] -> [(a,b)]"
  , "seqTupList xs = go xs `seq` xs"
  , "  where go ((x1,x2):xs) = x1 `seq` x2 `seq` go xs"
  , "        go []           = ()"
  ]

genImmutableA = genBuildA "unsafePerformIO (toJSArray xs)" "I" "A"
genMutableA   = genBuildA "toJSArray xs" "M" "IO A"

genImmutableO = genBuildO "I" "O"
genMutableO   = genBuildO "M" "IO O"

genBuildAL :: String -> String -> String -> String
genBuildAL body m res = unlines $
  [ "foreign import javascript unsafe \"$r = [];\" js_emptyArray"  ++ m ++ " :: " ++ res
  , ""
  , m' ++ " :: [J] -> " ++ res
  , m' ++ " xs = " ++ body
  , "{-# INLINE [1] " ++ m' ++ " #-}"
  , "{-# RULES \"" ++ m' ++ "/empty\" " ++ m' ++ " [] = js_emptyArray" ++ m ++ " #-}"
  ] ++ map mkRule sizes
  where
    mkRule n =
      let vars = map (('x':).show) [1..n]
      in  concat [ "{-# RULES \"", m' ,"/", m', show n, "\" forall "
                 , intercalate " " vars, ". ", m'
                 , " [", intercalate "," vars, "]"
                 , " = ", m', show n, " ", intercalate " " vars, " #-}"
                 ]
    m' = "buildArray" ++ m

genBuildA body n res = unlines $ genBuildAL body n res : map (genBuildA' n res) sizes

genBuildA' :: String -> String -> Int -> String
genBuildA' n res i = genBuild ("buildArray" ++ n ++ show i) imp args sig
  where
    args = intercalate " " $ map (('x':).show) [1..i]
    sig  = join (replicate i ("J -> ")) ++ res
    imp  = '[' : intercalate "," (map (('$':).show) [1..i]) ++ "]"

genBuildOL :: String -> String -> String
genBuildOL m res = unlines $
  [ "foreign import javascript unsafe \"h$buildObjectFromTupList($1)\""
  , "  js_buildObjectFromTupList" ++ m ++ " :: Any -> " ++ res
  , "foreign import javascript unsafe \"$r = {};\" js_emptyObject"  ++ m ++ " :: " ++ res
  , m' ++ " :: [(K,V)] -> " ++ res
  , m' ++ " xs = js_buildObjectFromTupList" ++ m ++ " . unsafeCoerce . seqTupList $ xs"
  , "{-# INLINE [1] " ++ m' ++ " #-}"
  , "{-# RULES \"" ++ m' ++ "/empty\" " ++ m' ++ " [] = js_emptyObject" ++ m ++ " #-}"
  ] ++ map mkRule sizes
  where
    mkRule n =
      let varst = map (\i -> let si = show i in "(k"++si++",v"++si++")") [1..n]
          vars  = concatMap (\i -> let si = show i in ['k':si,'v':si]) [1..n]
      in  concat [ "{-# RULES \"", m' ,"/", m', show n, "\" forall "
                 , intercalate " " vars, ". ", m'
                 , " [", intercalate "," varst, "]"
                 , " = ", m', show n, " ", intercalate " " vars, " #-}"
                 ]
    m' = "buildObject" ++ m

genBuildO n res = unlines $ genBuildOL n res : map (genBuildO' n res) sizes

genBuildO' :: String -> String -> Int -> String
genBuildO' n res i = genBuild ("buildObject" ++ n ++ show i) imp args sig
  where
    imp  = "h$buildObject(" ++ intercalate "," (map (('$':).show) [1..2*i]) ++ ")"
    args = intercalate " " $
           map (\j -> "k" ++ show j ++ " v" ++ show j) [1..i]
    sig  = join (replicate i "K -> V -> ") ++ res

genBuild n imp args sig = unlines
  [ n ++ " :: " ++ sig
  , n ++ " " ++ args ++ " ="
  , "  js_" ++ n ++ " " ++ args
  , "{-# INLINE " ++ n ++ " #-}"
  , ""
  , "foreign import javascript unsafe \"" ++ imp ++ "\""
  , "  js_" ++ n ++ " :: " ++ sig
  , ""
  ]

