-- Lisp-style s-expression support

module SExpression where

import List
import qualified Tree as N

data SExp = Item String | List [SExp]

instance Show SExp where
  show (Item s) = s
  show (List is) = "(" ++ (concat $ intersperse " " $ map show is) ++ ")"

dyadicName :: N.Node -> String
dyadicName n = case n of
  N.Add -> "+"
  N.Subtr -> "-"
  N.Mul -> "*"
  N.Div -> "/"
  N.Rem -> "mod"
  N.Plus -> "plus"
  N.Minus -> "minus"
  N.Times -> "times"
  N.BitAnd -> "bitand"
  N.BitOr -> "bitor"
  N.BitXor -> "bitxor"
  N.And -> "and"
  N.Or -> "or"
  N.Eq -> "="
  N.NEq -> "<>"
  N.Less -> "<"
  N.More -> ">"
  N.LessEq -> "<="
  N.MoreEq -> ">="
  N.After -> "after"

monadicName :: N.Node -> String
monadicName n = case n of
  N.MonSub -> "-"
  N.MonBitNot -> "bitnot"
  N.MonNot -> "not"
  N.MonSize -> "size"

nodeToSExp :: N.Node -> SExp
nodeToSExp node
  = case node of
      N.Decl a b -> wrap2 ":" (top a) (top b)
      N.Alt a -> wrapl "alt" (map top a)
      N.AltRep a b -> wrap2 "alt-rep" (top a) (top b)
      N.PriAlt a -> wrapl "pri-alt" (map top a)
      N.PriAltRep a b -> wrap2 "pri-alt-rep" (top a) (top b)
      N.In a b -> wrapl1 "?" (top a) (map top b)
      N.Variant a b -> wrap2 "variant" (top a) (top b)
      N.InCase a b -> wrapl1 "?case" (top a) (map top b)
      N.InCaseGuard a b c -> wrapl2 "?case-guarded" (top a) (top b) (map top c)
      N.InTag a b -> wrap2 "?case-tag" (top a) (top b)
      N.InAfter a b -> wrap2 "?after" (top a) (top b)
      N.Out a b -> wrapl1 "!" (top a) (map top b)
      N.OutCase a b c -> wrapl2 "!case" (top a) (top b) (map top c)
      N.ExpList a -> wrapl "exp-list" (map top a)
      N.Assign a b -> wrap2 ":=" (List $ map top a) (top b)
      N.If a -> wrapl "if" (map top a)
      N.IfRep a b -> wrap2 "if-rep" (top a) (top b)
      N.While a b -> wrap2 "while" (top a) (top b)
      N.Par a -> wrapl "par" (map top a)
      N.ParRep a b -> wrap2 "par-rep" (top a) (top b)
      N.PriPar a -> wrapl "pri-par" (map top a)
      N.PriParRep a b -> wrap2 "pri-par-rep" (top a) (top b)
      N.PlacedPar a -> wrapl "placed-par" (map top a)
      N.PlacedParRep a b -> wrap2 "placed-par-rep" (top a) (top b)
      N.Processor a b -> wrap2 "processor" (top a) (top b)
      N.Skip -> Item "skip"
      N.Stop -> Item "stop"
      N.Case a b -> wrapl1 "case" (top a) (map top b)
      N.Seq a -> wrapl "seq" (map top a)
      N.SeqRep a b -> wrap2 "seq-rep" (top a) (top b)
      N.ProcCall a b -> wrapl1 "proc-call" (top a) (map top b)
      N.MainProcess -> Item "main"
      N.Vars a b -> wrapl1 "vars" (top a) (map top b)
      N.Is a b -> wrap2 "is" (top a) (top b)
      N.IsType a b c -> wrap3 "is-type" (top a) (top b) (top c)
      N.ValIs a b -> wrap2 "val-is" (top a) (top b)
      N.ValIsType a b c -> wrap3 "val-is-type" (top a) (top b) (top c)
      N.Place a b -> wrap2 "place-at" (top a) (top b)
      N.DataType a b -> wrap2 "data-type" (top a) (top b)
      N.Record a -> wrapl "record" (map top a)
      N.PackedRecord a -> wrapl "packed-record" (map top a)
      N.Fields a b -> wrapl1 "fields" (top a) (map top b)
      N.Protocol a b -> wrapl1 "protocol" (top a) (map top b)
      N.TaggedProtocol a b -> wrapl1 "protocol-tagged" (top a) (map top b)
      N.Tag a b -> wrapl1 "tag" (top a) (map top b)
      N.Formal a b -> wrap2 "formal" (top a) (top b)
      N.Proc a b c -> wrap3 "proc" (top a) (List $ map top b) (top c)
      N.Func a b c d -> wrap4 "function" (top a) (List $ map top b) (List $ map top c) (top d)
      N.FuncIs a b c d -> wrap4 "function-is" (top a) (List $ map top b) (List $ map top c) (top d)
      N.Retypes a b c -> wrap3 "retypes" (top a) (top b) (top c)
      N.ValRetypes a b c -> wrap3 "val-retypes" (top a) (top b) (top c)
      N.Reshapes a b c -> wrap3 "reshapes" (top a) (top b) (top c)
      N.ValReshapes a b c -> wrap3 "val-reshapes" (top a) (top b) (top c)
      N.ValOf a b -> wrap2 "valof" (top a) (top b)
      N.Sub a b -> wrap2 "sub" (top a) (top b)
      N.SubFromFor a b c -> wrap3 "sub-from-for" (top a) (top b) (top c)
      N.SubFrom a b -> wrap2 "sub-from" (top a) (top b)
      N.SubFor a b -> wrap2 "sub-for" (top a) (top b)
      N.CaseExps a b -> wrap2 "case-exps" (List $ map top a) (top b)
      N.Else a -> wrap "else" (top a)
      N.For a b c -> wrap3 "for" (top a) (top b) (top c)
      N.Conv a b -> wrap2 "conv" (top a) (top b)
      N.Round a b -> wrap2 "round" (top a) (top b)
      N.Trunc a b -> wrap2 "trunc" (top a) (top b)
      N.DyadicOp o a b -> wrap2 (dyadicName o) (top a) (top b)
      N.MonadicOp o a -> wrap (monadicName o) (top a)
      N.MostPos a -> wrap "mostpos" (top a)
      N.MostNeg a -> wrap "mostneg" (top a)
      N.Size a -> wrap "size" (top a)
      N.Call a b -> wrapl1 "call" (top a) (map top b)
      N.BytesIn a -> wrap "bytesin" (top a)
      N.OffsetOf a b -> wrap2 "offsetof" (top a) (top b)
      N.Guarded a b -> wrap2 "guarded" (top a) (top b)
      N.Val a -> wrap "val" (top a)
      N.ChanOf a -> wrap "chan" (top a)
      N.PortOf a -> wrap "port" (top a)
      N.Timer -> Item "timer"
      N.Array a b -> wrap2 "array" (top a) (top b)
      N.ArrayUnsized a -> wrap "array-unsized" (top a)
      N.Counted a b -> wrap2 "::" (top a) (top b)
      N.Bool -> Item "bool"
      N.Byte -> Item "byte"
      N.Int -> Item "int"
      N.Int16 -> Item "int16"
      N.Int32 -> Item "int32"
      N.Int64 -> Item "int64"
      N.Real32 -> Item "real32"
      N.Real64 -> Item "real64"
      N.Any -> Item "any"
      N.TypedLit a b -> wrap2 "typed-literal" (top a) (top b)
      N.LitReal a -> wrap "real-literal" (Item a)
      N.LitInt a -> wrap "integer-literal" (Item a)
      N.LitHex a -> wrap "hex-literal" (Item a)
      N.LitByte a -> wrap "byte-literal" (Item ("'" ++ a ++ "'"))
      N.LitString a -> wrap "string-literal" (Item ("\"" ++ a ++ "\""))
      N.LitArray a -> wrapl "array-literal" (map top a)
      N.True -> Item "true"
      N.False -> Item "false"
      N.Name a -> wrap "name" (Item a)
      _ -> error $ "Unsupported node: " ++ (show node)
    where top = nodeToSExp
          wrap name arg = List [Item name, arg]
          wrap2 name arg1 arg2 = List [Item name, arg1, arg2]
          wrap3 name arg1 arg2 arg3 = List [Item name, arg1, arg2, arg3]
          wrap4 name arg1 arg2 arg3 arg4 = List [Item name, arg1, arg2, arg3, arg4]
          wrapl name args = List ((Item name) : args)
          wrapl1 name arg1 args = List ((Item name) : arg1 : args)
          wrapl2 name arg1 arg2 args = List ((Item name) : arg1 : arg2 : args)

