toSML.hs

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

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

-- TODO: might need op sometimes
idToSML :: (Show a) => Id a -> Doc
idToSML (Short x) = 
  if List.elem (show x) ["*", "/", "div", "mod", "+", "-", "^", "::", "@", "<", ">", "<=", ">=", "<>", ":=", "o", "before"] then
    text "op" <+> text (show x)
  else if show x == "=" then
    text "Cake_stub.my_eq"
  else
    text (show x)
idToSML (Long m x) = 
  text (show m) <> text "." <> text (show x)

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

tcToSML :: Tc -> Doc
tcToSML (TC_name n) = idToSML n
tcToSML TC_int = text "Int.int"
tcToSML TC_char = text "Char.char"
tcToSML TC_string = text "String.string"
tcToSML TC_ref = text "Cake_stub.ref"
tcToSML TC_word8 = text "Word8.word"
tcToSML TC_word8array = text "Word8Array.array"
tcToSML TC_exn = text "Cake_stub.exn"
tcToSML TC_vector = text "Vector.vector"
tcToSML TC_array = text "Array.array"
tcToSML _ = error "internal type representation"

typeToSML :: T -> Doc
typeToSML (Tvar t) = 
  text (show t)
typeToSML (Tapp [t1,t2] TC_fn) =
  parens (typeToSML t1) <+> text "->" <+> parens (typeToSML t2)
typeToSML (Tapp [] TC_tup) =
  text "Cake_stub.unit"
typeToSML (Tapp ts TC_tup) =
  parens (sep (punctuate (text " *") (List.map typeToSML ts)))
typeToSML (Tapp [] tc) =
  tcToSML tc
typeToSML (Tapp [t] tc) =
  typeToSML t <+> tcToSML tc
typeToSML (Tapp ts tc) =
  parens (sep (punctuate comma (List.map typeToSML ts))) <+> tcToSML tc
typeToSML _ =
  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

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

lopToSML :: Lop -> Doc
lopToSML (And _) = text "andalso"
lopToSML (Or _) = text "orelse"

patToSML :: Pat -> Doc
patToSML (Pvar v) = 
  idToSML (Short v)
patToSML (Plit l _) =
  litToSML l
patToSML (Pcon Nothing es _) =
  parens (sep (punctuate comma (List.map patToSML es)))
patToSML (Pcon (Just c) [] _) =
  conIdToSML c
patToSML (Pcon (Just c) es _) =
  conIdToSML c <+> parens (sep (punctuate comma (List.map patToSML es)))
