module NHCBackend
( cNhc
, hNhc
--, genProcNHC
) where
#if defined(__NHC__) || defined(__HBC__)
import NonStdTrace
#elif __GLASGOW_HASKELL__ >= 502
import Debug.Trace (trace)
#else
import IOExts (trace)
#endif
import Pretty
import PrettyUtils (textline,vcatMap,vsepMap,vsep,commaList,ppList)
import Decl (Decl(..), Sig, Call, CCode, Fail, Result)
import DIS (DIS(..), expandDIS, DISEnv, simplify)
import FillIn (fillinProc, Consts, genConsts)
import Casm (BaseTy(..), baseTyToCall, baseTyToRtn, baseToCType)
import Type (ppType, isPureType)
import Maybe (fromMaybe)
import Name
import NameSupply
cNhc, hNhc :: Bool -> DISEnv -> [String] -> Decl -> Doc
cNhc dbg disEnv pre (Haskell _) = empty
cNhc dbg disEnv pre (C c) = text c
cNhc dbg disEnv pre (DisDef _ _ _) = empty
cNhc dbg disEnv pre (Prefix _) = empty
cNhc dbg disEnv pre (Include _) = error "%#include is obsolete."
cNhc dbg disEnv pre (Constant ty ns) = --nyi "%const"
vcat (map (cBit . fillinProc disEnv pre) (genConsts disEnv (ty,ns)))
cNhc dbg disEnv pre (ProcSpec sig mbcall mbcode mbfail mbresult) =
cBit $
fillinProc disEnv pre $
(sig, mbcall, mbcode, fromMaybe [] mbfail, mbresult)
hNhc dbg disEnv pre (Haskell h) = text h
hNhc dbg disEnv pre (C _) = empty
hNhc dbg disEnv pre (DisDef _ _ _) = empty
hNhc dbg disEnv pre (Prefix _) = empty
hNhc dbg disEnv pre (Include _) = error "%#include is obsolete"
hNhc dbg disEnv pre (Constant ty ns) = --nyi "%const"
vcat (map (haskellBit dbg . fillinProc disEnv pre) (genConsts disEnv (ty,ns)))
hNhc dbg disEnv pre (ProcSpec sig mbcall mbcode mbfail mbresult) =
haskellBit dbg $
fillinProc disEnv pre $
(sig, mbcall, mbcode, fromMaybe [] mbfail, mbresult)
cfn name = text "hs_" <> name
--genProcNHC :: (Sig, Call, CCode, Fail, Result) -> (Doc, Doc, Doc)
--genProcNHC arg =
-- (haskellBit False arg, cBit arg, empty)
haskellBit dbg ((name, typ), calls, code, fails, result) =
let fnName = text name
--arity = text (show (length argTypes))
primTypes = ppList (text " -> ")
( if isPureType typ then rtnType
else text "IO" <+> rtnType)
argTypes
argDISs = map simplify calls
rtnDIS = simplify result
argTypes = concat $
fst $ initNS (mapM hargtypes argDISs) (nameSupply "a")
(eqns,argPats) = fst $ initNS (hargpats argDISs) (nameSupply "tmp")
argsCall = fst $ initNS (mapM hargcall argDISs) (nameSupply "arg")
rtnType = fst $ initNS (hrtntype rtnDIS) (nameSupply "r")
(bind,rtnCons) = fst $ initNS (hrtncon rtnDIS) (nameSupply "res")
rtnPat = fst $ initNS (hrtnpat rtnDIS) (nameSupply "res")
emit c x = if c then trace x else id
in
emit dbg ("*****ARGS:\n"++unlines (map show argDISs)) $
emit dbg ("*****RESULT:\n"++show rtnDIS++"\n") $
if clean rtnDIS && and (map clean argDISs) then
text "foreign import ccall" <+> doubleQuotes (cfn fnName)
<+> fnName <+> text "::" <+> primTypes
else
text "foreign import ccall" <+> cfn fnName <+> text "::" <+> primTypes $$
text "" $$
fnName <+> text "::" <+> ppType typ $$
fnName <+> hsep argPats <+> equals $$
nest 2 (
if isPureType typ then
-- text "let" $$
-- nest 4 (vsep eqns $$
-- rtnPat <+> equals <+> cfn fnName <+> hsep argsCall) $$
-- text "in" <+> rtnCons
vsep (map (<+> text "in") eqns) $$
text "let" <+> rtnPat <+> equals <+>
cfn fnName <+> hsep argsCall <+> text "in" $$
rtnCons
else
-- ( if null eqns then text "do"
-- else text "let" $$
-- nest 4 (vsep eqns) $$
-- text "in do" ) <+>
text "do" <+>
nest 4
( vsep eqns $$
if clean rtnDIS then
cfn fnName <+> hsep argsCall
else
rtnPat <+> text "<-" <+> cfn fnName <+> hsep argsCall $$
vsep bind $$
text "return" <+> rtnCons)
) $$
text "\n"
cBit ((name, typ), calls, code, fails, result) =
let argDecls = cdecls [] (map simplify calls)
rtnDIS = simplify result
rtnDecls = cdecls [] [rtnDIS]
in
text "" $$
ctype rtnDIS <+> cfn (text name) <+> parens (commaList argDecls) $$
cblock (
rtnDecls ++
[ vcatMap text code $$
if isVoid rtnDIS then
text "return"
else if simple rtnDIS then
text "return" <+> fst (initNS (crtnpat rtnDIS) (nameSupply "res"))
else
text "return " <> crtn rtnDIS
]
)
--------
hargtypes :: DIS -> NSM [Doc]
hrtntype :: DIS -> NSM Doc
hargpats :: [DIS] -> NSM ([Doc],[Doc])
hrtncon :: DIS -> NSM ([Doc],Doc)
hargcall :: DIS -> NSM Doc
hrtnpat :: DIS -> NSM Doc
hargtypes (Apply (BaseDIS (Foreign _)) ds) = return $ [text "ForeignObj"]
hargtypes (Apply (BaseDIS StablePtr) ds) = getNewName >>= \n->
return [text "StablePtr" <+> text n]
hargtypes (Apply (BaseDIS Word) ds) = getNewName >>= \n->
return [text n]
hargtypes (Apply (BaseDIS b) ds) = return $ [text (show b)]
hargtypes (Apply d ds) = mapM hargtypes ds >>= return . concat
hargtypes (BaseDIS b) = return $ []
hargtypes (Constructor c) = return $ []
hargtypes (Declare cty d) = return $ []
hargtypes (Exp e) = return $ []
hargtypes (Record n ns) = return $ []
hargtypes (Tuple) = return $ [text "()"]
hargtypes (UserDIS _ f t) = return $ []
hargtypes (Var v) = return $ []
--
hrtntype (Apply (BaseDIS (Foreign _)) ds) = return $ text "ForeignObj"
hrtntype (Apply (BaseDIS StablePtr) ds) = getNewName >>= return . (text "StablePtr" <+>) . text
hrtntype (Apply (BaseDIS Word) ds) = getNewName >>= return . text
hrtntype (Apply (BaseDIS b) ds) = return $ text (show b)
hrtntype (Apply d [r]) = hrtntype r
hrtntype (Apply d ds) = mapM hrtntype ds >>=
return . parens . commaList
hrtntype (BaseDIS b) = return $ empty
hrtntype (Constructor c) = return $ empty
hrtntype (Declare cty d) = return $ empty
hrtntype (Exp e) = return $ empty
hrtntype (Record n ns) = return $ empty
hrtntype (Tuple) = return $ text "()"
hrtntype (UserDIS _ f t) = return $ empty
hrtntype (Var v) = return $ empty
--
{-
hargpat (Apply Tuple ds) = mapM hargpat ds >>=
return . parens . commaList
hargpat (Apply (Constructor c) ds) = mapM hargpat ds >>= \ps->
return $ parens (text c <+> hsep ps)
hargpat (Apply (Record n ns) ds) = mapM hargpat ds >>= \ps->
return $ parens (text n <+> feqList ns ps)
hargpat (Apply (UserDIS f t) ds) = mapM hargpat ds >>= return . hsep
--hargpat (Apply (UserDIS f t) ds) = getNewName >>= return . text
hargpat (Apply d ds) = mapM hargpat ds >>= return . hsep
hargpat (BaseDIS b) = return $ empty
hargpat (Constructor c) = return $ text c
hargpat (Declare cty d) = hargpat d
hargpat (Exp e) = getNewName >>= return . text
hargpat (Record n ns) = return $ empty
hargpat (Tuple) = return $ text "()"
hargpat (UserDIS f t) = return $ empty
hargpat (Var v) = return $ text v
-}
hargpats ds = mapM hargpat ds >>= \xs->
let (eqnss,pats) = unzip xs in
return (concat eqnss, pats)
hargpat (Apply (UserDIS True f t) ds) = getNewName >>= \n->
hargpats ds >>= \(eqns,pats)->
return ((text "let" <+>
hsep pats <+> equals <+>
text f <+> text n): eqns,
text n)
hargpat (Apply (UserDIS False f t) ds) = getNewName >>= \n->
hargpats ds >>= \(eqns,pats)->
return ((hsep pats <+> text "<-" <+>
text f <+> text n): eqns,
text n)
hargpat (Apply Tuple ds) = hargpats ds >>= \(eqns,pats)->
return (eqns, parens (commaList pats))
hargpat (Apply (Constructor c) ds) = hargpats ds >>= \(eqns,pats)->
return (eqns,
parens (text c <+> hsep pats))
hargpat (Apply (Record n ns) ds) = hargpats ds >>= \(eqns,pats)->
return (eqns,
parens (text n <+> feqList ns pats))
hargpat (Apply d ds) = hargpats ds >>= \(eqns,pats)->
return (eqns, hsep pats)
hargpat (BaseDIS b) = return $ ([],empty)
hargpat (Constructor c) = return $ ([],text c)
hargpat (Declare cty d) = hargpat d
hargpat (Exp e) = getNewName >>= \n-> return ([],text n)
hargpat (Record n ns) = return $ ([],empty)
hargpat (Tuple) = return $ ([],text "()")
hargpat (UserDIS _ f t) = return $ ([],empty)
hargpat (Var v) = return $ ([],text v)
--
hrtncons ds = mapM hrtncon ds >>= \xs->
let (eqnss,cs) = unzip xs in
return (concat eqnss, cs)
hrtncon (Apply Tuple ds) = hrtncons ds >>= \(eqns,cs)->
return $ (eqns, parens (commaList cs))
hrtncon (Apply (Constructor c) ds)= hrtncons ds >>= \(eqns,cs)->
return $ (eqns, parens (text c <+> hsep cs))
hrtncon (Apply (Record n ns) ds) = hrtncons ds >>= \(eqns,cs)->
return $ (eqns, parens (text n <+> feqList ns cs))
hrtncon (Apply (UserDIS True f t) ds)= hrtncons ds >>= \(eqns,cs)->
return $ (eqns, parens (text t <+> hsep cs))
hrtncon (Apply (UserDIS False f t) ds)= getNewName >>= \n->
hrtncons ds >>= \(eqns,cs)->
return $ ((text n <+> text "<-" <+>
text t <+> hsep cs):eqns
, text n)
hrtncon (Apply d ds) = hrtncons ds >>= \(eqns,cs)->
return $ (eqns, hsep cs)
hrtncon (BaseDIS b) = return $ ([], empty)
hrtncon (Constructor c) = return $ ([], text c)
hrtncon (Declare cty d) = hrtncon d
hrtncon (Exp e) = getNewName >>= \n-> return ([], text n)
hrtncon (Record n ns) = return $ ([], empty)
hrtncon (Tuple) = getNewName >>= \n-> return ([], text n)
-- return $ text "()"
hrtncon (UserDIS _ f t) = return $ ([], empty)
hrtncon (Var v) = return $ ([], text v)
--
{-hargcall (Apply (Declare cty (Var v)) ds) = text v-}
--hargcall (Apply (UserDIS f t) ds) = mapM hargcall ds >>= \as->
-- return $ parens (text f <+> hsep as)
--hargcall (Apply (BaseDIS StablePtr) [d]) = hargcall d >>= return . parens . (text "StablePtr" <+>)
hargcall (Apply d ds) = mapM hargcall ds >>= return . hsep
hargcall (BaseDIS b) = return $ empty
hargcall (Constructor c) = return $ empty
hargcall (Declare cty d) = hargcall d
hargcall (Exp e) = getNewName >>= return . text
hargcall (Record n ns) = mapM (hargcall . Var) ns >>= return . hsep
hargcall (Tuple) = return $ text "()"
hargcall (UserDIS _ f t) = return $ empty
hargcall (Var v) = return $ text v
--
--hrtnpat (Apply (BaseDIS StablePtr) [r]) = hrtnpat r >>= return . parens . (text "StablePtr" <+>)
hrtnpat (Apply d [r]) = hrtnpat r
hrtnpat (Apply d ds) = mapM hrtnpat ds >>=
return . parens . commaList
hrtnpat (BaseDIS b) = return $ empty
hrtnpat (Constructor c) = return $ empty
hrtnpat (Declare cty d) = hrtnpat d
hrtnpat (Exp e) = getNewName >>= return . text
hrtnpat (Record n ns) = mapM (hrtnpat . Var) ns >>=
return . parens . commaList
hrtnpat (Tuple) = getNewName >>= return . text
-- return $ text "()"
hrtnpat (UserDIS _ f t) = return $ empty
hrtnpat (Var v) = return $ text v
--------
cdecls :: [String] -> [DIS] -> [Doc]
--cdefs :: DIS -> [Doc]
crtn :: DIS -> Doc
cdecls env ((Apply d ds):rest) = cdecls env (d:ds++rest)
cdecls env ((Declare cty (Var v)):ds)
| v `notElem` env = (text cty <+> text v): cdecls (v:env) ds
cdecls env (d:ds) = cdecls env ds
cdecls env [] = []
ctype (Apply Tuple ds) = text "NodePtr"
ctype (Apply (Var "iO") [d]) = ctype d
ctype (Apply (UserDIS _ _ _) [d])= ctype d
ctype (Apply (Constructor _) [d])= ctype d
ctype (Apply d ds) = ctype d
ctype (Declare cty (Var v)) = text cty
ctype (Tuple) = text "void"
ctype (BaseDIS b) = text (baseToCType b)
ctype _ = text "NodePtr"
--
--cdefs (Apply (BaseDIS b) [r]) = [collect b (baseToCType b) r]
--cdefs (Apply d ds) = cdefs d ++ concatMap cdefs ds
--cdefs d = []
--
--collect hty cty (Apply (Declare _ _) [r]) = collect hty cty r
--collect hty cty (Declare cast d) = collect hty cast d
--collect hty cty (Var v) =
-- text v <+> equals <+> parens (text cty) <> text (baseTyToCall hty)
--collect hty cty (Exp e) =
-- text (pc e) <+> equals <+> parens (text cty) <> text (baseTyToCall hty)
--collect hty cty d = error ("BaseDIS "++show hty++" applied to "++show d)
pc :: String -> String
pc = filter (/='%')
--
crtn (Apply (BaseDIS b) [r]) = crtn' (baseTyToRtn b) r
crtn (Apply d [r]) = crtn r
crtn (Apply d ds) =
let rs = map crtn ds
n = length rs
in
text "nhc_mkTuple" <> text (show n) <> parens (commaList rs)
crtn (Tuple) = text "nhc_mkUnit()"
crtn d = empty
crtn' wrap (Apply d [r]) = crtn' wrap r
crtn' wrap (Declare cty d) = crtn' wrap d
crtn' wrap (Exp e) = text (wrap (pc e))
crtn' wrap (Var v) = text (wrap v)
crtn' wrap d = error ("BaseDIS applied to complex DIS: "++
wrap (show d))
crtnpat (Apply d [r]) = crtnpat r
crtnpat (Declare cty d) = crtnpat d
crtnpat (Exp e) = return $ text e
crtnpat (Var v) = return $ text v
--------
cblock :: [Doc] -> Doc
cblock ds =
text "{" $$
nest 2 (foldr (\a as-> a<>semi $$ as) empty ds) $$
text "}" $$
text ""
feqList :: [Name] -> [Doc] -> Doc
feqList ns pats = braces (commaList (zipWith feq ns pats))
where feq name pat = text name <> text "=" <> pat
nyi s = error ("Not yet implemented: "++s)
clean :: DIS -> Bool
clean (Apply d ds) = clean d && and (map clean ds)
--clean (BaseDIS StablePtr) = True -- previously False (until 1999-07-07)
clean (BaseDIS StablePtr) = False -- back to False again! (1999-11-19)
clean (BaseDIS b) = True
clean (Constructor c) = False
clean (Declare cty d) = True
clean (Exp e) = True
clean (Record n ns) = False
clean (Tuple) = False -- previously True (until 2001-05-24)
clean (UserDIS _ f t) = False
clean (Var v) = True
-- Following function is new and may not be correct yet.
simple :: DIS -> Bool
simple (Apply d [d']) = simple d && simple d'
simple (Apply d ds) = False
simple (BaseDIS StablePtr) = False
simple (BaseDIS (Foreign _)) = False
simple (BaseDIS b) = True
simple (Constructor c) = True
simple (Declare cty d) = simple d
simple (Exp e) = True
simple (Record n ns) = True
simple (Tuple) = False
simple (UserDIS _ f t) = True
simple (Var v) = True
isVoid :: DIS -> Bool
isVoid (Apply (Var "iO") [Tuple]) = True
isVoid (Tuple) = True
isVoid _ = False
--------
|
