module Language.Pointfree.Pretty
  ( pf2hs
  , type2hs
  )  where

import Language.Pointfree.Syntax as Pointfree
import Language.Haskell.Exts.Syntax as Exts


instance Show Term where
    showsPrec d (ID) = showString "id"
    showsPrec d (BANG) = showString "bang"
    showsPrec d (AP) = showString "app"
    showsPrec d (Curry aa) = -- showParen (d >= 10)
          (showString "curry" . showChar ' ' . showsPrec 10 aa)
    showsPrec d (aa :.: ab@(_ :.: _)) = showParen (d >= 10)
          (showsPrec 10 aa . showChar '.' . showsPrec 0 ab)
    showsPrec d (aa :.: ab) = showParen (d >= 10)
          (showsPrec 10 aa . showChar '.' . showsPrec 10 ab)
    showsPrec d (aa@(_ :\/: _) :\/: ab) = showParen (d >= 10)
          (showsPrec 0 aa . showString " \\/ " . showsPrec 10 ab)
    showsPrec d (aa :\/: ab) = showParen (d >= 10)
          (showsPrec 10 aa . showString " \\/ " . showsPrec 10 ab)
    showsPrec d (aa@(_ :/\: _) :/\: ab) = showParen (d >= 10)
          (showsPrec 0 aa . showString " /\\ " . showsPrec 10 ab)
    showsPrec d (aa :/\: ab) = showParen (d >= 10)
          (showsPrec 10 aa . showString " /\\ " . showsPrec 10 ab)
    showsPrec d (FST) = showString "fst"
    showsPrec d (SND) = showString "snd"
    showsPrec d (INL) = showString "inl"
    showsPrec d (INR) = showString "inr"
    showsPrec d (Point aa) = showParen (d >= 10)
          (showString "pnt" . showChar ' ' . showsPrec 10 aa)
    showsPrec d (IN) = showString "inn"
    showsPrec d (OUT) = showString "out"
    showsPrec d (Hylo typ aa ab) = showParen (d >= 10)
          (showString "hylo_{" . showsPrec 0 typ . showString "} " .
          showsPrec 10 aa . showChar ' ' . showsPrec 10 ab)
    showsPrec d (HyloO typ aa ab) = showParen (d >= 10)
          (showString "hyloO_{" . showsPrec 0 typ . showString "} " .
          showsPrec 10 aa . showChar ' ' . showsPrec 10 ab)
    showsPrec d (Macro ('(':sym) [aa,ab]) = showParen (d >= 10)
          (showsPrec 10 aa . showString (" "++(init sym)++" ") . showsPrec 10 ab)
--    showsPrec d (Macro "sum" [aa,ab]) = showParen (d >= 10)
--          (showsPrec 10 aa . showString " -|- " . showsPrec 10 ab)
    showsPrec d (Macro aa []) =
          showChar '\'' . showString aa . showChar '\''
    showsPrec d (Macro aa lst) = showParen (d >= 10)
          (showChar '\'' . showString aa . showString "' " .
           showsPrec 10 lst)

instance Show Pointfree.Type
    where
      show One       = "One"
      show (Base s)  = s
      show (Fix (Const One :++: Const One)) = "Bool"
      show (Fix (Const One :++: Id)) = "Int"
      show (Fix (Const One :++: (Const a :**: Id))) = "["++(show a)++"]"
      show (Fix t)    = "Fix ("++(show t)++")"
      show (t :*: u) = "("++(show t)++","++(show u)++")"
      show (t :+: u) = "Either ("++(show t)++") ("++(show u)++")"
      show (t :-> u) = "("++(show t)++" -> "++(show u)++")"

instance Show Funct
    where
      show Id         = "Id"
      show (Const t)  = "Const ("++(show t)++")"
      show (f :**: g) = "("++(show f)++" :*: "++(show g)++")"
      show (f :++: g) = "("++(show f)++" :+: "++(show g)++")"


pf2hs :: Term -> Exp
pf2hs ID           = mkVar "id"
pf2hs (t1 :.: t2)  = InfixApp  (mbParen$ pf2hs t1)
                           (mkOp ".") (mbParen$ pf2hs t2)
pf2hs FST          = mkVar "fst"
pf2hs SND          = mkVar "snd"
pf2hs (t1 :/\: t2) = InfixApp (mbParen$ pf2hs t1) (mkOp "/\\")
                             (mbParen$ pf2hs t2)
pf2hs INL          = mkCon "inl"
pf2hs INR          = mkCon "inr"
pf2hs (t1 :\/: t2) = InfixApp (mbParen$ pf2hs t1) (mkOp "\\/")
                             (mbParen$ pf2hs t2)

pf2hs AP           = mkVar "app"
pf2hs (Curry t1)   = App (mkVar "curry") (mbParen$ pf2hs t1)

pf2hs BANG         = mkVar "bang"
pf2hs (Macro ('(':sym) [t1,t2]) = InfixApp (mbParen $ pf2hs t1)
                                  (QVarOp (UnQual (Symbol (init sym))))
                                  (mbParen $ pf2hs t2)
pf2hs (Macro str [])  = mkVar str
pf2hs (Macro str lst) = App (pf2hs $ Macro str (init lst))
                              (mbParen $ pf2hs $ last lst)
pf2hs (Point str)  = App (mkVar "pnt") (mkVar str)

pf2hs IN           = mkVar "inn"
pf2hs OUT          = mkVar "out"

pf2hs (Hylo typ t1 t2) = -- hylo (_L::typ) t1 t2
    App (App (App 
      (mkVar "hylo") (Paren $ ExpTypeSig mkLoc
        (mkVar "_L") (type2hs typ)))
      (mbParen $ pf2hs t1))
      (mbParen $ pf2hs t2)

pf2hs (HyloO typ t1 t2) = -- hyloO (_L::typ) t1 t2
    App (App (App 
      (mkVar "hyloO") (Paren $ ExpTypeSig mkLoc
        (mkVar "_L") (type2hs typ)))
      (mbParen $ pf2hs t1))
      (mbParen $ pf2hs t2)


type2hs :: Pointfree.Type -> Exts.Type
type2hs One = mkTCon "One"
type2hs (Base s) = TyVar (Ident s)
type2hs (t1 :*: t2) = TyTuple Boxed [type2hs t1, type2hs t2]
type2hs (t1 :+: t2) = TyApp (TyApp (mkTCon "Either")
                         (type2hs t1)) (type2hs t2)
type2hs (t1 :-> t2) = TyFun (type2hs t1) (type2hs t2)
type2hs (Fix t) = TyApp (mkTCon "Fix") (func2hs t)
 where
  func2hs Id = mkTCon "Id"
  func2hs (Const t) = TyApp (mkTCon "Const") (type2hs t)
  -- grammar not rich enough to allow infix constructors
  func2hs (f :**: g) =  TyApp (TyApp (mkTCon "(:*:)")
                         (func2hs f)) (func2hs g)
  func2hs (f :++: g) =  TyApp (TyApp (mkTCon "(:+:)")
                         (func2hs f)) (func2hs g)


-- Auxiliary functions --
mkLoc = SrcLoc "" 0 0
mkOp  = QVarOp . UnQual . Symbol
mkCon  = Con . UnQual . Ident
mkVar  = Var . UnQual . Ident
mkTCon  = TyCon . UnQual . Ident

-- places parentisis in an expression only if it is necessary
mbParen :: Exp -> Exp
mbParen e@(App _ _) = Paren e
mbParen e@(InfixApp _ _ _) = Paren e
mbParen e@(Case _ _) = Paren e
mbParen e@(Lambda _ _ _) = Paren e
mbParen x = x