toOCaml.hs

module ToOCaml where
import Ast
import Data.List as List
import Text.PrettyPrint
import Data.Char as Char

infixl <->
(<->) x y = sep [x,y]

idParens :: String -> Doc
idParens s =
  if List.head s == '*' then
    text ("( " ++ s ++ " )")
  else if Char.isAlphaNum (List.head s) && not (s == "mod") then
    text s
  else
    parens (text s)

-- TODO detect idents that won't work, try to infix some
idToOCaml :: (Show a) => Id a -> Doc
idToOCaml (Short x) = 
  idParens (show x)
idToOCaml (Long m x) = 
  text (show m) <> text "." <> idParens (show x)

conIdToOCaml :: Id ConN -> Doc
conIdToOCaml (Short x) = 
  if show x == "nil" then
    text "[]"
  else
    idToOCaml (Short x)
conIdToOCaml (Long m x) = 
  text (show m) <> text "." <> idParens (show x)

tcToOCaml :: Tc -> Doc
tcToOCaml (TC_name n) = idToOCaml n
tcToOCaml TC_int = text "Cake_stub.int"
tcToOCaml TC_char = text "Cake_stub.char"
tcToOCaml TC_string = text "Cake_stub.string"
tcToOCaml TC_ref = text "Pervasives.ref"
tcToOCaml TC_word8 = text "Cake_stub.char"
tcToOCaml TC_word8array = text "Cake_stub.bytes"
tcToOCaml TC_exn = text "Cake_stub.exn"
tcToOCaml TC_vector = text "Cake_stub.array"
tcToOCaml TC_array = text "Cake_stub.array"
tcToOCaml _ = error "internal type representation"

typeToOCaml :: T -> Doc
typeToOCaml (Tvar t) = 
  text (show t)
typeToOCaml (Tapp [t1,t2] TC_fn) =
  parens (typeToOCaml t1) <+> text "->" <+> parens (typeToOCaml t2)
typeToOCaml (Tapp ts TC_tup) =
  parens (sep (punctuate (text " *") (List.map typeToOCaml ts)))
typeToOCaml (Tapp [] tc) =
  tcToOCaml tc
typeToOCaml (Tapp [t] tc) =
  typeToOCaml t <+> tcToOCaml tc
typeToOCaml (Tapp ts tc) =
  parens (sep (punctuate comma (List.map typeToOCaml ts))) <+> tcToOCaml tc
typeToOCaml _ =
  error "internal type representation"

escape :: String -> String
escape [] = 
  []
escape (c:s) =
  if c == '\t' then
    '\\' : 't' : escape s
  else if c == '\n' then
    '\\' : 'n' : escape s
  else if c == '"' || c == '\\' then
    '\\' : c : escape s
  else
    c : escape s

litToOCaml :: Lit -> Doc
litToOCaml (IntLit i) =
  integer i
litToOCaml (Char c) =
  if c == '\t' then
    quotes (text "\\t")
  else if c == '\n' then
    quotes (text "\\n")
  else if c == '\'' || c == '\\'then
    quotes (text ['\\',c])
  else
    quotes (char c)
litToOCaml (StrLit s) =
  doubleQuotes (text (escape s))
litToOCaml (Word8 w) =
  error "Word8 not supported" -- TODO

lopToOCaml :: Lop -> Doc
lopToOCaml (And _) = text "&&"
lopToOCaml (Or _) = text "||"

patToOCaml :: Pat -> Doc
patToOCaml (Pvar v) = 
  idParens (show v)
patToOCaml (Plit l _) =
  litToOCaml l
patToOCaml (Pcon Nothing es _) =
  parens (sep (punctuate comma (List.map patToOCaml es)))
patToOCaml (Pcon (Just c) [] _) =
  conIdToOCaml c
patToOCaml (Pcon (Just c) es _) =
  conIdToOCaml c <+> parens (sep (punctuate comma (List.map patToOCaml es)))
patToOCaml (Pref p _) =
  braces (text "Pervasives.contents =" <+> patToOCaml p)

data ExpCtxt = 
    AtomicC
  | AppC

expParen :: ExpCtxt -> Doc -> Doc
expParen AtomicC d = d
expParen AppC d = parens d