nodeToSOccam :: N.Node -> SExp
nodeToSOccam node
  = case node of
      N.Decl a b -> wrap2 ":" (top a) (top b)
      N.Alt a -> wrapl "alt" (map top a)
      N.AltRep a b -> wrap2 "alt" (top a) (top b)
      N.PriAlt a -> wrapl "pri-alt" (map top a)
      N.PriAltRep a b -> wrap2 "pri-alt" (top a) (top b)
      N.In a b -> wrapl1 "?" (top a) (map top b)
      N.Variant a b -> l2 (top a) (top b)
      N.InCase a b -> wrapl1 "?case" (top a) (map top b)
      N.InCaseGuard a b c -> wrapl2 "?case-guarded" (top a) (top b) (map top c)
      N.InTag a b -> wrap2 "?case" (top a) (top b)
      N.InAfter a b -> wrap2 "?after" (top a) (top b)
      N.Out a b -> wrapl1 "!" (top a) (map top b)
      N.OutCase a b c -> wrapl2 "!case" (top a) (top b) (map top c)
      N.ExpList a -> List (map top a)
      N.Assign a b -> wrap2 ":=" (List $ map top a) (top b)
      N.If a -> wrapl "if" (map top a)
      N.IfRep a b -> wrap2 "if" (top a) (top b)
      N.While a b -> wrap2 "while" (top a) (top b)
      N.Par a -> wrapl "par" (map top a)
      N.ParRep a b -> wrap2 "par" (top a) (top b)
      N.PriPar a -> wrapl "pri-par" (map top a)
      N.PriParRep a b -> wrap2 "pri-par" (top a) (top b)
      N.PlacedPar a -> wrapl "placed-par" (map top a)
      N.PlacedParRep a b -> wrap2 "placed-par" (top a) (top b)
      N.Processor a b -> wrap2 "processor" (top a) (top b)
      N.Skip -> Item "skip"
      N.Stop -> Item "stop"
      N.Case a b -> wrapl1 "case" (top a) (map top b)
      N.Seq a -> wrapl "seq" (map top a)
      N.SeqRep a b -> wrap2 "seq" (top a) (top b)
      N.ProcCall a b -> List ((top a) : (map top b))
      N.MainProcess -> Item "main"
      N.Vars a b -> List ((top a) : (map top b))
      N.Is a b -> wrap2 "is" (top a) (top b)
      N.IsType a b c -> wrap3 "is" (top a) (top b) (top c)
      N.ValIs a b -> wrap2 "val-is" (top a) (top b)
      N.ValIsType a b c -> wrap3 "val-is" (top a) (top b) (top c)
      N.Place a b -> wrap2 "place-at" (top a) (top b)
      N.DataType a b -> wrap2 "data-type" (top a) (top b)
      N.Record a -> wrapl "record" (map top a)
      N.PackedRecord a -> wrapl "packed-record" (map top a)
      N.Fields a b -> List ((top a) : (map top b))
      N.Protocol a b -> wrapl1 "protocol" (top a) (map top b)
      N.TaggedProtocol a b -> wrapl1 "protocol" (top a) (map top b)
      N.Tag a b -> List ((top a) : (map top b))
      N.Formal a b -> l2 (top a) (top b)
      N.Proc a b c -> wrap3 "proc" (top a) (List $ map top b) (top c)
      N.Func a b c d -> wrap4 "function" (top a) (List $ map top b) (List $ map top c) (top d)
      N.FuncIs a b c d -> wrap4 "function-is" (top a) (List $ map top b) (List $ map top c) (top d)
      N.Retypes a b c -> wrap3 "retypes" (top a) (top b) (top c)
      N.ValRetypes a b c -> wrap3 "val-retypes" (top a) (top b) (top c)
      N.Reshapes a b c -> wrap3 "reshapes" (top a) (top b) (top c)
      N.ValReshapes a b c -> wrap3 "val-reshapes" (top a) (top b) (top c)
      N.ValOf a b -> wrap2 "valof" (top a) (top b)
      N.Sub a b -> wrap2 "sub" (top a) (top b)
      N.SubFromFor a b c -> wrap3 "sub-from-for" (top a) (top b) (top c)
      N.SubFrom a b -> wrap2 "sub-from" (top a) (top b)
      N.SubFor a b -> wrap2 "sub-for" (top a) (top b)
      N.CaseExps a b -> l2 (List $ map top a) (top b)
      N.Else a -> wrap "else" (top a)
      N.For a b c -> wrap3 "for" (top a) (top b) (top c)
      N.Conv a b -> wrap2 "conv" (top a) (top b)
      N.Round a b -> wrap2 "round" (top a) (top b)
      N.Trunc a b -> wrap2 "trunc" (top a) (top b)
      N.DyadicOp o a b -> wrap2 (dyadicName o) (top a) (top b)
      N.MonadicOp o a -> wrap (monadicName o) (top a)
      N.MostPos a -> wrap "mostpos" (top a)
      N.MostNeg a -> wrap "mostneg" (top a)
      N.Size a -> wrap "size" (top a)
      N.Call a b -> wrapl1 "call" (top a) (map top b)
      N.BytesIn a -> wrap "bytesin" (top a)
      N.OffsetOf a b -> wrap2 "offsetof" (top a) (top b)
      N.Guarded a b -> wrap2 "guarded" (top a) (top b)
      N.Val a -> wrap "val" (top a)
      N.ChanOf a -> wrap "chan" (top a)
      N.PortOf a -> wrap "port" (top a)
      N.Timer -> Item "timer"
      N.Array a b -> wrap2 "array" (top a) (top b)
      N.ArrayUnsized a -> wrap "array" (top a)
      N.Counted a b -> wrap2 "::" (top a) (top b)
      N.Bool -> Item "bool"
      N.Byte -> Item "byte"
      N.Int -> Item "int"
      N.Int16 -> Item "int16"
      N.Int32 -> Item "int32"
      N.Int64 -> Item "int64"
      N.Real32 -> Item "real32"
      N.Real64 -> Item "real64"
      N.Any -> Item "any"
      N.TypedLit a b -> l2 (top a) (top b)
      N.LitReal a -> Item a
      N.LitInt a -> Item a
      N.LitHex a -> Item a
      N.LitByte a -> Item ("'" ++ a ++ "'")
      N.LitString a -> Item ("\"" ++ a ++ "\"")
      N.LitArray a -> List (map top a)
      N.True -> Item "true"
      N.False -> Item "false"
      N.Name a -> Item a
      _ -> error $ "Unsupported node: " ++ (show node)
    where top = nodeToSOccam
          wrap name arg = List [Item name, arg]
          wrap2 name arg1 arg2 = List [Item name, arg1, arg2]
          wrap3 name arg1 arg2 arg3 = List [Item name, arg1, arg2, arg3]
          wrap4 name arg1 arg2 arg3 arg4 = List [Item name, arg1, arg2, arg3, arg4]
          wrapl name args = List ((Item name) : args)
          wrapl1 name arg1 args = List ((Item name) : arg1 : args)
          wrapl2 name arg1 arg2 args = List ((Item name) : arg1 : arg2 : args)
          l2 arg1 arg2 = List [arg1, arg2]