patToSML (Pref p _) =
  parens ((text "ref") <+> patToSML 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
opToSML :: Op -> Doc
opToSML (Opn Plus _) = text "Int.+"
opToSML (Opn Minus _) = text "Int.-"
opToSML (Opn Times _) = text "Int.*"
opToSML (Opn Divide _) = text "Int.div"
opToSML (Opn Modulo _) = text "Int.mod"
opToSML (Opb Lt _) = text "Int.<"
opToSML (Opb Gt _) = text "Int.>"
opToSML (Opb Leq _) = text "Int.<="
opToSML (Opb Geq _) = text "Int.>="
opToSML (Equality _) = text "op ="
opToSML (Opassign _) = text "Cake_stub.:="
opToSML (Opref _) = text "ref"
opToSML (Opderef _) = text "Cake_stub.!"
opToSML (Aw8alloc _) = text "Word8Array.array"
opToSML (Aw8sub _) = text "Word8Array.sub"
opToSML (Aw8length _) = text "Word8Array.length"
opToSML (Aw8update _) = text "Word8Array.update"
opToSML (Ord _) = text "Char.ord"
opToSML (Ast.Chr _) = text "Char.chr"
opToSML (Chopb Lt _) = text "Char.<"
opToSML (Chopb Gt _) = text "Char.>"
opToSML (Chopb Leq _) = text "Char.<="
opToSML (Chopb Geq _) = text "Char.>="
opToSML (Implode _) = text "String.implode"
opToSML (Explode _) = text "String.explode"
opToSML (Strlen _) = text "String.size"
opToSML (VfromList _) = text "Vector.fromList"
opToSML (Vsub _) = text "Vector.sub"
opToSML (Vlength _) = text "Vector.length"
opToSML (Aalloc _) = text "Array.array"
opToSML (Asub _) = text "Array.sub"
opToSML (Alength _) = text "Array.length"
opToSML (Aupdate _) = text "Array.update"
opToSML (FFI n _) = error "No ffi for SML"

expToSML :: ExpCtxt -> Exp -> Doc
expToSML c (Raise e) =
  expParen c (text "raise" <+> expToSML AppC e)
expToSML c (Handle e pes) =
  parens ((expToSML AtomicC e <+> text "handle") <-> 
          nest 2 (sep (punctuate (text "|") (List.map patExpToSML pes))))
expToSML c (Lit l _) =
  litToSML l
expToSML c (Con Nothing es _) =
  parens (sep (punctuate comma (List.map (expToSML AtomicC) es)))
expToSML c (Con (Just con) [] _) =
  conIdToSML con
expToSML c (Con (Just con) es _) =
  expParen c (conIdToSML con <+> parens (sep (punctuate comma (List.map (expToSML AtomicC) es))))
expToSML c (Var v) =
  idToSML v
expToSML c (Fun x e _) =
  parens ((text "fn" <+> idToSML (Short x) <+> text "=>") <-> nest 2 (expToSML AtomicC e))
expToSML c (App Opapp es) =
  expParen c (sep (List.map (expToSML AppC) (List.reverse (expAppToList (App Opapp es)))))
expToSML c (App op es) =
  expParen c (opToSML op <+> parens (sep (punctuate comma (List.map (expToSML AtomicC) es))))
expToSML c (Log lop e1 e2) =
  expParen c (((expToSML AppC e1) <+> lopToSML lop) <-> nest 2 (expToSML AppC e2))
expToSML c (If e1 e2 e3) =
  parens ((text "if" <+> expToSML AtomicC e1 <+> text "then") <-> 
           nest 2 (expToSML AtomicC e2) <-> 
	   text "else" <-> nest 2 (expToSML AtomicC e3))
expToSML c (Mat e pes) =
  parens ((text "case" <+> expToSML AtomicC e <+> text "of") <-> 
          nest 2 (sep (punctuate (text "|") (List.map patExpToSML pes))))
expToSML c (Let Nothing e1 e2) =
  parens ((expToSML AtomicC e1 <> semi) <-> expToSML AtomicC e2)
expToSML c (Let (Just v) e1 e2) =
  (text "let val" <+> idToSML (Short v) <+> equals) <-> 
   nest 2 (expToSML AtomicC e1) <-> text "in" <-> nest 2 (expToSML AtomicC e2) <-> text "end"
expToSML c (Letrec funs e) =
  parens (letrecToSML (text "let fun") funs <->
          text "in" <-> 
	  nest 2 (expToSML AtomicC e) <->
          text "end")
 
patExpToSML :: (Pat,Exp) -> Doc
patExpToSML (p,e) =
  (patToSML p <+> text "=>") <-> nest 2 (expToSML AtomicC e)

letrecToSML :: Doc -> [(VarN, VarN, Exp)] -> Doc
letrecToSML head [] = error "empty letrec"
letrecToSML head [(f,x,e)] =
  (head <+> idToSML (Short f) <+> idToSML (Short x) <+> equals) <->
  nest 2 (expToSML AtomicC e)
letrecToSML head ((f,x,e):funs) =
  (head <+> idToSML (Short f) <+> idToSML (Short x) <+> equals) <->
  nest 2 (expToSML AtomicC e) <->
  letrecToSML (text "and") funs

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

conToSML :: (ConN, [T]) -> Doc
conToSML (cn,[]) =
  idToSML (Short cn)
conToSML (cn,ts) =
  idToSML (Short cn) <+> text "of" <+> sep (punctuate (text "*") (List.map typeToSML ts))

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

decToSML :: Dec -> Doc
decToSML (Dlet p e _) =
  text "val" <+> patToSML p <+> equals $+$ 
  nest 2 (expToSML AtomicC e <> semi)
decToSML (Dletrec funs) =
  letrecToSML (text "fun") funs <> semi
decToSML (Dtype td) =
  text "datatype" <+> sep (punctuate (text "and") (List.map dataToSML td)) <> semi
decToSML (Dtabbrev tvs tn t) =
  text "type" <+> tvsToSML tvs <+> text (show tn) <+> equals $+$ 
  nest 2 (typeToSML t <> semi)
decToSML (Dexn cn ts) =
  text "exception" <+> conToSML (cn,ts) <> semi

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

progToSML :: Prog -> Doc
progToSML p = vcat (List.map topToSML p)