HsPretty.hs

-- Please, see the file LICENSE for copyright and license information.

{-# LANGUAGE PatternGuards #-}
module HFusion.Internal.HsPretty(
 show, -- :: Prog -> String
 ShowDoc(..),
 showTuple, -- :: ShowDoc a => [a]->Doc
 ttupleprec,tlambprec,tletprec,tcaseprec,tfappprec,thyloprec,tcappprec,tappprec,tsumprec,
 mergeCasePatterns,
 module Text.PrettyPrint,
 sss
      -- :: Term -> String
) where

import HFusion.Internal.HsSyn
import Text.PrettyPrint
import HFusion.Internal.HsPrec
import HFusion.Internal.Utils

import Control.Monad(mplus,msum)
import Control.Arrow((***))
import Data.List(transpose,intersperse)
import Data.Char(isLetter)

import HFusion.Internal.Messages


instance Show Prog where   
    show (Prog defs) = render.vcat$ intersperse (text "")$ map showDoc defs
    {- o : show (Prog defs) = fullRender PageMode 100 1.5 string_txt "" (showDoc defs)
     string_txt (Chr c)   s  = c:s
     string_txt (Str s1)  s2 = s1 ++ s2
     string_txt (PStr s1) s2 = s1 ++ s2
    -}

instance Show Def where
  show = render . showDoc

instance Show Term where   
    show t = render.showDoc$ t

-- | A class for building 'Doc' values.
class ShowDoc a where
    showDoc::a->Doc
    showDocPrec:: Precedence -> LeftParam -> a -> Doc

    showDoc = showDocPrec (0,None) False
    showDocPrec _ _ = showDoc


showTuple :: ShowDoc a => [a]->Doc
showTuple [a] = showDoc a
showTuple ls = char '('<> (hcat$ intersperse (char ',')$ map showDoc ls)<>char ')'

parlist:: Bool -> [Doc] -> Doc
parlist paren content = if paren 
                          then  char '(' <> 
                                cat (intersperse (text " ") content++[char ')'])
                          else sep content

tab,stab::Int
-- | normal indentation
tab=4      
-- | small indentation
stab=2     

-- | Precedences for the constructors of 'Term' values.
ttupleprec,tlambprec,tletprec,tcaseprec,
 tfappprec,thyloprec,tcappprec,tappprec,tsumprec::Precedence
ttupleprec=(0,None)
tlambprec=(0,RightAsoc)
tletprec=(0,RightAsoc)
tcaseprec=(0,RightAsoc)
thyloprec=(0,RightAsoc)
tsumprec =(1,None)
tfappprec=(maxprec,LeftAsoc)
tcappprec=(maxprec,LeftAsoc)
tinfixcappprec=(9,RightAsoc)
tappprec=(maxprec,LeftAsoc)

dec (p,a) = (p-1,a)

maxprec::Int
maxprec=10



instance (ShowDoc a,ShowDoc b)  => ShowDoc (a,b) where
    showDoc (a,b) = char '('<>showDoc a<>char ','<+> showDoc b <>char ')'

instance ShowDoc Bool where
    showDoc True = text "True"
    showDoc False = text "False"

instance ShowDoc Def where
    showDoc (Defvalue name t) = vcat$ map showDef$ splitCase vs t'
     where getParams (Tlamb bv t) = let (l,t') = getParams t in (bv:l,t')
           getParams t = ([],t)
           (vs,t') = getParams t
           -- tries to separate a case definition into equations
           -- it returns a list containing one element for each derived equation
           -- [(equation patterns,equation term)]
           splitCase :: [Boundvar] -> Term -> [([Pattern],Term)]
           splitCase bvs t = maybe [(map bv2pat bvs,t)] (uncurry$ zipWith (\p t->(patList p,t)))$ 
                                                         mergeCasePatterns' p t
             where p = ptuple$ map bv2pat bvs
           patList (Ptuple ps) = ps
           patList p = [p]

           showDef (ps,t) = sep [text (show name) <+> hsep (map (toDoc (vars t)) ps) <+> char '=' 
                                , nest 8$ showDoc t]
           toDoc vs p = showDocPrec tcappprec False (removeSpuriousPas vs p)


-- Flattens nested case terms by carefully replacing patterns into patterns to remove
-- inner case constructs and increase the amount of alternatives in the outer case
-- constructs.

mergeCasePatterns :: Term -> Term
mergeCasePatterns t = mergeCPat id t
  where mergeCPat bvs (Tlamb bv t) = Tlamb bv$ mergeCPat (bvs . (bv:)) t
        mergeCPat bvs t = 
           let ps = map bv2pat (bvs [])
               pvs = lastVarsList ps
            in if null ps 
                 then case t of
                       Tcase t0 ps ts -> (\(ps,ts)-> Tcase t0 (concat ps) (concat ts))$
                                                     unzip$ map unzip$ zipWith ((map removePas.) . mergeCase) ps ts 
                       _ -> t 
                 else if isTcase t then
                        delCases$ uncurry (Tcase (ttuple (map Tvar pvs)))$ unzip$ map removePas$ mergeCase (ptuple$ map Pvar pvs) t
					  else t
        mergeCase :: Pattern -> Term -> [(Pattern,Term)]
        mergeCase p t = case mergeCasePatterns' p t of
                         Just (ps,ts) -> concat$ zipWith mergeCase ps ts
                         Nothing -> [(p,t)]
        removePas (p,t) = (removeSpuriousPas (vars t) p,t)
        isTcase (Tcase _ _ _) = True
        isTcase _ = False

-- Removes Pas patterns which are not in a given set of variables.

removeSpuriousPas ::  [Variable] -> Pattern -> Pattern
removeSpuriousPas vs (Pas v p@(Pas v' _)) | v==v' = removeSpuriousPas vs p
removeSpuriousPas vs (Pas v p@(Pvar v')) |  v==v' = p
                                         |  p==pany = if elem v vs then Pvar v else pany
removeSpuriousPas vs (Pas v p) | elem v vs = Pas v (removeSpuriousPas vs p)
                               | otherwise = removeSpuriousPas vs p
removeSpuriousPas _ p@(Pvar _) = p
removeSpuriousPas _ p@(Plit _) = p
removeSpuriousPas vs (Ptuple ps) = Ptuple (map (removeSpuriousPas vs) ps)
removeSpuriousPas vs (Pcons c ps) = Pcons c (map (removeSpuriousPas vs) ps)

-- Merges the cases in the term to the given pattern. Returns Nothing
-- if there are no cases to merge.

mergeCasePatterns' :: Pattern -> Term -> Maybe ([Pattern],[Term])
mergeCasePatterns' p t = case removeAllCaseVar Nothing t of
                           Just res -> mergeCasePatterns'' p res `mplus` Just ([p],[res])
                           _ -> mergeCasePatterns'' p t
  where removeAllCaseVar res t = maybe res (\mt->removeAllCaseVar (Just mt) mt)$ removeCaseVars t
        removeCaseVars (Tcase t0 ps ts) 
                       | length t0s > 1, 
                         Just i<-msum (zipWith3 findVarPattern [0..] t0s pss) = Just (Tcase (listToTerm$ del i t0s) (map (removePattern i) ps) ts)
            where t0s = termList t0
                  pss = transpose$ map patList ps
        removeCaseVars _ = Nothing
        findVarPattern i (Tvar v) ps | all (isPatternVar v) ps = Just i
        findVarPattern _ _ _ = Nothing
        isPatternVar v (Pvar v') = v==v'
        isPatternVar _ _ = False
        removePattern i (Ptuple ps) = toPat$ del i ps
        removePattern _ _ = error "mergeCasePatterns': something that shouldn't had happened happened."
        listToTerm [t] = t
        listToTerm ts = Ttuple False ts
        termList (Ttuple _ ts) = ts
        termList t = [t]
        patList (Ptuple ps) = ps
        patList p = [p]
        toPat [p] = p
        toPat ps = Ptuple ps
        del i ls = take i ls ++ drop (i+1) ls

mergeCasePatterns'' :: Pattern -> Term -> Maybe ([Pattern],[Term])
mergeCasePatterns'' p (Tcase t0 ps ts)
            | all isAllowedTerm t0s 
              && orderMatches lvp t0s
              && all ((==length t0s) . length) pss
              && any (not.null.fst) sustss =
         Just (map (flip substitutePattern p . fst)$ sustss ,map snd sustss)
  where t0s = termList t0
        tvs = vars t0s
        pss = map patList ps
        sustss = zipWith (makeSustPairs tvs) pss ts
        lvp = lastVars p
        isAllowedTerm (Tvar v) = elem v lvp
        isAllowedTerm _ = False
        makeSustPairs tvs ps t = let ss = zipWith (makeSustPair t (vars t)) tvs ps
                                  in (map fst ss,substitution (concat . map snd$ ss) t)
        makeSustPair t _ v (Pvar v') | notElem v (varsB t) = ((v,Pvar v),[(v',Tvar v)])
        makeSustPair _ tsvs v p | p/=pany = ((v,Pas v p),[])
                                | elem v tsvs = ((v,Pvar v),[])
		                        | otherwise = ((v,pany),[])
        patList (Ptuple ps) = ps
        patList p = [p]
        termList (Ttuple _ ts) = ts
        termList t = [t]
        orderMatches (v:lvp) t0s@(Tvar v':t0ss) | v==v' = orderMatches lvp t0ss
                                                | otherwise = orderMatches lvp t0s
        orderMatches _ [] = True
        orderMatches _ _ = False
mergeCasePatterns'' _ _ = Nothing

substitutePattern :: [(Variable,Pattern)] -> Pattern -> Pattern
substitutePattern subst p@(Pvar v) = maybe p id $ lookup v subst 
substitutePattern _ p@(Plit _) = p 
substitutePattern subst (Ptuple ps) = Ptuple$ map (substitutePattern subst) ps 
substitutePattern subst (Pcons c ps) = Pcons c$ map (substitutePattern subst) ps 
substitutePattern subst (Pas v p) = Pas v$ substitutePattern subst p 


-- lastVars returns the variables that can be replaced without breaking the pattern matching sequence.
-- e.g. in (C a (C2 b c) d) the variables that can be safely replaced are b c and d.

lastVars :: Pattern -> [Variable]
lastVars (Pvar v) = [v]
lastVars (Pcons _ ps) = lastVarsList ps
lastVars (Ptuple ps) = lastVarsList ps
lastVars (Plit _) = []
lastVars (Pas _ p) = lastVars p
lastVarsList ps = let (vps,others) = break (not.isPvar) (reverse ps)
                   in if null others then reverse (vars vps)
                        else lastVars (head others)++reverse (vars vps)
  where isPvar (Pvar _) = True
        isPvar _ = False


instance ShowDoc Variable where
    showDoc v = text (show v)

instance ShowDoc Term where
    showDocPrec _ _ (Tvar name) = text$ if not (null n) && not (isLetter (head n)) then  "("++n++")" else n
         where n = show name
    showDocPrec _ _ (Tlit literal) = text (show literal)

    showDocPrec _ _ (Ttuple _ [Tvar name]) = text (show name)
    showDocPrec _ _ (Ttuple _ terms) =  
           let
              tdocs = map (showDocPrec ttupleprec False) terms
           in          
               cat $ [char '(']
                     ++ map (nest 1) (uncurry(++)$ (id *** map (char ','<>))$ splitAt 1 tdocs)
                     ++ [char ')']

    showDocPrec prec left (Tlamb boundvar term) =
                let
                   t=showDocPrec tlambprec False term
                   content = [char '\\' <> text (show boundvar) <+> text "->",
                              nest tab t]
                   paren = parenthesize prec left tlambprec
                in parlist paren content

    showDocPrec prec left (Tlet variable term1 term2) =
                let
                   t1=showDocPrec tletprec False term1
                   t2=showDocPrec tletprec False term2
                   content = [(text "let" <+> text (show variable) <+> equals <+> t1)
                              $$ nest 1 (text "in" <+> t2)]
                   paren = parenthesize prec left tletprec
                in parlist paren content

    showDocPrec prec left (Tif term0 term1 term2) =
                let
                   t0=showDocPrec tletprec False term0
                   t1=showDocPrec tletprec False term1
                   t2=showDocPrec tletprec False term2
                   content = [vcat [sep [text "if" <+> t0,nest stab (text "then"<+>t1)],
                                    nest stab (text "else" <+> t2)]]
                   paren = parenthesize prec left tletprec
                in parlist paren content

    showDocPrec _ _ (Tpar t) = char '(' <+> showDocPrec (0,None) False t <+> char ')'

    showDocPrec prec left (Tcase term ps' ts') =
                let
                   tr=showDocPrec tcaseprec False term
                   ts=map (showDocPrec tcaseprec False) ts'
                   ps=map (showDocPrec tcaseprec False) ps'
                   content = [text "case" <+> tr <+> text "of",
                              nest stab $
                                 vcat [sep [p <+> text "->", nest tab t]
                                      | (p,t)<-zip ps ts]
                             ]
                   paren = parenthesize prec left tcaseprec
                in parlist paren content

    showDocPrec p l (Tfapp variable [] ) = showDocPrec p l (Tvar variable)
    showDocPrec prec left (Tfapp variable terms) =
                let
                   tds@(td:tdocs)=map (flip (showDocPrec op_precedence)) terms
                   content 
                        | infx && length terms>1 = 
                                 (td True <+> text (show variable)):
                                 map (\t->nest 2$ t False) tdocs
                        | infx = [td True<>text (show variable)]
                        | otherwise = text (show variable):
                                      map (\t->nest 2$ t False) tds
                   paren = infx && length terms<=1 || parenthesize prec left op_precedence
                in
                   parlist paren content
              where infx = isInfix variable
                    isInfix (Vgen _ _) = False
                    isInfix (Vuserdef ('@':'b':_)) = False
                    isInfix (Vuserdef (c:_)) = not ((('a'<=c)&&(c<='z'))||(c=='_'))
                    isInfix _ = error infix_Operator_Without_Characters_In_Name
                    op_precedence | infx && variable/=Vuserdef "/" && variable/=Vuserdef "-"
                                         && variable/=Vuserdef "+"
                                        = (1,RightAsoc)
                                  | otherwise = tfappprec


    showDocPrec _ _ (Tcapp constructor []) = text$ if constructor/="[]" && not (null constructor) 
                                                && not (isLetter (head constructor)) 
                                              then "("++constructor++")"
                                              else constructor
    showDocPrec prec left (Tcapp constructor terms) =
                let
                   tds@(td:tdocs)=map (flip (showDocPrec op_precedence)) terms
                   content 
                    | isInfix && length terms>1 = td True <+> text constructor <+>
                                                   hsep (map (\t->t False) tdocs)
                    | isInfix = td True<>text constructor
                    | otherwise = text constructor <+> 
                                  hsep (map (\t->t False) tds)
                   paren = isInfix && length terms<=1 || parenthesize prec left op_precedence
                in
                   hpar paren content
              where isInfix = case constructor of 
                                "_" -> False
                                (c:_)-> not (('A'<=c)&&(c<='Z')) && constructor/="[]"
                                _ -> error infix_Constructor_Without_Characters_In_Name
                    op_precedence | isInfix = tinfixcappprec
                                  | otherwise = tcappprec

    showDocPrec prec left (Tapp term1 term2) =
               let
                  t1=showDocPrec tappprec True term1
                  t2=showDocPrec tappprec False term2
                  paren = parenthesize prec left tappprec
                  content = t1 <+> t2
               in
                  hpar paren content
    showDocPrec _ _ Tbottom = text "undef"

    showDocPrec prec left (Thyloapp v i ts pos t) = showDocPrec prec left (Tfapp v (thyloArgs i ts pos t))


instance Show Boundvar where
    show = render.showDoc

instance ShowDoc Boundvar where
    showDoc (Bvar name) = text$ show name
    showDoc (Bvtuple _ vars) = showTuple vars

instance Show Pattern where
    show (Pvar name) = show name
    show (Ptuple patterns) = "("++ (concat$ intersperse ","$ map show patterns) ++")"
    show (Pcons name patterns) = "("++ name ++ foldr ((++).(" "++).show) "" patterns ++")"
    show (Plit literal) = show literal
    show (Pas v p) = show v++'@':show p

instance ShowDoc Pattern where
  showDocPrec _ _ (Pvar v) = text (show v) 
  showDocPrec _ _ (Pas v p) = text (show v)<>char '@'<>showDocPrec tcappprec False p
  showDocPrec _ _ (Ptuple patterns) =
               let
                  ps=map (showDocPrec ttupleprec False) patterns
               in
                  (char '('<>hcat (uncurry(++)$ (id *** map (char ','<>))$ splitAt 1 ps)<>char ')')
  showDocPrec _ _ (Pcons name []) = text name
  showDocPrec prec left (Pcons name patterns) =
                let
                   tds@(td:tdocs)= map (flip (showDocPrec op_precedence)) patterns
                   content
                        | esinfijo name = td True <> text name <>
                                              hsep (map (\t->t False) tdocs)
                        | otherwise = text name <+>
                                      hsep (map (\t->t False) tds)
                   paren = parenthesize prec left op_precedence
                in
                   hpar paren content
              where esinfijo (c:_) = not (('A'<=c)&&(c<='Z'))
                    esinfijo _ = error infix_Constructor_Without_Characters_In_Name
                    op_precedence | esinfijo name = (fst tcappprec,RightAsoc)
                                  | otherwise = tcappprec
  showDocPrec _ _ (Plit literal) = text (show literal)


instance Show Literal where
    show (Lstring string) = show string
    show (Lint string) = string
    show (Lchar char) = show char
    show (Lrat string) = string