futhask-1.0.0: src/CodeGen.hs

{-# LANGUAGE OverloadedStrings #-}
--{-# LANGUAGE PatternSynonyms #-}
--{-# LANGUAGE ViewPatterns #-}

module CodeGen where

import Futhark.Manifest
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Data.Text.Encoding as T
import qualified Data.ByteString as B
import qualified Data.Char as C
import qualified Data.Map.Strict as M
import Text.ParserCombinators.ReadP as P
import Debug.Trace

readManifest :: FilePath -> IO Manifest
readManifest path = B.readFile path >>= \bs -> case (manifestFromJSON $ T.decodeUtf8 bs) of
    Just manifest -> return manifest
    Nothing -> error "Invalid manifest file"

writeText path = B.writeFile path . T.encodeUtf8
putText = T.putStrLn


--Futhark to Haskell
futhaskTypeMap :: M.Map Text Text
futhaskTypeMap = M.fromList
    [ ("f16", "F16")
    , ("f32", "F32")
    , ("f64", "F64")
    , ("bool", "CBool")
    , ("i8" , "I8")
    , ("i16", "I16")
    , ("i32", "I32")
    , ("i64", "I64")
    , ("u8" , "U8")
    , ("u16", "U16")
    , ("u32", "U32")
    , ("u64", "U64") ]

primitive = 
    [ "f16"
    , "f32"
    , "f64"
    , "bool"
    , "i8" 
    , "i16"
    , "i32"
    , "i64"
    , "u8" 
    , "u16"
    , "u32"
    , "u64" ]

isPrimitive a = elem a primitive
isBool a = a == "bool"

haskellElemType :: TypeName -> Text
haskellElemType ft = case M.lookup ft futhaskTypeMap of
    Just ht -> ht
    Nothing -> error (T.unpack ft <> " is not a valid element type")

haskellType :: TypeName -> Text
haskellType ft = case M.lookup ft futhaskTypeMap of
    Just ht -> ht
    Nothing -> reformatTypeName ft

rawHaskellType :: TypeName -> Text
rawHaskellType ft = case M.lookup ft futhaskTypeMap of
    Just ht -> ht
    Nothing -> pointer (raw $ reformatTypeName ft)

rawOutputType output = if M.member (outputType output) futhaskTypeMap
                            then pointer (haskellType $ outputType output)
                            else pointer $ pointer (raw $ haskellType (outputType output))

rawInputType input = if M.member (inputType input) futhaskTypeMap
                            then (haskellType $ inputType input)
                            else pointer (raw $ haskellType (inputType input))
--C to Haskell
chaskTypeMap = M.fromList
    [ ("int", "Int")
    , ("float", "Float")
    , ("double", "Double")
    , ("char", "CChar")
    , ("unsigned char", "CUChar")
    , ("bool", "CBool")
    , ("void", "()")
    , ("int8_t" , "Int8")
    , ("int16_t", "Int16")
    , ("int32_t", "Int32")
    , ("int64_t", "Int64")
    , ("uint8_t" , "Word8")
    , ("uint16_t", "Word16")
    , ("uint32_t", "Word32")
    , ("uint64_t", "Word64")
    , ("size_t", "CSize")
    , ("FILE", "CFile")
    , ("cl_mem", "CLMem")
    , ("cl_command_queue", "CLCommandQueue")
    , ("CUdeviceptr", "DevicePtr ()") ]


csize = "CSize"
cbyte = "CChar"

capitalize t = case T.uncons t of
    Nothing -> t
    Just (i, r) -> T.cons (C.toUpper i) r

decapitalize t = case T.uncons t of
    Nothing -> t
    Just (i, r) -> T.cons (C.toLower i) r

-- bad conversion, needs improvement
markdown2haddock t = T.replace "`" "@" $ t
comment t = case T.lines (markdown2haddock t) of
    [] -> ""
    (l:ls) -> T.unlines $ map ("-- " <>) $ ("|" <> l : ls)

hcomment t = "-- *" <> t <> "\n"
codecomment t = "-- | @" <> t <> "@\n"
indent :: Text -> Text
indent = T.unlines . (map ("  " <>)) . T.lines

commaSep = T.intercalate ", "
arrowSep = T.intercalate " -> "
wrap t = "(" <> t <> ")"

tuple :: [Text] -> Text
tuple elements = wrap (commaSep elements)
strictTuple = tuple . map ("!"<>)  


wrapIfNotOneWord t = if length (T.words t) == 1 then t else wrap t
wrapIfNotTupleOrPrimitive t s = if isPrimitive t then s else if isTuple t then s else wrap s
wrapIfNotWrappedOrSingleton s = if (T.head s == '(' && T.last s == ')') || length (T.words s) == 1 then s else wrap s
    
raw t = "Raw." <> t
wrapped t = "Wrapped." <> t
(<->) a b = a <> "_" <> b
(<~>) a b = a <> " " <> b
(<=>) a b = a <> " = " <> b
(</>) a b = a <> "\n" <> b
(</~>) a b = a <> "\n  " <> b


pointer t = "Ptr " <> wrapIfNotOneWord t
void = "()"

unpacked t = "{-# UNPACK #-}!(" <> t <> ")"

data CompositeType = SimpleType Text | ArrayType Int CompositeType | TupleType [CompositeType] | RecordType [(String, CompositeType)] | SumType [(String, [CompositeType])] deriving Show
formatCompositeType :: CompositeType -> Text
formatCompositeType (SimpleType name) = capitalize name
formatCompositeType (ArrayType rank elem) = "Arr" <> T.pack (show rank) <-> formatCompositeType elem
formatCompositeType (TupleType fields) = if length fields == 0 then "Unit" else
    "Tup" <> T.pack (show (length fields)) <-> T.intercalate "_" (map formatCompositeType fields)
formatCompositeType (RecordType fields) =
    "Rec" <> T.pack (show (length fields)) <-> T.intercalate "_" (map (\(n, t) -> T.pack n <-> formatCompositeType t) fields)
formatCompositeType (SumType variants) = "Sum" <> T.pack (show (length variants)) <-> T.intercalate "_" (map (\(c, ps) -> T.pack c <-> T.intercalate "_" (map formatCompositeType ps)) variants) 

haskellEquivType :: CompositeType -> Text
haskellEquivType (SimpleType t) = haskellType t
haskellEquivType (ArrayType rank elem) = if rank > 0 then "Array " <> wrapIfNotWrappedOrSingleton (haskellEquivType (ArrayType (rank-1) elem)) else haskellEquivType elem
haskellEquivType (TupleType fields) = tuple (map haskellEquivType fields)
haskellEquivType (RecordType fields) = formatCompositeType(RecordType fields)
haskellEquivType (SumType variants) = formatCompositeType (SumType variants)


readDigit = fmap C.digitToInt (P.satisfy C.isDigit)
readTuple readElem = do
    P.char '(' 
    elems <- P.sepBy readElem (skipSpaces >> P.char ',' >> skipSpaces)
    P.char ')'
    pure elems
readRecord readFieldType = do
    P.char '{'
    fields <- P.sepBy readField (skipSpaces >> P.char ',' >> skipSpaces)
    P.char '}'
    pure fields
    where 
        readField = do
            skipSpaces
            n <- P.munch1 (/= ':')
            skipSpaces
            P.char ':'
            skipSpaces
            t <- readFieldType
            pure (n, t)


readCompositeType :: P.ReadP CompositeType
readCompositeType = do
    skipSpaces 
    get >>= \c -> case c of
        '(' -> P.sepBy readCompositeType (P.char ',' >> skipSpaces) >>= \m -> char ')' >> pure (if length m == 1 then head m else TupleType m) 
        '{' -> P.sepBy 
                    (P.munch (/=':') >>= \n -> char ':' >> P.skipSpaces >> readCompositeType >>= \t -> pure (n, t)) 
                    (P.char ',' >> P.skipSpaces) 
            >>= \m -> char '}' >> pure (RecordType m)
        '[' -> P.munch (\c -> elem c ("[]" :: String)) >>= \p -> readCompositeType >>= \elem -> pure (ArrayType (div (length p + 1) 2) elem) 
        '#' -> P.sepBy 
            (P.munch (/=' ') >>= \cons -> P.sepBy readCompositeType (P.char ' ') >>= \payloads -> pure (cons, payloads)) 
            (P.string " | #")
            >>= \cps -> pure (SumType cps) 
        _   -> P.munch (\c -> not $ elem c (" ()[]{},#|"::String)) >>= \cs -> pure (SimpleType (T.pack (c:cs)))
    where
        char c = P.char c >>= \_ -> pure ()


parseCompositeType :: TypeName -> CompositeType
parseCompositeType n = case (P.readP_to_S (readCompositeType >>= \t -> P.eof >> pure t) $ T.unpack n) of
    [] -> error (T.unpack ("unable to parse type: " <> n))
    (a:_) -> fst a
parseCompositeType' = fst . head . P.readP_to_S readCompositeType

reformatTypeName = formatCompositeType . parseCompositeType
reformatTypeName' = T.unpack . formatCompositeType . parseCompositeType . T.pack

nativeType :: TypeName -> Text
nativeType = haskellEquivType . parseCompositeType
isTuple t = case parseCompositeType t of
    (TupleType _) -> True
    _ -> False

type Constraint = Text

assignment :: Text -> Text -> Text
assignment a b = a <> " = " <> b <> "\n"

sumFormat :: TypeName -> [(Text, [TypeName])] -> Text
sumFormat name constructors
    =  "data " <> name <> "\n"
    <> indent ("= " <> T.intercalate "\n| " (map (\(c, as) -> T.unwords (c:as)) constructors) <> "\n")
    <> "\n"
sumFormat' :: TypeName -> [(Text, [TypeName])] -> Text
sumFormat' name constructors
    =  "data " <> name <> "\n"
    <> indent ("= " <> T.intercalate "\n| " (map (\(c, as) -> T.unwords (c:as)) constructors) <> "\n")
    <> "  deriving Show\n"
    <> "\n"
    


recFormat :: TypeName -> [(Text, TypeName)] -> Text
recFormat name fields
    =  "data " <> name <> " = " <> name <> "\n"
    <> indent ("{ " <> T.intercalate "\n, " (map (\(f, t) -> f <> " :: " <> t) fields) <> " }\n")
    <> "\n"
recFormat' :: TypeName -> [(Text, TypeName)] -> Text
recFormat' name fields
    =  "data " <> name <> " = " <> name <> "\n"
    <> indent ("{ " <> T.intercalate "\n, " (map (\(f, t) -> f <> " :: " <> t) fields) <> " } deriving Show\n")
    <> "\n"
qrecFormat :: TypeName -> [(Text, TypeName)] -> Text
qrecFormat name fields
    =  "data " <> name <> " c = " <> name <> "\n"
    <> indent ("{ " <> T.intercalate "\n, " (map (\(f, t) -> f <> " :: " <> t) fields) <> " }\n")
    <> "\n"

typeFormat :: TypeName -> TypeName -> Text
typeFormat nt ot
    = "type " <> nt <> " = " <> ot <> "\n"
qtypeFormat :: TypeName -> TypeName -> Text
qtypeFormat nt ot
    = "type " <> nt <> " c = " <> ot <> "\n"
newtypeFormat :: TypeName -> TypeName -> Text
newtypeFormat nt ot
    = "newtype " <> nt <> " = " <> nt <~> ot <> "\n"
newtypeFormat' :: TypeName -> TypeName -> Text
newtypeFormat' nt ot
    = "newtype " <> nt <> " = " <> nt <~> ot <~> "deriving Show\n"
qnewtypeFormat :: TypeName -> TypeName -> Text
qnewtypeFormat nt ot
    = "newtype " <> nt <> " c = " <> nt <~> ot <> "\n"

caseFormat :: Text -> [(Text, Text)] -> Text
caseFormat expression cases
    =  "case " <> expression <> " of\n"
    <> indent (mconcat (map (\(pattern, result) -> pattern <~> "->" <~> result <> "\n") cases))

functionFormat :: Text -> TypeName -> [(Text, TypeName, [Constraint])] -> Text -> Text
functionFormat name outputType arguments body
    =  name
    <> " :: "
    <> tuple (concatMap (\(_, t, cs) -> (map (\c -> c <~> t) cs) ) arguments)
    <> " => "
    <> arrowSep ( (map (\(_, t, _) -> t) arguments) <> [outputType])
    <> "\n"
    <> name
    <> mconcat (map (\(n, _, _) -> " " <> n) arguments)
    <> " = \n"
    <> indent body
    <> "\n"


classFormat :: Text -> [(TypeName, [Constraint])] -> [([Text], Text)] -> [(Text, TypeName, [TypeName])] -> Text
classFormat name parameters dependencies methods
    = "class "
    <> tuple (concatMap (\(t, cs) -> (map (\c -> c <> " " <> t) cs) ) parameters)
    <> " => "
    <> name
    <> " "
    <> T.unwords (map fst parameters)
    <> if dependencies == []
        then ""
        else " | " <> commaSep (map (\(ts, t) -> T.unwords ts <> " -> " <> t) dependencies)
    <> " where"
    <> "\n"
    <> indent (mconcat $ map (\(n,t,ats) -> n <> " :: " <> arrowSep (ats <> [t]) <> "\n") methods)
    <> "\n"

instanceFormat :: Text -> [(TypeName, [Constraint])] -> [Text] -> Text
instanceFormat className instanceTypes methods
    =  "instance "
    <> className
    <> " "
    <> T.unwords (map fst instanceTypes)
    <> " where"
    <> "\n"
    <> indent (mconcat methods)
    <> "\n"

cFFICall :: Text -> CFuncName -> [Text] -> Text -> Text
cFFICall name cfunc argTypes returnType
    = "foreign import ccall unsafe \"" <> cfunc <> "\""
    <> "\n  "
    <> decapitalize name
    <> "\n    :: "
    <> mconcat (map (<> "\n    -> ") argTypes)
    <> "IO " <> wrapIfNotOneWord returnType
    <> "\n"


withCtxCall outformat fun inputTypes outputTypes = "" 
            <> mconcat (zipWith (\i t -> if isPrimitive t
                then "" 
                else "    -> withRawObject in" <> i <> " $ \\in" <> i <> "'\n") inputNums inputTypes)
            <> mconcat (map (\i -> "    -> alloca $ \\outptr" <> i <> "\n") outputNums)
            <> "    -> inContextWithError ctx (\\ctx'\n"
            <> "    -> " <> fun <> " ctx' "
            <> T.unwords (map ("outptr" <>) outputNums) 
            <> " "
            <> T.unwords (zipWith (\i t -> if isPrimitive t
                then "in" <> i 
                else "in" <> i <> "'") inputNums inputTypes) <> ")\n"
            <> "    >> "
            <> mconcat (zipWith (\i t -> "peek outptr" <> i <>  " >>= wrap" <> (if isPrimitive t then "" else "FO") <~> "ctx >>= \\out" <> i <> "\n    -> ") outputNums outputTypes)
            <> "pure" <~> outformat (map ("out" <>) outputNums) <> "\n"
    where 
        inputNums = zipWith (\i _ -> T.pack (show (i::Int))) [0..] inputTypes 
        outputNums = zipWith (\i _ -> T.pack (show (i::Int))) [0..] outputTypes 
futCall fun inputTypes outputTypes = "unsafeLiftFromIO $ \\ctx\n" <> withCtxCall tuple fun inputTypes outputTypes
rawContextType :: Text
rawContextType = "C.Context"
contextPointer = pointer rawContextType

rawEntryCall :: Text -> EntryPoint -> Text
rawEntryCall name entry = cFFICall name (entryPointCFun entry) argTypes "Int"
    where
        argTypes = contextPointer
                 : (rawOutputType $ entryPointOutput entry)
                 : (map rawInputType $ entryPointInputs entry)
packTuple manifest t = pack t
    where
        inContext f args = "inContextWithError ctx (\\ctx -> " <> f <> " ctx " <> T.unwords args <> ")"
        outputInContext f args = "alloca (\\ptr -> " <> inContext f ("ptr":args) <> " >> peek ptr)"
        subtypes t = case M.lookup t (manifestTypes manifest) of
            Just (TypeOpaque _ _ (Just (OpaqueRecord ops)) _) -> map recordFieldType (recordFields ops)
            _ -> error "nontuple type"
        subargs t = zipWith (\i _ -> "t" <> T.pack (show i)) [0..] (subtypes t) 
        pack t = let as = subargs t 
            in "(\\" <> tuple as <> "\n"
            <> indent ( "  -> " 
            <> mconcat (zipWith (\st a -> if isPrimitive st 
                    then "" 
                    else if isTuple st 
                        then pack st <~> a <> " >>= \\" <> a <> "\n  -> " 
                        else "withRawObject " <> a <> " $ \\" <> a <> "\n  -> ") 
                (subtypes t) as) 
            <> outputInContext ("Raw.new_" <> reformatTypeName t) as <> " >>= \\t\n  -> " 
            <> mconcat (zipWith (\t a -> if isTuple t 
                    then inContext ("Raw.free_" <> reformatTypeName t) [a] <> "\n  >> " 
                    else "") 
                (subtypes t) as) 
            <> "pure t) " )
unpackTuple manifest t = unpack t
    where
        inContext f args = "inContextWithError ctx (\\ctx -> " <> f <> " ctx " <> T.unwords args <> ")"
        outputInContext f args = "alloca (\\ptr -> " <> inContext f ("ptr":args) <> " >> peek ptr)"
        subtypes t = case M.lookup t (manifestTypes manifest) of
            Just (TypeOpaque _ _ (Just (OpaqueRecord ops)) _) -> map recordFieldType (recordFields ops)
            _ -> error "nontuple type"
        subargs t = zipWith (\i _ -> "t" <> T.pack (show i)) [0..] (subtypes t) 
        unpack t = let as = subargs t
            in "(\\t\n" 
            <> indent ( "  -> " 
            <> mconcat (zipWith3 (\a st i -> outputInContext ("Raw.project" <-> reformatTypeName t <-> T.pack (show i)) ["t"] 
                <> (if isTuple st 
                    then "\n  >>= " <> unpack st 
                    else (if isPrimitive st then "" else " >>= wrapFO ctx")) 
                    <> "  >>= \\" <> a <> "\n  -> ") 
                as (subtypes t) [0..]) 
            <> inContext ("Raw.free" <-> reformatTypeName t) ["t"] <> "\n  >> pure " <> tuple as <> ") " )

packTuple' manifest t = pack t
    where
        inContext f args = "C.inContextWithError ctx (\\ctx -> " <> f <> " ctx " <> T.unwords args <> ")"
        outputInContext f args = "F.alloca (\\ptr -> " <> inContext f ("ptr":args) <> " >> F.peek ptr)"
        subtypes t = case M.lookup t (manifestTypes manifest) of
            Just (TypeOpaque _ _ (Just (OpaqueRecord ops)) _) -> map recordFieldType (recordFields ops)
            _ -> error "nontuple type"
        subargs t = zipWith (\i _ -> "t" <> T.pack (show i)) [0..] (subtypes t) 
        pack t = let as = subargs t 
            in "(\\" <> tuple as <> "\n"
            <> indent ( "  -> " 
            <> mconcat (zipWith (\st a -> if isPrimitive st 
                    then if isBool st
                        then "pure (F.fromBool " <> a <> ") >>= \\" <> a <> "\n  -> "
                        else ""
                    else if isTuple st 
                        then pack st <~> a <> " >>= \\" <> a <> "\n  -> " 
                        else "O.withRawObject " <> a <> " $ \\" <> a <> "\n  -> ") 
                (subtypes t) as) 
            <> outputInContext ("Raw.new_" <> reformatTypeName t) as <> " >>= \\t\n  -> " 
            <> mconcat (zipWith (\t a -> if isTuple t 
                    then inContext ("Raw.free_" <> reformatTypeName t) [a] <> "\n  >> " 
                    else "") 
                (subtypes t) as) 
            <> "pure t) " )
unpackTuple' manifest t = unpack t
    where
        inContext f args = "C.inContextWithError ctx (\\ctx -> " <> f <> " ctx " <> T.unwords args <> ")"
        outputInContext f args = "F.alloca (\\ptr -> " <> inContext f ("ptr":args) <> " >> F.peek ptr)"
        subtypes t = case M.lookup t (manifestTypes manifest) of
            Just (TypeOpaque _ _ (Just (OpaqueRecord ops)) _) -> map recordFieldType (recordFields ops)
            _ -> error "nontuple type"
        subargs t = zipWith (\i _ -> "t" <> T.pack (show i)) [0..] (subtypes t) 
        unpack t = let as = subargs t
            in "(\\t\n" 
            <> indent ( "  -> " 
            <> mconcat (zipWith3 (\a st i -> outputInContext ("Raw.project" <-> reformatTypeName t <-> T.pack (show i)) ["t"] 
                <> (if isTuple st 
                    then "\n  >>= " <> unpack st 
                    else (if isPrimitive st then if isBool st then ">>= pure . F.toBool" else "" else " >>= O.wrapFO ctx")) 
                    <> "  >>= \\" <> a <> "\n  -> ") 
                as (subtypes t) [0..]) 
            <> inContext ("Raw.free" <-> reformatTypeName t) ["t"] <> "\n  >> pure " <> tuple as <> ") " )

wrappedEntryCall manifest name entry 
    = (doc <> typeDec <> "\n", pragma <> callDec <> "\n")
    where 
        doc = comment $ "`" <> futtype <> "`" <> case entryPointDoc entry of
            Nothing -> ""
            Just d -> "\n\n" <> d
        inputs = entryPointInputs entry
        output = entryPointOutput entry
        subtypes t = case M.lookup t (manifestTypes manifest) of
            Just (TypeOpaque _ _ (Just (OpaqueRecord ops)) _) -> map recordFieldType (recordFields ops)
            _ -> error "nontuple type"
        subargs t = zipWith (\i _ -> "t" <> T.pack (show i)) [0..] (subtypes t) 
        name' = decapitalize name
        futtype = name 
            <~> T.unwords (map (\i -> "(" <> inputName i <> " : " <> (if inputUnique i then "*" else "") <> inputType i <> ")") inputs) 
            <> " : " <> outputType output
        tuningDec = let ps = entryPointTuningParams entry in if length ps == 0 
            then ""
            else comment $ "tuning parameters:\n" <> mconcat (map (\t -> " - " <> t <> "\n") ps) 
        attributeDec = let as = entryPointAttrs entry in if length as == 0 
            then "" 
            else comment $ "attributes:\n" <> mconcat (map (\t -> " - " <> t <> "\n") as)
        typeDec = name' <> " :: " <> (if any inputUnique inputs then "MonadIO" else "Monad") <> " m\n  => " 
            <> mconcat (map (\i -> typeDec' (inputType i) <> " -- ^" <> inputName i <> "\n  -> " ) inputs) 
            <> "M.FutT c m " 
            <> (let ot = outputType output in if isTuple ot 
                then typeDec' ot 
                else wrapIfNotOneWord (typeDec' ot)) 
            <> "\n"
        typeDec' t = if isTuple t 
                then tuple (map typeDec' (subtypes t))
                else reformatTypeName t <> (if isPrimitive t then "" else " c")
        pragma = "{-# NOINLINE " <> name <> " #-}\n"
        callDec = name' <~> T.unwords args <> " = M.unsafeLiftFromIO (\\ctx\n  -> " 
            <> mconcat (zipWith prepareInput inputs args) 
            <> callRaw 
            <> processOutput 
            <> cleanup 
            <> "C.sync ctx >> pure res)" 
            <> if any inputUnique inputs 
                then " >>= \\res\n  -> " <> freeuniqueinputs <> "pure res\n"
                else "\n"
        args = zipWith (\i _ -> "arg" <> T.pack (show i)) [0..] inputs
        prepareInput i a = let t = inputType i in if isPrimitive t 
            then if isBool t 
                then "pure (F.fromBool " <> a <> ") >>= \\" <> a <> "\n  -> "
                else "" 
            else if isTuple t 
                then packTuple' manifest t <~> a <> " >>= \\" <> a <> "\n  -> " 
                else "O.withRawObject" <~> a <~> "$ \\" <> a <> "\n  -> "

        processOutput = let t = outputType output in if isPrimitive t 
            then if isBool t
                then " >>= pure . F.toBool >>= \\res\n  -> "
                else " >>= \\res\n  -> "
            else if isTuple t
                then "\n  >>= " <> unpackTuple' manifest t <> "  >>= \\res\n  -> " 
                else "\n  >>= O.wrapFO ctx >>= \\res\n  -> "
        inContext f args = "C.inContextWithError ctx (\\ctx -> " <> f <> " ctx " <> T.unwords args <> ")"
        outputInContext f args = "F.alloca (\\ptr -> " <> inContext f ("ptr":args) <> " >> F.peek ptr)"
        cleanup = mconcat (zipWith (\i a -> if isTuple (inputType i) 
            then inContext ("Raw.free_" <> reformatTypeName (inputType i))   [a] <> "\n  >> " else "") inputs args)
        freeuniqueinputs = mconcat (zipWith (\i a -> if inputUnique i 
            then finalizeValue a (inputType i)
            else "" ) inputs args)
        finalizeValue n t = if isPrimitive t 
            then ""
            else if isTuple t 
                then 
                    let as = subargs t 
                    in "(\\" <> tuple as <> "\n"
                    <> indent ( "  -> " 
                    <> mconcat (zipWith finalizeValue as (subtypes t)) 
                    <> "pure () ") 
                    <> ") " <> n <> "\n  >> "
                else "O.finalizeFO " <> n <> "\n  >> "
        callRaw = outputInContext ("RawEntry." <> name) args

rawTypeDec :: Text -> Type -> Text
rawTypeDec name _ = codecomment name <> "\n" <> "data" <~> reformatTypeName name <> "\n\n"

wrappedTypeDec :: Text -> Type -> Text
wrappedTypeDec name _ = if isTuple name then "" else 
    let name' = reformatTypeName name
    in codecomment name <> "\n"
    <> "data " <> name' <>  " c = " <> name' <~> unpacked "Futhask.ReferenceCounter" <~> unpacked ("F.ForeignPtr" <~> raw name') <> "\n"
    <> "\n"
unpackedType manifest t = if isPrimitive t 
    then reformatTypeName t 
    else if isTuple t 
        then tuple (map (unpackedType manifest) (subtypes t))
        else "Packed." <> reformatTypeName t <~> "c"
    where
        subtypes t = case M.lookup t (manifestTypes manifest) of
            Just (TypeOpaque _ _ (Just (OpaqueRecord ops)) _) -> map recordFieldType (recordFields ops)
            _ -> error "nontuple type"

unpackedTypeDec manifest name (TypeOpaque ctype ops mExtraOps doc) = dec
    where 
        dec = case mExtraOps of 
            Just (OpaqueSum ops) -> unpackedSumDec manifest name ops
            Just (OpaqueRecord ops) -> unpackedRecordDec manifest name ops
            Just (OpaqueRecordArray ops) -> unpackedRecordArrayDec manifest name ops
            _ -> ""

unpackedTypeDec manifest name _ = ""
unpackedSumDec manifest name ops = codecomment name <> sumFormat (reformatTypeName name <~> "c") (map variant $ sumVariants ops)
    where 
        variant v = (reformatTypeName name <-> sumVariantName v, map (\p -> wrapIfNotTupleOrPrimitive p (unpackedType manifest p)) $ sumVariantPayload v)

                
unpackedRecordDec manifest name ops = if length fields == 0 then "" else if isTuple'
    then if isTuple name 
        then ""
        else codecomment name <> qnewtypeFormat name' (tuple (map snd fields)) <> "\n"
    else codecomment name <> qrecFormat name' fields
    where
        name' = reformatTypeName name 
        isTuple' = fst (fields !! 0) == "0"
        fields = map (\f -> (recordFieldName f, unpackedType manifest (recordFieldType f))) $ recordFields ops

unpackedRecordArrayDec manifest name ops = if isTuple'
    then codecomment name <> qnewtypeFormat name' (tuple (map snd fields)) <> "\n" 
    else codecomment name <> qrecFormat name' fields <> "\n" 
    where
        isTuple' = fst (fields !! 0) == "0"
        name' = reformatTypeName name 
        fields = map (\f -> (recordFieldName f, unpackedType manifest (recordFieldType f))) $ recordArrayFields ops
      
objectInstance name = instanceFormat "FutharkObject" [(wname,[])] [rawDec, contextDec, freeDec, wrapDec, pointerDec, counterDec]
    where
        name' = reformatTypeName name
        wname = wrapped name'
        constructor = wname
        rawDec = typeFormat ("RawObject" <~> wname) (raw name')
        contextDec = typeFormat ("ObjectContext" <~> wname) "C.Context"
        freeDec = assignment "freeRawObject" (raw "free" <-> name')
        wrapDec = assignment "wrapRawObject"  constructor
        pointerDec = assignment ("objectPointer (" <> constructor <> " _ ptr)") "ptr"
        counterDec = assignment ("objectCounter (" <> constructor <> " ctr _)") "ctr"

sumCompositeInstance manifest name ops = instanceFormat "FutharkComposite" [(wname,[])] [unpackedDec, packDec, unpackDec]
    where
        name' = reformatTypeName name
        wname = wrapped name'
        uname = "Unpacked." <> name'
        unpackedDec = typeFormat ("Unpacked" <~> wname) uname
        payloadid variant = zipWith (\i _ -> "p" <> T.pack (show i)) [0..] (sumVariantPayload variant)
        payloadtypes variant = sumVariantPayload variant
        packDec = "pack unpacked = unsafeLiftFromIO $ \\ctx\n -> case unpacked of\n" 
            <> indent (mconcat (map packVariant (sumVariants ops)))
        unpackDec = "unpack sum = unsafeLiftFromIO $ \\ctx\n -> "
            <> "withRawObject sum $ \\sum -> "
            <> "inContext ctx (\\ctx -> Raw.variant_" <> name' <> " ctx sum)" <> " >>= \\variant -> case variant of\n" 
            <> indent (mconcat (zipWith unpackVariant [0..] (sumVariants ops)))
        packVariant variant = "Unpacked." <> name' <-> sumVariantName variant <~> T.unwords (payloadid variant) <> " ->\n" 
            <> indent ( ""
                <> mconcat (zipWith prepareInput (payloadtypes variant) (payloadid variant))
                <> outputInContext ("Raw.construct" <-> name' <-> sumVariantName variant) (payloadid variant)
                <> "\n  >>= wrapFO ctx >>= \\packed\n  -> "
                <> mconcat (zipWith (\t id -> if isTuple t
                    then inContext ("Raw.free_" <> reformatTypeName t) [id] <> "\n  >> "
                    else "") (payloadtypes variant) (payloadid variant))
                <> "pure packed\n" 
            )

        unpackVariant i variant = T.pack (show i) <> " -> "
            <> mconcat (map (\a -> "alloca $ \\" <> a <> "\n  -> ") (payloadid variant))
            <> inContext ("Raw.destruct" <-> name' <-> sumVariantName variant) (payloadid variant ++ ["sum"]) <> "\n  >> "
            <> mconcat (zipWith (\t a -> "peek " <> a <> processOutput t a) (payloadtypes variant) (payloadid variant))
            <> "pure (" <> "Unpacked." <> name' <-> sumVariantName variant <~> T.unwords (payloadid variant) <> ")\n"
        inContext f args = "inContextWithError ctx (\\ctx -> " <> f <> " ctx " <> T.unwords args <> ")"
        outputInContext f args = "alloca (\\ptr -> " <> inContext f ("ptr":args) <> " >> peek ptr)"
        prepareInput t a = if isPrimitive t 
            then "" 
            else if isTuple t 
                then packTuple manifest t <~> a <> " >>= \\" <> a <> "\n  -> " 
                else "withRawObject" <~> a <~> "$ \\" <> a <> "\n  -> "
        processOutput t a = if isPrimitive t 
            then " >>= \\" <> a <> "\n  -> "
            else if isTuple t
                then "\n  >>= " <> unpackTuple manifest t <> "  >>= \\" <> a <> "\n  -> " 
                else "\n  >>= wrapFO ctx >>= \\"<> a <>"\n  -> "

recordCompositeInstance manifest name fields isArr = instanceFormat "FutharkComposite" [(wname,[])] [unpackedDec, packDec, unpackDec]
    where
        name' = reformatTypeName name
        wname = wrapped name'
        uname = "Unpacked." <> name'
        packfun = if isArr then "zip" else "new"
        unpackedDec = typeFormat ("Unpacked" <~> wname) uname
        isTuple' = recordFieldName (fields !! 0) == "0"
        nums = zipWith (\i _ -> T.pack (show (i::Int))) [0..] fields
        fieldid = map ("f"<>) nums
        fieldtypes = map recordFieldType fields
        fieldnames = map recordFieldName fields
        pattern = if isTuple' then tuple fieldid else T.unwords fieldid
        packDec = "pack (" <> uname <~> pattern <> ") = unsafeLiftFromIO $ \\ctx\n  -> " 
            <> mconcat (zipWith prepareInput fieldtypes fieldid)
            <> outputInContext ("Raw." <> packfun <-> name') fieldid
            <> "\n  >>= wrapFO ctx >>= \\packed\n  -> "
            <> mconcat (zipWith (\t id -> if isTuple t
                then inContext ("Raw.free_" <> reformatTypeName t) [id] <> "\n  >> "
                else "") fieldtypes fieldid )
            <> "pure packed\n" 
        
        unpackDec =  "unpack packed = unsafeLiftFromIO $ \\ctx\n  -> " 
            <> "withRawObject packed" <~> "$ \\packed\n  -> " 
            <> mconcat (zipWith3 (\n t id -> outputInContext ("Raw.project" <-> name' <-> n) ["packed"] <> processOutput t id) 
                fieldnames fieldtypes fieldid)
            <> "pure (" <> uname <~> pattern <> ")\n" 

        inContext f args = "inContextWithError ctx (\\ctx -> " <> f <> " ctx " <> T.unwords args <> ")"
        outputInContext f args = "alloca (\\ptr -> " <> inContext f ("ptr":args) <> " >> peek ptr)"
        prepareInput t a = if isPrimitive t 
            then "" 
            else if isTuple t 
                then packTuple manifest t <~> a <> " >>= \\" <> a <> "\n  -> " 
                else "withRawObject" <~> a <~> "$ \\" <> a <> "\n  -> "
        processOutput t a = if isPrimitive t 
            then " >>= \\" <> a <> "\n  -> "
            else if isTuple t
                then "\n  >>= " <> unpackTuple manifest t <> "  >>= \\" <> a <> "\n  -> " 
                else "\n  >>= wrapFO ctx >>= \\"<> a <>"\n  -> "
arrayInstance name futelem rank 
    =  instanceFormat "FutIndexable" [(wname,[])] [rankDec]
    <> instanceFormat "FutharkPrimArray'" [(wname,[]), ("C.Context",[]), (rank',[]), (elem',[])] [elemDec, shapeDec, valuesDec, newDec, indexDec]
     where
        name' = reformatTypeName name
        wname = wrapped name'
        rank' = "R" <> T.pack (show rank)
        elem' = haskellElemType futelem
        rankDec = typeFormat ("FutRank" <~> wname) rank'
        elemDec = typeFormat ("PrimElem" <~> wname) elem'
        newDec = assignment "newFPA" (raw "newArray" <-> name')
        shapeDec = assignment "shapeFPA" (raw "shape" <-> name')
        valuesDec = assignment "valuesFPA" (raw "values" <-> name')
        indexDec = assignment "indexFPA" (raw "index" <-> name')

opaqueInstance name = instanceFormat "FutharkOpaque" [(wname,[])] [storeDec, restoreDec]
    where
        name' = reformatTypeName name
        wname = wrapped name'
        storeDec = assignment "storeOpaque" (raw "store" <-> name')
        restoreDec = assignment "restoreOpaque" (raw "restore" <-> name')

--wrappedTypeOps :: Text -> Type -> Text
wrappedTypeOps manifest name (TypeArray ctype futelem rank ops) = objectInstance name <> arrayInstance name futelem rank
wrappedTypeOps manifest name (TypeOpaque ctype ops mExtraOps doc) = if isTuple name 
    then "" 
    else "-- " <> name </> objectInstance name <> opaqueInstance name <> otherInstances
    where 
        otherInstances = case mExtraOps of
            Just (OpaqueSum ops) -> sumCompositeInstance manifest name ops
            Just (OpaqueRecord ops) -> recordCompositeInstance manifest name (recordFields ops) False
            Just (OpaqueRecordArray ops) -> recordCompositeInstance manifest name (recordArrayFields ops) True
            _ -> ""

rawTypeOps :: Text -> Type -> Text
rawTypeOps name (TypeArray ctype futelem rank ops) = freeDec <> shapeDec <> indexDec <> valuesDec <> newDec <> newRawDec <> valuesRawDec
    where
        name' = reformatTypeName name
        elem =  haskellElemType futelem
        freeDec = cFFICall ("free" <-> name') (arrayFree ops)
            [contextPointer, pointer (raw name')] "Int"
        shapeDec = cFFICall ("shape" <-> name') (arrayShape ops)
            [contextPointer, pointer (raw name')] (pointer "I64")
        indexDec = cFFICall ("index" <-> name') (arrayIndex ops)
            (contextPointer : pointer elem : pointer (raw name') : replicate rank "I64") "Int"
        valuesDec = cFFICall ("values" <-> name') (arrayValues ops)
            [contextPointer, pointer (raw name'), pointer elem] "Int"
        valuesRawDec = cFFICall ("valuesRaw" <-> name') (arrayValuesRaw ops)
            [contextPointer, pointer (raw name')] (pointer cbyte)
        newDec = cFFICall ("newArray" <-> name') (arrayNew ops)
            (contextPointer : pointer elem : replicate rank "I64") (pointer $ raw name')
        newRawDec = cFFICall ("newArrayRaw" <-> name') (arrayNewRaw ops)
            (contextPointer : pointer cbyte : replicate rank "I64") (pointer $ raw name')

rawTypeOps name (TypeOpaque ctype ops mExtraOps doc) = freeDec <> storeDec <> restoreDec <> extraOpsDec
    where
        name' = reformatTypeName name
        freeDec = cFFICall ("free" <-> name') (opaqueFree ops)
            [contextPointer, pointer (raw name')] "Int"
        storeDec = cFFICall ("store" <-> name') (opaqueStore ops)
            [contextPointer, pointer (raw name'), pointer (pointer cbyte), pointer csize] "Int"
        restoreDec = cFFICall ("restore" <-> name') (opaqueRestore ops)
            [contextPointer, pointer cbyte] (pointer (raw name'))
        extraOpsDec = case mExtraOps of
            Nothing -> ""
            Just (OpaqueSum ops) -> rawOpaqueSumDec name ops 
            Just (OpaqueRecord ops) -> rawOpaqueRecordDec name ops
            Just (OpaqueArray ops) -> rawOpaqueArrayDec name ops
            Just (OpaqueRecordArray ops) -> rawOpaqueRecordArrayDec name ops
            _ -> error ("unknown kind of opaque:" <> T.unpack name)    

rawOpaqueSumDec name ops 
    = cFFICall ("variant" <-> name') (sumVariant ops) [contextPointer, rawHaskellType name] "Int"
    <> mconcat (map variantDec $ sumVariants ops) 
    where
        name' = reformatTypeName name
        variantDec variant
            =  cFFICall ("construct" <-> name' <-> sumVariantName variant) (sumVariantConstruct variant)
                (contextPointer : pointer (rawHaskellType name) : map rawHaskellType (sumVariantPayload variant)) "Int"
            <> cFFICall ("destruct" <-> name' <-> sumVariantName variant) (sumVariantDestruct variant)
                (contextPointer : map (pointer . rawHaskellType) (sumVariantPayload variant) <> [rawHaskellType name]) "Int"
rawOpaqueRecordDec name ops
    = newDec (recordNew ops) (recordFields ops)
    <> mconcat (map fieldDec $ recordFields ops)
    where
        name' = reformatTypeName name
        newDec cfunc fields = cFFICall ("new" <-> name') cfunc
            (contextPointer : pointer (rawHaskellType name) : map (rawHaskellType . recordFieldType) fields) "Int"
        fieldDec field = cFFICall ("project" <-> name' <-> recordFieldName field) (recordFieldProject field)
            [contextPointer, pointer (rawHaskellType $ recordFieldType field), rawHaskellType name] "Int"
rawOpaqueArrayDec name ops = newDec <> setDec <> shapeDec <> indexDec
    where
        name' = reformatTypeName name
        rank = opaqueArrayRank ops
        elem = rawHaskellType (opaqueArrayElemType ops)
        newDec = cFFICall  ("new" <-> name') (opaqueArrayNew ops)
            (contextPointer : pointer (rawHaskellType name) : pointer elem : replicate rank "I64") "Int"
        setDec = cFFICall  ("set" <-> name') (opaqueArraySet ops)
            (contextPointer : pointer (rawHaskellType name) : elem : replicate rank "I64") "Int"
        shapeDec = cFFICall ("shape" <-> name') (opaqueArrayShape ops)
            [contextPointer, pointer (rawHaskellType name)] (pointer "I64")
        indexDec = cFFICall ("index" <-> name') (opaqueArrayIndex ops)
            (contextPointer : elem : rawHaskellType name : replicate rank "I64") "Int"
         
rawOpaqueRecordArrayDec name ops = newDec <> setDec <> shapeDec <> indexDec <> zipDec <> mconcat (map projectDec fields)
    where
        name' = reformatTypeName name
        rank = recordArrayRank ops
        elem = rawHaskellType (recordArrayElemType ops)
        fields = recordArrayFields ops
        newDec = cFFICall  ("new" <-> name') (recordArrayNew ops)
            (contextPointer : pointer (rawHaskellType name) : pointer elem : replicate rank "I64") "Int"
        setDec = cFFICall  ("set" <-> name') (recordArraySet ops)
            (contextPointer : pointer (rawHaskellType name) : elem : replicate rank "I64") "Int"
        shapeDec = cFFICall ("shape" <-> name') (recordArrayShape ops)
            [contextPointer, pointer (rawHaskellType name)] (pointer "I64")
        indexDec = cFFICall ("index" <-> name') (recordArrayIndex ops)
            (contextPointer : elem : rawHaskellType name : replicate rank "I64") "Int"
        zipDec = cFFICall ("zip" <-> name') (recordArrayZip ops)
            (contextPointer : pointer (rawHaskellType name) : map (rawHaskellType . recordFieldType) fields) "Int"
        projectDec field = cFFICall ("project" <-> name' <-> recordFieldName field) (recordFieldProject field)
            [contextPointer, pointer (rawHaskellType $ recordFieldType field), rawHaskellType name] "Int"


isConvertible manifest t = case M.lookup t (manifestTypes manifest) of 
    Nothing -> True --Primitive
    Just t' -> case t' of
        (TypeArray _ _ _ _) -> True
        (TypeOpaque _ _ ops _) -> case ops of
            Nothing -> False
            Just ops' -> case ops' of
                (OpaqueArray _) -> False --fix eventually
                (OpaqueRecordArray o) -> and (map (check . recordFieldType) (recordArrayFields o))
                (OpaqueRecord o) -> and (map (check . recordFieldType) (recordFields o))
                (OpaqueSum o) -> and (map (and . map check . sumVariantPayload) (sumVariants o))
    where
        check = isConvertible manifest

mutable t = "Mutable" <> t
nativeSumDec manifest name ops = 
    (codecomment name <> sumFormat' name' (map variant $ sumVariants ops), elementDec)
    where 
        variant v = (name' <-> sumVariantName v, map nativeType $ sumVariantPayload v)
        name' = reformatTypeName name
        elementDec = instanceFormat ("Element") [(name',[])]
            [ typeFormat ("Array " <> name') ("BArray " <> name')
            , typeFormat ("MArray " <> name') ("MBArray " <> name')
            , "size = sizeB\n"
            , "msize = msizeB\n"
            , "unsafeRead = unsafeReadB\n"
            , "unsafePeek = unsafePeekB\n"
            , "unsafePoke = unsafePokeB\n"
            , "unsafeThaw = unsafeThawB\n"
            , "unsafeFreeze = unsafeFreezeB\n"
            , "unsafeSlice = unsafeSliceB\n"
            , "scratch = scratchB\n"
            ]

nativeRecordDec manifest name ops = if isTuple name
    then ("","")
    else if isTuple'
        then (codecomment name <> newtypeFormat' (reformatTypeName name) (tuple (map snd fields)) <> "\n", elementDec)
        else (codecomment name <> recFormat' (reformatTypeName name) fields, elementDec)
    where
        elementDec = idec <> mdec <> arrdec <> elemdec <> zipdec <> unzipdec <> showdec :: Text
        name' = reformatTypeName name
        isTuple' = fst (fields !! 0) == "0"
        fields = map (\f -> (recordFieldName f, nativeType (recordFieldType f))) $ recordFields ops
        icon' =  "Array_" <> name'
        mcon' = "MArray_" <> name'
        array a = "Array " <> wrapIfNotWrappedOrSingleton a
        marray a = "M" <> array a
        econ vars = if isTuple' 
            then name' <~> tuple vars
            else name' <~> T.unwords (map wrapIfNotWrappedOrSingleton vars)
        icon vars = icon' <~> T.unwords (map wrapIfNotWrappedOrSingleton vars)
        mcon vars = mcon' <~> T.unwords (map wrapIfNotWrappedOrSingleton vars) 
        nums = map (T.pack . show) [0..length fields-1]
        vars = map ("a"<>) nums
        elems = map ("e"<>) nums
        idec = "data" <~> icon' <=> icon (map (wrap.array.snd) fields) <> "\n"
        mdec = "data" <~> mcon' <=> mcon (map (wrap.marray.snd) fields) <> "\n"
        arrdec = instanceFormat "Element"  
            [(name', [])] 
            [ typeFormat ("Array "  <> name' ) icon'
            , typeFormat ("MArray " <> name' ) mcon'
            , "size (" <> icon vars <> ") = size a0\n" 
            , "msize (" <> mcon vars <> ") = msize a0\n" 
            , "unsafeRead (" <> icon vars <> ") idx = " <> econ (map (\v -> "unsafeRead " <> v <> " idx") vars) <> "\n"
            , "unsafePeek (" <> mcon vars <> ") idx = do\n" 
                <> mconcat (zipWith (\v e -> "  " <> e <> " <- unsafePeek " <> v <> " idx\n") vars elems)
                <> "  pure (" <> econ elems <> ")\n"
            , "unsafePoke (" <> mcon vars <> ") idx (" <> econ elems <> ") = do\n" 
                <> mconcat (zipWith (\v e -> "  unsafePoke " <> v <> " idx " <> e <>"\n") vars elems)
            --, "copy (" <> mcon vars <> ") = do\n" 
            --    <> mconcat (map (\v -> "  " <> v <> "' <- copy " <> v <> "\n") vars)
            --    <> "  pure (" <> mcon (map (<>"'") vars) <> ")\n" 
            , "unsafeThaw (" <> icon vars <> ") = do\n" 
                <> mconcat (map (\v -> "  " <> v <> "' <- unsafeThaw " <> v <> "\n") vars)
                <> "  pure (" <> mcon (map (<>"'") vars) <> ")\n" 
            , "unsafeFreeze (" <> mcon vars <> ") = do\n" 
                <> mconcat (map (\v -> "  " <> v <> "' <- unsafeFreeze " <> v <> "\n") vars)
                <> "  pure (" <> icon (map (<>"'") vars) <> ")\n"
            , "unsafeSlice (" <> icon vars <> ") i s = " <> icon (map (\v -> "(unsafeSlice " <> v <> " i s)") vars)
                <> "\n"
            , "scratch s = do\n" 
                <> mconcat (map (\v -> "  " <> v <> " <- scratch s\n") vars)
                <> "  pure (" <> mcon vars <> ")\n" 
            ]
        elemdec = instanceFormat ("Element") [(icon',[])]
            [ typeFormat ("Array " <> icon') ("BArray " <> icon')
            , typeFormat ("MArray " <> icon') ("MBArray " <> icon')
            , "size = sizeB\n"
            , "msize = msizeB\n"
            , "unsafeRead = unsafeReadB\n"
            , "unsafePeek = unsafePeekB\n"
            , "unsafePoke = unsafePokeB\n"
            , "unsafeThaw = unsafeThawB\n"
            , "unsafeFreeze = unsafeFreezeB\n"
            , "unsafeSlice = unsafeSliceB\n"
            , "scratch = scratchB\n"
            ]
        zipdec = "" 
            <> "zip_" <> name' <> " :: "
            <> mconcat (map (\f -> array (snd f) <> " -> ") fields)
            <> "Array " <> name' <> "\n"
            <> "zip_" <> name' <~> T.unwords vars <=> (if length vars > 1
                then "if " <> T.intercalate " && " (zipWith (\v v' -> "size " <> v <> " == " <> "size " <> v') vars (tail vars)) <> "\n"
                    <> "  then " <> icon vars <> "\n"
                    <> "  else error \"sizes of arguments do not match\"\n"
                else icon vars <> "\n")
        unzipdec = "" 
            <> "unzip_" <> name' <> " :: "
            <> "Array " <> name' <> " -> " <> tuple (map (array.snd) fields) <> "\n"
            <> "unzip_" <> name' <~> wrap (icon vars) <=> tuple vars <> "\n"
        showdec = instanceFormat 
            "Show"
            [(icon',[])]
            [ "show = show . toList\n" ]

nativeOpaqueArrayDec manifest name ops = (codecomment name <> if isArr
    then typeFormat    name' (nativeType name)
      <> "\n"
    else newtypeFormat' name' (wrap innerType)
      <> "\n"
    , "" )
    where
        innerType = nativeType (mconcat (replicate (opaqueArrayRank ops) "[]") <> opaqueArrayElemType ops)
        isArr = take 2 (T.unpack name) == "[]" 
        name' = reformatTypeName name

nativeRecordArrayDec manifest name ops = (codecomment name <> if isArr
    then typeFormat    name' (nativeType name)
      <> "\n"
    else newtypeFormat' name' (wrap innerType)
      <> "\n"
    , "" )
    where
        innerType = nativeType (mconcat (replicate (recordArrayRank ops) "[]") <> recordArrayElemType ops)
        isArr = take 2 (T.unpack name) == "[]" 
        name' = reformatTypeName name 
        


nativeTypeDec manifest name (TypeArray ctype futelem rank ops) = (codecomment name <> staticDec <> "\n","")
    where
        name' = reformatTypeName name
        elem = capitalize futelem
        staticDec = typeFormat name' (arrayType rank)
        arrayType rank = if rank == 1 then "Array " <> elem else "Array (" <> arrayType (rank-1) <> ")"
nativeTypeDec manifest name (TypeOpaque ctype ops mExtraOps _) = case mExtraOps of
        Nothing -> ("","")
        Just (OpaqueSum ops) -> nativeSumDec manifest name ops
        Just (OpaqueRecord ops) -> nativeRecordDec manifest name ops
        Just (OpaqueArray ops) -> nativeOpaqueArrayDec manifest name ops
        Just (OpaqueRecordArray ops) -> nativeRecordArrayDec manifest name ops
        _ -> error ("unknown kind of opaque:" <> T.unpack name)    
conversionDec manifest name (TypeArray ctype futelem rank ops) = instanceFormat "Convertible" [(wname,[])] 
    [native, toFuthark, fromFuthark] 
    where 
        name' = reformatTypeName name
        wname = "Futhark." <> name'
        nname = "Haskell." <> name'
        native = typeFormat ("Native" <~> wname) nname
        szs = map (\i -> "sz"<> T.pack (show i)) [0..rank-1]
        idxs = map (\i -> "idx"<> T.pack (show i)) [0..rank-1]
        toFuthark = if rank == 1 
            then "toFuthark (SArray sz ptr) = unsafeLiftFromIO $ \\ctx"
                </~> "-> inContext ctx $ \\cp"
                </~> "-> F.withForeignPtr ptr $ \\ap"
                </~> "-> Raw.newArray_" <> name' <> " cp ap (fromIntegral sz) >>= wrapFO ctx\n"
            else "toFuthark arr = let " <> tuple szs <=> tuple (map (\r -> "size (arr " <> mconcat (replicate r "! 0") <> ")" ) [0..rank-1]) <> " in unsafeLiftFromIO $ \\ctx"
                </~> "-> inContext ctx $ \\cp"
                </~> "-> F.allocaArray (" <> T.intercalate "*" szs <> ") $ \\tmp"
                </~> "-> sequence ((\\" <> T.unwords (init idxs) <> " -> pure (arr" <> mconcat (map (" ! "<>) (init idxs)) <> ") >>= \\(SArray sz ptr) -> if sz == " <> last szs 
                </~> "  then F.withForeignPtr ptr (\\ap -> F.copyArray ap (F.advancePtr tmp (" <> T.intercalate "+" (zipWith (\a b -> a<>"*"<>b) (tail szs) (init idxs)) <> ")) sz)"
                </~> "  else error \"Uneven array can not be converted\") <$> " <> T.intercalate " <*> " (map (\sz -> "[0.." <> sz <> "-1]") $ init szs) <> ")"
                </~> ">> Raw.newArray_" <> name' <> " cp tmp " <> T.unwords (map (wrap.("fromIntegral " <>)) szs) <>" >>= wrapFO ctx\n" 
              
        fromFuthark = "fromFuthark arr = unsafeLiftFromIO $ \\ctx"
                </~> "-> inContext ctx $ \\cp"
                </~> "-> withRawObject arr $ \\fp"
                </~> "-> Raw.shape_" <> name' <> " cp fp >>= \\sp"
                <> mconcat (zipWith (\i sz -> "\n  -> fmap fromIntegral (F.peekElemOff sp " <> T.pack (show i) <> ") >>= \\" <> sz <> "") [0..] szs)
                </~> "-> pure (" <> T.intercalate "*" szs <> ") >>= \\sz"
                </~> "-> F.mallocForeignPtrArray sz >>= \\ptr"

               
                </~> "-> F.withForeignPtr ptr (\\ap -> Raw.values_" <> name' <> " cp fp ap)"
                </~> ">> sync ctx"
                </~> ">> pure (SArray sz ptr)" <> if rank == 1 
                    then "\n" 
                    else " >>= \\arr "
                        </~> "-> pure (" 
                        <> mconcat (zipWith (\i sz -> "A.tabulate " <> sz <> " $ \\" <> i <> " -> ") (init idxs) szs)
                        <> "A.unsafeSlice arr ("<> T.intercalate "*" (last szs:init idxs) <> ") " <> last szs <> ")"
                
                
        
conversionDec manifest name (TypeOpaque ctype ops mExtraOps doc) = if not (isConvertible manifest name) 
    then ""
    else case mExtraOps of
        Nothing -> ""
        Just (OpaqueSum ops) -> conversionSumDec manifest name ops
        Just (OpaqueRecord ops) -> conversionRecordDec manifest name ops
        Just (OpaqueArray ops) -> conversionArrayDec manifest name ops
        Just (OpaqueRecordArray ops) -> conversionRecordArrayDec manifest name ops
        _ -> error ("unknown kind of opaque:" <> T.unpack name)    

conversionSumDec manifest name ops = instanceFormat "Convertible" [(wname,[])] [native, toFuthark, fromFuthark]
    where
        name' = reformatTypeName name
        wname = "Futhark."  <> name'
        uname = "Unpacked." <> name'
        nname = "Haskell."  <> name'
        native = typeFormat ("Native" <~> wname) nname
        fieldtype t = if isTuple t 
            then mconcat $ map fieldtype (subtypes t)
            else [t]
        fieldid prefix t = if isTuple t 
            then mconcat $ zipWith (\i -> fieldid (prefix <-> T.pack (show i))) [0..] (subtypes t)
            else [prefix]
        tuplePattern prefix t = if isTuple t 
            then tuple $ zipWith (\i -> tuplePattern (prefix <-> T.pack (show i))) [0..] (subtypes t)
            else prefix
        payloadtypes variant = mconcat $ map fieldtype (sumVariantPayload variant)
        payloadids variant = mconcat $ zipWith (fieldid) (map (\i -> "p" <> T.pack (show i)) [0..]) (sumVariantPayload variant)
        pattern variant = 
            let items = zipWith tuplePattern (map (\i -> "p" <> T.pack (show i)) [0..]) (sumVariantPayload variant)
             in T.unwords items
        subtypes t = case M.lookup t (manifestTypes manifest) of
            Just (TypeOpaque _ _ (Just (OpaqueRecord ops)) _) -> map recordFieldType (recordFields ops)
            _ -> error "nontuple type"
        subargs t = zipWith (\i _ -> "t" <> T.pack (show i)) [0..] (subtypes t) 
        fromFuthark = "fromFuthark packed = unsafeFromFutIO $ do\n" <> indent (""
            <> "unpacked <- unpack packed\n"
            <> "case unpacked of\n" 
            <> indent (mconcat (map fromFutharkVariant (sumVariants ops)))
            )
        toFuthark = "toFuthark native = unsafeFromFutIO $ do\n" <> indent (""
            <> "case native of\n"
            <> indent (mconcat (map toFutharkVariant (sumVariants ops)))
            )
        fromFutharkVariant variant = uname <-> sumVariantName variant <~> pattern variant <> " -> do\n" <> indent (""
            <> mconcat (zipWith (\t i -> if isPrimitive t 
                then "" 
                else i <> " <- fromFuthark " <> i <> " >>= \\" <> i <> "' -> finalizeFO " <> i <> " >> pure " <> i <> "'\n") 
                (payloadtypes variant) (payloadids variant))
            <> "pure (" <> nname <-> sumVariantName variant <~> pattern variant <> ")\n"
            )
        toFutharkVariant variant = nname <-> sumVariantName variant <~> pattern variant <> " -> do\n" <> indent (""
            <> mconcat (zipWith (\t i -> if isPrimitive t 
                then "" 
                else i <> " <- toFuthark " <> i <> "\n") 
                (payloadtypes variant) (payloadids variant))
            <> "packed <- pack $ " <> uname <-> sumVariantName variant <~> (pattern variant) <> "\n" 
            <> mconcat (zipWith (\t i -> if isPrimitive t 
                then "" 
                else "finalizeFO " <> i <> "\n") 
                (payloadtypes variant) (payloadids variant))
            <> "pure packed\n"
            )
conversionRecordDec manifest name ops = if isTuple name 
    then ""
    else instanceFormat "Convertible" [(wname,[])] [native, toFuthark, fromFuthark]
    where
        name' = reformatTypeName name
        fields = recordFields ops
        isTuple' = recordFieldName (fields !! 0) == "0" 
        wname = "Futhark."  <> name'
        uname = "Unpacked." <> name'
        nname = "Haskell."  <> name'
        fieldtype t = if isTuple t 
            then mconcat $ map fieldtype (subtypes t)
            else [t]
        fieldid prefix t = if isTuple t 
            then mconcat $ zipWith (\i -> fieldid (prefix <-> T.pack (show i))) [0..] (subtypes t)
            else [prefix]
        tuplePattern prefix t = if isTuple t 
            then tuple $ zipWith (\i -> tuplePattern (prefix <-> T.pack (show i))) [0..] (subtypes t)
            else prefix
        fieldtypes = mconcat $ map (fieldtype . recordFieldType) fields
        fieldids = mconcat $ zipWith (fieldid) (map (\i -> "f" <> T.pack (show i)) [0..]) (map recordFieldType fields)
        pattern = let items = zipWith tuplePattern (map (\i -> "f" <> T.pack (show i)) [0..]) (map recordFieldType fields)
            in if isTuple' then tuple items else T.unwords items
        native = typeFormat ("Native" <~> wname) nname
        subtypes t = case M.lookup t (manifestTypes manifest) of
            Just (TypeOpaque _ _ (Just (OpaqueRecord ops)) _) -> map recordFieldType (recordFields ops)
            _ -> error "nontuple type"
        subargs t = zipWith (\i _ -> "t" <> T.pack (show i)) [0..] (subtypes t) 
        fromFuthark = "fromFuthark packed = unsafeFromFutIO $ do\n" <> indent (""
            <> uname <~> pattern <> " <- unpack packed\n"
            <> mconcat (zipWith (\t a -> if isPrimitive t 
                then "" 
                else a <> " <- fromFuthark " <> a <> " >>= \\" <> a <> "' -> finalizeFO " <> a <> " >> pure " <> a <> "'\n") 
                fieldtypes fieldids)
            <> "pure (" <> nname <~> pattern <> ")\n"
            )
        toFuthark = "toFuthark (" <> nname <~> pattern <> ") = unsafeFromFutIO $ do\n" <> indent (""
            <> mconcat (zipWith (\t a -> if isPrimitive t 
                then "" 
                else a <> " <- toFuthark " <> a <> "\n") 
                fieldtypes fieldids)
            <> "packed <- pack (" <> uname <~> pattern <> ")\n"
            <> mconcat (zipWith (\t a -> if isPrimitive t 
                then "" 
                else "finalizeFO " <> a <> "\n") 
                fieldtypes fieldids)
            <> "pure packed\n"
            )
        
conversionRecordArrayDec manifest name ops = instanceFormat "Convertible" [(wname,[])] [native, toFuthark, fromFuthark]
    where
        name' = reformatTypeName name 
        fields = recordArrayFields ops
        ename = reformatTypeName $ recordArrayElemType ops
        fieldN = T.pack (show (length fields))
        rank = recordArrayRank ops
        (zipFun, unzipFun) = if isTuple (recordArrayElemType ops)
            then ("A.zip" <> fieldN, "A.unzip" <> fieldN)
            else ("Haskell.zip_" <> ename, "Haskell.unzip_" <> ename)
        unzipArr rank = if rank > 1 
            then "A.unzip" <> fieldN <> " . A.map " <> wrapIfNotOneWord (unzipArr (rank-1))
            else unzipFun
        zipArr rank = if rank > 1 
            then "A.map" <> fieldN <~> wrapIfNotOneWord (zipArr (rank-1))
            else zipFun
        isTuple' = recordFieldName (fields !! 0) == "0" 
        isArr = take 2 (T.unpack name) == "[]" 
        deArr = T.dropWhile (\c -> c == '[' || c == ']')
        isTupleArr = isTuple . deArr
        tupleArr = "T" <> T.pack (show (length fields)) <> "Array"
        recordArr = "Haskell.Array_" <> reformatTypeName (recordArrayElemType ops)
        wname = "Futhark."  <> name'
        uname = "Unpacked." <> name'
        nname = "Haskell."  <> name'
        fieldtypes = map recordFieldType fields
        fieldids = zipWith (\i _ -> "f" <> T.pack (show i)) [0..] fields
        upattern = uname <~> if isTuple' then tuple fieldids else T.unwords fieldids
        native = typeFormat ("Native" <~> wname) nname
        fromFuthark = "fromFuthark packed = unsafeFromFutIO $ do\n" <> indent (""
            <> upattern <> " <- unpack packed\n"
            <> mconcat (zipWith (\t a -> if isPrimitive t 
                then "" 
                else a <> " <- fromFuthark " <> a <> " >>= \\" <> a <> "' -> finalizeFO " <> a <> " >> pure " <> a <> "'\n") 
                fieldtypes fieldids)
            <> "pure $ " <> (if isArr then "" else nname <> " $ ") <> zipArr rank <~> T.unwords fieldids 
            )
        toFuthark = "toFuthark "<> (if isArr then "arr" else wrap (nname <> " arr")) <>" = unsafeFromFutIO $ do\n" <> indent (""
            <> tuple fieldids <> " <- pure . " <> unzipArr rank <> " $ arr\n" 
            <> mconcat (zipWith (\t a -> if isPrimitive t 
                then "" 
                else a <> " <- toFuthark " <> a <> "\n") 
                fieldtypes fieldids)
            <> "packed <- pack (" <> upattern <> ")\n"
            <> mconcat (zipWith (\t a -> if isPrimitive t 
                then "" 
                else "finalizeFO " <> a <> "\n") 
                fieldtypes fieldids)
            <> "pure packed\n"
            )

conversionArrayDec manifest name ops = instanceFormat "Convertible" [(wname,[])] [native, toFuthark, fromFuthark]
    where
        name' = reformatTypeName name
        wname = "Futhark."  <> name'
        uname = "Unpacked." <> name'
        nname = "Haskell."  <> name' 
        native = typeFormat ("Native" <~> wname) nname
        fromFuthark = "fromFuthark = undefined\n"
        toFuthark = "toFuthark = undefined\n"

rawTypeUtil name _ = error $ "unknown type: " <> T.unpack name

typeDec :: Text -> Type -> Text
typeDec name (TypeArray ctype futelem rank ops) = undefined
typeDec name (TypeOpaque ctype ops mExtraOps doc) = undefined
typeDec name _ = error $ "unknown type: " <> T.unpack name



rawEntryCalls = M.foldr (<>) "" . M.mapWithKey rawEntryCall . manifestEntryPoints
rawTypeOpss = M.foldr (<>) "" . M.mapWithKey rawTypeOps . manifestTypes
rawTypeDecs =  M.foldr (<>) "" . M.mapWithKey rawTypeDec . manifestTypes
wrappedTypeDecs = M.foldr (<>) "" . M.mapWithKey wrappedTypeDec . manifestTypes
wrappedTypeOpss manifest = M.foldr (<>) "" . M.mapWithKey (wrappedTypeOps manifest) . manifestTypes $ manifest
unpackedTypeDecs manifest = M.foldr (<>) "" . M.mapWithKey (unpackedTypeDec manifest) . manifestTypes $ manifest
conversionDecs manifest = M.foldr (<>) "" . M.mapWithKey (conversionDec manifest) . manifestTypes $ manifest
wrappedEntryCalls manifest = (\(docs, calls) -> docs <> calls) 
    $ M.foldr (\(doc1, call1) (doc2, call2) -> (doc1 <> doc2, call1 <> call2)) ("", "") 
    . M.mapWithKey (wrappedEntryCall manifest) . manifestEntryPoints $ manifest
nativeTypeDecs manifest = (\(decs, instances) -> hcomment "Types mirroring those in the manifest" <> "\n" <> decs <> "\n" <> hcomment "Element instances and functions" <> "\n" <> instances) 
    $ M.foldr (\(dec1, inst1) (dec2, inst2) -> (dec1 <> dec2, inst1 <> inst2)) ("", "") 
    . M.mapWithKey (nativeTypeDec manifest) . manifestTypes $ manifest


typetest = do
    manifest <- readManifest "test.json"
    putText $ rawEntryCalls manifest
    putText $ rawTypeOpss manifest
    putText $ rawTypeDecs manifest
    putText $ wrappedTypeDecs manifest
    putText $ wrappedTypeOpss manifest
    putText $ nativeTypeDecs manifest
    putText $ conversionDecs manifest
    pure ()


--generate mapN for array module
arrMapN :: Int -> Text
arrMapN n = typedec <> mapdec
    where
        n' = T.pack (show n)
        elems = take (n+1) $ map (\i -> "e" <> T.pack (show i)) [0..]
        vars = take n $ map (\i -> "a" <> T.pack (show i)) [0..]
        typedec = "map" <> n' 
            <> " :: " <> tuple (map ("Element "<>) elems) 
            <> " => " <> wrap (T.intercalate " -> " elems) 
            <> mconcat (map (" -> Array "<>) elems) 
            <> "\n"
        mapdec = "map" <> n' <> " f " <> T.unwords vars 
            <=> "if " <> T.intercalate " && " (zipWith (\a b -> "size " <> a <> " == size " <> b) vars (tail vars)) 
            </~> "then tabulate (size a0) (\\idx -> f " <> T.unwords (map (\v -> "(unsafeRead " <> v <> " idx)") vars) <> ")"
            </~> "else error \"sizes of arguments do not match\""
            </> "\n" 

--generate tuple arrays
tupleArray :: Int -> Text
tupleArray i = idec <> mdec <> arrdec <> elemdec <> showdec <> zipdec <> unzipdec
    where
        icon' = "T" <> T.pack (show i) <> "Array"
        mcon' = "M" <> icon'
        icon vars = icon' <~> T.unwords vars
        mcon vars = mcon' <~> T.unwords vars
        nums = map (T.pack . show) [0..i-1]
        vars = map ("a"<>) nums
        elems = map ("e"<>) nums
        idec = "data" <~> icon vars <> " where\n  " 
            <> icon' <> " :: " 
            <> tuple (map ("Element " <>) vars) <> " => " 
            <> mconcat (map (\v -> "Array " <> v <> " -> ") vars)
            <> icon vars <> "\n"
        mdec = "data" <~> mcon vars <> " where\n  " 
            <> mcon' <> " :: " 
            <> tuple (map ("Element " <>) vars) <> " => " 
            <> mconcat (map (\v -> "MArray " <> v <> " -> ") vars)
            <> mcon vars <> "\n"
        arrdec = instanceFormat ( tuple ( map ("Element" <~>) vars)  <> " => Element" ) 
            [(tuple vars, [])] 
            [ typeFormat ("Array "  <> tuple vars ) (icon vars)
            , typeFormat ("MArray " <> tuple vars ) (mcon vars)
            , "size (" <> icon vars <> ") = size a0\n" 
            , "msize (" <> mcon vars <> ") = msize a0\n" 
            , "unsafeRead (" <> icon vars <> ") idx = " <> tuple (map (\v -> "unsafeRead " <> v <> " idx") vars) <> "\n"
            , "unsafePeek (" <> mcon vars <> ") idx = do\n" 
                <> mconcat (zipWith (\v e -> "  " <> e <> " <- unsafePeek " <> v <> " idx\n") vars elems)
                <> "  pure " <> tuple elems <> "\n"
            , "unsafePoke (" <> mcon vars <> ") idx " <> tuple elems <> " = do\n" 
                <> mconcat (zipWith (\v e -> "  unsafePoke " <> v <> " idx " <> e <>"\n") vars elems)
            --, "copy (" <> mcon vars <> ") = do\n" 
            --    <> mconcat (map (\v -> "  " <> v <> "' <- copy " <> v <> "\n") vars)
            --    <> "  pure (" <> mcon (map (<>"'") vars) <> ")\n" 
            , "unsafeThaw (" <> icon vars <> ") = do\n" 
                <> mconcat (map (\v -> "  " <> v <> "' <- unsafeThaw " <> v <> "\n") vars)
                <> "  pure (" <> mcon (map (<>"'") vars) <> ")\n" 
            , "unsafeFreeze (" <> mcon vars <> ") = do\n" 
                <> mconcat (map (\v -> "  " <> v <> "' <- unsafeFreeze " <> v <> "\n") vars)
                <> "  pure (" <> icon (map (<>"'") vars) <> ")\n"
            , "unsafeSlice (" <> icon vars <> ") i s = " <> icon (map (\v -> "(unsafeSlice " <> v <> " i s)") vars)
                <> "\n"
            , "scratch s = do\n" 
                <> mconcat (map (\v -> "  " <> v <> " <- scratch s\n") vars)
                <> "  pure (" <> mcon vars <> ")\n" 
            ]
        elemdec = instanceFormat ("Element") [(wrap (icon vars),[])]
            [ typeFormat ("Array " <> wrap (icon vars)) ("BArray " <> wrap (icon vars))
            , typeFormat ("MArray " <> wrap (icon vars)) ("MBArray " <> wrap (icon vars))
            , "size = sizeB\n"
            , "msize = msizeB\n"
            , "unsafeRead = unsafeReadB\n"
            , "unsafePeek = unsafePeekB\n"
            , "unsafePoke = unsafePokeB\n"
            , "unsafeThaw = unsafeThawB\n"
            , "unsafeFreeze = unsafeFreezeB\n"
            , "unsafeSlice = unsafeSliceB\n"
            , "scratch = scratchB\n"
            ]
        zipdec = "" 
            <> "zip" <> T.pack (show i) <> " :: " <> tuple (map ("Element " <> ) vars) <> " => " 
            <> mconcat (map (\v -> "Array " <> v <> " -> ") vars)
            <> "Array " <> tuple vars <> "\n"
            <> "zip" <> T.pack (show i) <~> T.unwords vars <=> "if " <> T.intercalate " && " (zipWith (\v v' -> "size " <> v <> " == " <> "size " <> v') vars (tail vars)) <> "\n"
            <> "  then " <> icon vars <> "\n"
            <> "  else error \"sizes of arguments do not match\"\n"
        unzipdec = "" 
            <> "unzip" <> T.pack (show i) <> " :: " <> tuple (map ("Element " <> ) vars) <> " => " 
            <> "Array " <> tuple vars <> " -> " <> tuple (map ("Array " <>) vars) <> "\n"
            <> "unzip" <> T.pack (show i) <~> wrap (icon vars) <=> tuple vars <> "\n"
        showdec = instanceFormat 
            (tuple ( map ("Show " <>) vars ++ map ("Element " <>) vars ) <> " => Show")
            [(wrap (icon vars),[])]
            [ "show = show . toList\n" ]