expAppToList :: Exp -> [Exp]
expAppToList (App Opapp [e1,e2]) =
  e2 : expAppToList e1
expAppToList e = 
  [e]

-- TODO: option to use bignums or not
-- TODO: The OCaml mod semantics are different from SML. Unsure about the div semantics.
-- TODO: Also, check the various exceptions.
opToOCaml :: Op -> Doc
opToOCaml (Opn Plus _) = text "Pervasives.(+)"
opToOCaml (Opn Minus _) = text "Pervasives.(-)"
opToOCaml (Opn Times _) = text "Pervasives.( * )"
opToOCaml (Opn Divide _) = text "Pervasives.(/)"
opToOCaml (Opn Modulo _) = text "Pervasives.(mod)"
opToOCaml (Opb Lt _) = text "Pervasives.(<)"
opToOCaml (Opb Gt _) = text "Pervasives.(>)"
opToOCaml (Opb Leq _) = text "Pervasives.(<=)"
opToOCaml (Opb Geq _) = text "Pervasives.(>=)"
opToOCaml (Equality _) = text "Pervasives.(=)"
opToOCaml (Opassign _) = text "Pervasives.(:=)"
opToOCaml (Opref _) = text "Pervasives.ref"
opToOCaml (Opderef _) = text "Pervasives.(!)"
opToOCaml (Aw8alloc _) = text "Bytes.make"
opToOCaml (Aw8sub _) = text "Bytes.get"
opToOCaml (Aw8length _) = text "Bytes.length"
opToOCaml (Aw8update _) = text "Bytes.set"
opToOCaml (Ord _) = text "Char.code"
opToOCaml (Ast.Chr _) = text "Char.chr"
opToOCaml (Chopb Lt _) = text "Pervasives.(<)"
opToOCaml (Chopb Gt _) = text "Pervasives.(>)"
opToOCaml (Chopb Leq _) = text "Pervasives.(<=)"
opToOCaml (Chopb Geq _) = text "Pervasives.(>=)"
opToOCaml (Implode _) = text "Cake_stub.implode"
opToOCaml (Explode _) = text "Cake_stub.explode"
opToOCaml (Strlen _) = text "String.length"
-- OCaml doesn't have vectors, so translate to arrays
opToOCaml (VfromList _) = text "Array.of_list"
opToOCaml (Vsub _) = text "Array.get"
opToOCaml (Vlength _) = text "Array.length"
opToOCaml (Aalloc _) = text "Array.make"
opToOCaml (Asub _) = text "Array.get"
opToOCaml (Alength _) = text "Array.length"
opToOCaml (Aupdate _) = text "Array.set"
opToOCaml (FFI n _) = error "No ffi for OCaml"

expToOCaml :: ExpCtxt -> Exp -> Doc
expToOCaml c (Raise e) =
  expParen c (text "raise" <+> expToOCaml AppC e)
expToOCaml c (Handle e pes) =
  parens ((text "try" <+> expToOCaml AtomicC e <+> text "with") <-> 
          nest 2 (sep (List.map patExpToOCaml pes)))
expToOCaml c (Lit l _) =
  litToOCaml l
expToOCaml c (Con Nothing es _) =
  parens (sep (punctuate comma (List.map (expToOCaml AtomicC) es)))
expToOCaml c (Con (Just con) [] _) =
  conIdToOCaml con
expToOCaml c (Con (Just con) es _) =
  expParen c (conIdToOCaml con <+> parens (sep (punctuate comma (List.map (expToOCaml AtomicC) es))))
expToOCaml c (Var v) =
  idToOCaml v
expToOCaml c (Fun x e _) =
  parens ((text "fun" <+> idParens (show x) <+> text "->") <-> nest 2 (expToOCaml AtomicC e))
expToOCaml c (App Opapp es) =
  expParen c (sep (List.map (expToOCaml AppC) (List.reverse (expAppToList (App Opapp es)))))
expToOCaml c (App op es) =
  expParen c (sep (opToOCaml op : List.map (expToOCaml AppC) es))
