content: {-# LANGUAGE OverloadedStrings #-}
  module Pretty.Haskell where
  
  import Prelude hiding ((<>))
  
  import           WildcardSemantics
  
  import qualified Data.Text as T
  
  import           Text.PrettyPrint hiding (sep)
  
  ppHaskell :: Term -> Doc
  ppHaskell t = case t of
    Cons "ArrProcedure" [pat,cmd] ->
      text "proc " <> ppHaskell pat <> text " -> " <> ppHaskell cmd
    Cons "OpApp" [l,StringLiteral o,r] ->
      parens $ ppHaskell l <> space <> text (T.unpack o) <> space <> ppHaskell r
    Cons "AppBin" [f,x@(Cons "AppBin" _)] ->
      ppHaskell f <> space <> parens (ppHaskell x)
    Cons "AppBin" [f,x] ->
      ppHaskell f <> space <> ppHaskell x
    Cons "Var" [StringLiteral x] -> text (T.unpack x)
    Cons "Var" [Wildcard] -> ppWildcard
    Cons "Abs" [args, body] ->
      parens $ char '\\' <> ppSepList space args <> text " -> " <> ppHaskell body
    Cons "Let" [bnds, body] ->
      text "let " <> braces (ppLetBindings bnds) <>
      text " in " <> ppHaskell body
    Cons "If" [e1,e2,e3] ->
      text "if " <> ppHaskell e1 <>
      text " then " <> ppHaskell e2 <>
      text " else " <> ppHaskell e3
    Cons "Constr" [Cons "Unit" []] -> "()"
    Cons "Constr" [StringLiteral t'] -> text (T.unpack t')
    Cons "Product" [t'] -> parens (ppSepList comma t')
    Cons "Tuple" [t1,t2] -> parens (ppHaskell t1 <> comma <> space <> ppSepList (comma <> space) t2)
    Wildcard -> ppWildcard
    _ -> error $ "unexpected haskell expression: " ++ show t
  
  ppLetBindings :: Term -> Doc
  ppLetBindings t = case t of
    Wildcard -> ppWildcard
    _ -> error $ "unexpected term: " ++ show t
  
  ppSepList :: Doc -> Term -> Doc
  ppSepList sep t = case t of
    Cons "ECons" [x, Cons "Nil" []] -> ppHaskell x
    Cons "ECons" [x, xs] -> ppHaskell x <> sep <> ppSepList sep xs
    Cons "Cons" [x, Cons "Nil" []] -> ppHaskell x
    Cons "Cons" [x, xs] -> ppHaskell x <> sep <> ppSepList sep xs
    Cons "Nil" [] -> mempty
    Wildcard -> ppWildcard
    _ -> error $ "unexpected term: " ++ show t
  
  ppWildcard :: Doc
  ppWildcard = char '*'
  