module Language.Haskell.Exts.ToHaskell
( ToHS(..), HDoc, Prec, showsPrecHS
, appHS, ifHS, lamHS, letHS, tupleHS, infixHS, hsName, hsShow
, ToHSPat(..)
) where
import Data.Functor ((<$>))
import Control.Applicative (liftA2,liftA3)
import Control.Monad ((>=>),mzero)
import Data.Maybe (fromMaybe)
import qualified Data.Map as M
import Language.Haskell.Exts.Syntax
import Language.Haskell.Exts.Fixity
import Language.Haskell.Exts.Pretty (prettyPrint)
type Prec = Int
type HDoc = Prec -> Exp
class ToHS a where
toHS :: a -> HDoc
showsPrecHS :: ToHS a => Prec -> a -> ShowS
showsPrecHS p a s = prettyPrint (toHS a p) ++ s
appPrec :: Prec
appPrec = 11
appHS :: Binop HDoc
appHS f a p = hsParen (p > appPrec) $
App (f appPrec) (a (appPrec+1))
ifHS :: Ternop HDoc
ifHS i t e p = hsParen (p > 0) $ If (i 0) (t 0) (e 0)
lamHS :: Pat -> Unop HDoc
lamHS pat d p = hsParen (p > 0) $
Lambda noLoc [pat] (d 0)
letHS :: Pat -> Binop HDoc
letHS pat rhs body p = hsParen (p > 0) $
simpleLet pat (rhs 0) (body 0)
simpleLet :: Pat -> Binop Exp
simpleLet pat r b =
mkLet (BDecls [PatBind noLoc pat Nothing (UnGuardedRhs r) (BDecls [])]) b
mkLet :: Binds -> Exp -> Exp
mkLet (BDecls ds) (Let (BDecls ds') e) = Let (BDecls (ds ++ ds')) e
mkLet bs e = Let bs e
tupleHS :: [HDoc] -> HDoc
tupleHS ds _ = Tuple (map ($ 0) ds)
infixHS :: String -> Maybe (Binop HDoc)
infixHS = (fmap.fmap) infixHS' fixity
fixity :: String -> Maybe Fixity
fixity = flip M.lookup fixityMap
fixityMap :: M.Map String Fixity
fixityMap = M.fromList (keyed <$> allFixities)
where
keyed :: Fixity -> (String,Fixity)
keyed f@(Fixity _ _ q) = (prettyPrint q, f)
infixHS' :: Fixity -> Binop HDoc
infixHS' (Fixity assoc q name) a b p =
hsParen (p > q) $
InfixApp (a (lf q)) (QVarOp name) (b (rf q))
where
(lf,rf) = case assoc of
AssocLeft -> (incr, succ)
AssocRight -> (succ, incr)
AssocNone -> (succ, succ)
incr | extraParens = succ
| otherwise = id
extraParens :: Bool
extraParens = True
hsName :: String -> HDoc
hsName s _ = Var . UnQual . Ident $ s
hsShow :: Show a => a -> HDoc
hsShow = hsName . show
noLoc :: SrcLoc
noLoc = SrcLoc "no file" 0 0
hsParen :: Bool -> Unop Exp
hsParen True = Paren
hsParen False = id
allFixities :: [Fixity]
allFixities = baseFixities
class ToHSPat a where toHSPat :: a -> Pat
type Unop a = a -> a
type Binop a = a -> Unop a
type Ternop a = a -> Binop a