expToOCaml c (Log lop e1 e2) =
  expParen c (((expToOCaml AppC e1) <+> lopToOCaml lop) <-> nest 2 (expToOCaml AppC e2))
expToOCaml c (If e1 e2 e3) =
  parens ((text "if" <+> expToOCaml AtomicC e1 <+> text "then") <-> 
           nest 2 (expToOCaml AtomicC e2) <-> 
	   text "else" <-> nest 2 (expToOCaml AtomicC e3))
expToOCaml c (Mat e pes) =
  parens ((text "match" <+> expToOCaml AtomicC e <+> text "with") <-> 
          nest 2 (sep (List.map patExpToOCaml pes)))
expToOCaml c (Let Nothing e1 e2) =
  parens ((expToOCaml AtomicC e1 <> semi) <-> expToOCaml AtomicC e2)
expToOCaml c (Let (Just v) e1 e2) =
  parens ((text "let" <+> idParens (show v) <+> equals) <-> 
           nest 2 (expToOCaml AtomicC e1) <-> text "in" <-> nest 2 (expToOCaml AtomicC e2))
expToOCaml c (Letrec funs e) =
  parens (letrecToOCaml (text "let rec") funs <->
          text "in" <-> 
	  nest 2 (expToOCaml AtomicC e))
 
patExpToOCaml :: (Pat,Exp) -> Doc
patExpToOCaml (p,e) =
  (text "|" <+> patToOCaml p <+> text "->") <-> nest 2 (expToOCaml AtomicC e)

letrecToOCaml :: Doc -> [(VarN, VarN, Exp)] -> Doc
letrecToOCaml head [] = error "empty letrec"
letrecToOCaml head [(f,x,e)] =
  (head <+> idParens (show f) <+> idParens (show x) <+> equals) <->
  nest 2 (expToOCaml AtomicC e)
letrecToOCaml head ((f,x,e):funs) =
  (head <+> idParens (show f) <+> idParens (show x) <+> equals) <->
  nest 2 (expToOCaml AtomicC e) <->
  letrecToOCaml (text "and") funs

tvsToOCaml :: [TvarN] -> Doc
tvsToOCaml [] = empty
tvsToOCaml [t] = text (show t)
tvsToOCaml ts = parens (sep (punctuate comma (List.map (text . show) ts)))

conToOCaml :: (ConN, [T]) -> Doc
conToOCaml (cn,[]) =
  idParens (show cn)
conToOCaml (cn,ts) =
  idParens (show cn) <+> text "of" <+> sep (punctuate (text "*") (List.map typeToOCaml ts))

dataToOCaml :: ([TvarN], TypeN, [(ConN, [T])]) -> Doc
dataToOCaml (tvs, tn, cons) =
  (tvsToOCaml tvs <+> text (show tn) <+> equals) <->
  nest 2 (sep (List.map (\c -> text "|" <+> conToOCaml c) cons))

decToOCaml :: Dec -> Doc
decToOCaml (Dlet p e _) =
  text "let" <+> patToOCaml p <+> equals $+$ 
  nest 2 (expToOCaml AtomicC e <> semi <> semi)
decToOCaml (Dletrec funs) =
  letrecToOCaml (text "let rec") funs <> semi <> semi
decToOCaml (Dtype td) =
  text "type" <+> sep (punctuate (text "and") (List.map dataToOCaml td)) <> semi <> semi
decToOCaml (Dtabbrev tvs tn t) =
  text "type" <+> tvsToOCaml tvs <+> text (show tn) <+> equals $+$ 
  nest 2 (typeToOCaml t <> semi <> semi)
decToOCaml (Dexn cn ts) =
  text "exception" <+> conToOCaml (cn,ts) <> semi <> semi

topToOCaml :: Top -> Doc
topToOCaml (Tdec d) =
  decToOCaml d
topToOCaml (Tmod mn Nothing ds) =
  text "module" <+> text (show mn) <+> equals <+> text "struct" $+$ 
  nest 2 (sep (List.map decToOCaml ds)) $+$
  text "end"
topToOCaml (Tmod mn (Just sig) ds) =
  error "signatures not supported" -- TODO

progToOCaml :: Prog -> Doc
progToOCaml p = vcat (List.map topToOCaml p)