module Syntax.Ppr (

    Pretty(..),
    
    ) where

import Prelude hiding ((<$>))

import Data.Function (on)
import Data.List (sortBy,isPrefixOf, stripPrefix, (\\), nub, groupBy)
import Data.Maybe (fromMaybe)
import qualified Language.Haskell.Exts.Syntax as Hs
import Language.Haskell.Exts.Pretty (prettyPrint)
import qualified Language.Haskell.TH.Syntax as TH (Exp(..), Pat(..), Dec(..), Clause(..), Body(..), Lit(..))
import Language.Haskell.TH.Ppr (pprint)
import Syntax.Expressions
import Syntax.Type (typeOf, Type(..), TyCxt, Pred, predClass, predMember)
import Syntax.Name
import Syntax.Class.Term
import Syntax.Class.Subst
import Syntax.Context
import Syntax.Specification
import Text.PrettyPrint.ANSI.Leijen
import Igor2.Ppr

instance Pretty Position where
    pretty = text.show
    
instance Pretty TExp where
    pretty e = pprTExp e <+> colon <> colon <+> pretty (typeOf e)    

pprTExp (TVarE n t)         = pretty n
pprTExp (TConE n t)
    | isNil n               = text "[]"
    | isCons n              = text "(:)"
    | otherwise             = pretty n
pprTExp (TLitE l t)         = pretty l
pprTExp e@TAppE {}          = let (f:args) = unfoldTAppE e
    in case (checkConE isCons f, checkConE isAnyTuple f, map pprTExp args) of
           (True, _, [x, y])  -> parens $ x <+> colon <+> y
           (_, True, pprArgs) -> parens (sep (punctuate comma pprArgs))
           (_,    _, pprArgs) -> parens (sep (pprTExp f:pprArgs))
pprTExp (TWildE n t)        = red $ text "?" <> pretty n

instance Pretty Lit where
        pretty (Int i)        = integer i
        pretty (Char c)       = text (show c)
        pretty (String s)     = text (show s)
        pretty (Frac r)       = double (fromRational r)

instance Pretty Name where
    pretty = text.pprint

instance Pretty t => Pretty (Subst t) where
    pretty = encloseSep lbrace rbrace comma
             . map (\(k, v) -> pretty k <+> text "<~" <+> pretty v)
             . assocs

--------------------------------------------------------------------------------
-- PrettyPrinting Types

    
instance Pretty Type where
    pretty (ForallT ctxt ty) =
            text "forall" <+> hsep (map pretty (getVarNames ty)) <+> text "."
                          <+> pprCxt ctxt <+> pretty ty
    pretty ty = pprTyApp (split ty)

-----------------------------------------
-- PrettyPrinting Auxiliaries
-- Stolen from Language.Haskell.TH.PPr

pprParendType :: Type -> Doc
pprParendType (VarT v)   = pretty v
pprParendType (ConT c)   = fromMaybe (pretty c) $ lookup c (
        (listTypeName, text "[]") :
        (arrowName, parens (text "->")) :
        (tupleTypeName 0, text "()") :
        [ (tupleTypeName i, parens (hcat (replicate (i-1) comma))) | i <- [2..15] ])
pprParendType other      = parens (pretty other)

pprTyApp :: (Type, [Type]) -> Doc
pprTyApp (ConT n, [arg1, arg2])
  | n == arrowName = sep [pprFunArgType arg1 <+> text "->", pretty arg2]
pprTyApp (ConT n, [arg])
  | n == listTypeName = brackets (pretty arg)
pprTyApp (ConT n, args)
  | isAnyTuple n   = parens (sep (punctuate comma (map pretty args)))
pprTyApp (fun, []) = pprParendType fun
pprTyApp (fun, args) = pprParendType fun <+> sep (map pprParendType args)

pprFunArgType :: Type -> Doc    -- Should really use a precedence argument
-- Everything except forall and (->) binds more tightly than (->)
pprFunArgType ty@(ForallT {})                 = parens (pretty ty)
pprFunArgType ty@((ConT a `AppT` _) `AppT` _) | a == arrowName = parens (pretty ty)
pprFunArgType ty                              = pretty ty

split :: Type -> (Type, [Type])    -- Split into function and args
split t = go t []
    where go (AppT t1 t2) args = go t1 (t2:args)
          go ty           args = (ty, args)

pprPred :: Pred -> Doc
pprPred p = pretty (predClass p) <+> parens (pretty (predMember p))

pprCxt :: TyCxt -> Doc
pprCxt []  = empty
pprCxt [t] = pprPred t <+> text "=>"
pprCxt ts  = parens (hsep $ punctuate comma $ map pprPred ts) <+> text "=>"

-----------------------------------------

instance Pretty FunBind where
    pretty = vcat.(map text).fixbreaks.lines.unqual.pprint.toDec.wildIntro
    

-- Quick and dirty HACKs!!
-- I am to lazy to not use the Ppr instance of Dec
-- And even if so, I should use Regex
unqual [] = []
unqual s@(x:xs)
    | qualified s = unqual $ unqualifie s
    | otherwise   = x:(unqual xs)
    where
    qualified  s  = any (flip isPrefixOf s) qualifiers
    unqualifie s  = foldl stripFrom s qualifiers
    stripFrom s p = fromMaybe s (stripPrefix p s)
    qualifiers    = ["Data.Either.", "Data.Maybe.", "GHC.Bool."
                    , "GHC.Base.", "GHC.Err.", "GHC.Types.", "GHC.List."
                    , "Generics.Pointless.Combinators."
                    , "Generics.Pointless.RecursionPatterns."]

-- Introduce wild cards for variables occurring only in the head of a rule, 
-- and replacing multiple ocurrances of the same variable.
-- (it was a bad choice to use the WildE syntax for existentially quantified 
-- variables, however, they should not occur in the output.
wildIntro :: FunBind -> FunBind
wildIntro (FunB f es) = FunB f (map intro es)
    where
    intro (UnGuardEq ls rs) = 
        let dubls = dropOneEach . indVarPos . (map getVarPos) $ls
            -- all positions of dublicate variables, but the last one
            unusd = indVarPos $ 
                    map (filter (\(t,_) -> not $ t `elem` (getVars rs))) $  
                    map getVarPos $ ls                     
            -- positions of all those varibales not occurring on the rhs
            ls' =  (repl unusd) . (repl dubls) $ ls
        in (UnGuardEq ls' rs)  
           
    indVarPos l = nub $ concat $ zipWith (\al i -> concatMap (tag i) al) l [0..]
    -- get the variables, with argument index and positions 
    tag i (t,ps) = map (\p -> (t,(i,p))) ps
    dropOneEach = concat . (map init) . (groupBy (on (==) fst))
    repl ps t = foldl replW t ps
    replW tl (TVarE n ty,(i,p)) = applyAtIndex tl i (applyAtPos (const $ TWildE n ty) p)
    -- replace variable at position 'p' by wildcard
    
-- TH.pprint sometimes breaks lists in arguments, so I have to fix it
fixbreaks [x] = [x]
fixbreaks (x1:x2:xs)
   | isPrefixOf "  " x2 = fixbreaks ( (x1++ (' ':(dropWhile (==' ')x2))):xs)
   | otherwise          = x1 : (fixbreaks (x2:xs))
   
toDec :: FunBind  -> TH.Dec
toDec (FunB f es) = TH.FunD f (toClauses es)

toClauses :: [Equation] -> [TH.Clause]
toClauses rs = map toClause  (sortByPatLength rs)
    where
    sortByPatLength  = sortBy (compare `on` (\(UnGuardEq ls _) -> size ls))
     
toClause :: Equation -> TH.Clause
toClause (UnGuardEq ls rs) = TH.Clause (map toPat ls) (TH.NormalB . toExp $ rs) []

checkConE :: (Name -> Bool) -> TExp -> Bool
checkConE f (TConE n _) = f n
checkConE f _           = False

toExp (TVarE n _)         = TH.VarE n
toExp (TWildE n _)        = TH.AppE (TH.ConE errorName) . TH.LitE $ TH.StringL ('?':show n) -- shouldn' occur in body
toExp (TLitE l _)         = TH.LitE (toLit l)
toExp (TConE n _) | isNil n = TH.ListE []
                  | isTuple n 0 = TH.TupE []
                  | otherwise = TH.ConE n
toExp e@(TAppE _ _)     =
    let (f:args) = unfoldTAppE e
    in case (checkConE isCons f, checkConE isAnyTuple f, map toExp args) of
        (True, _, [x, TH.ListE xs]) -> TH.ListE (x:xs)
        (True, _, [x, xs])          -> TH.InfixE (Just x) (toExp f) (Just xs)
        (_,    True, components)    -> TH.TupE components
        (_,    _, argsx)            -> foldl TH.AppE (toExp f) argsx
toLit (Char c)   = TH.CharL c
toLit (String s) = TH.StringL s
toLit (Int i)    = TH.IntegerL i
toLit (Frac r)   = TH.RationalL r
              
toPat (TVarE n _)         = TH.VarP n
toPat (TLitE l _)         = TH.LitP (toLit l)
toPat (TWildE n _)        = TH.WildP            -- now the existentials are really wildcards
toPat (TConE n _) | isNil n = TH.ListP []
                  | isTuple n 0 = TH.TupP []
                  | otherwise = TH.ConP n []
toPat e@(TAppE _ _)     =
    let (TConE n _:as) = unfoldTAppE e
    in case (isCons n, isAnyTuple n, map toPat as) of
         (True, _, [bp, TH.ListP bsp]) -> TH.ListP (bp : bsp)
         (True, _, [bp, bsp])          -> TH.InfixP bp n bsp
         (_,    True, components)      -> TH.TupP components
         (_,    _, asp)                -> TH.ConP n asp
--toPat e = error $ "Cannot translate to Pat: " ++ show e

instance Pretty Equation where
    pretty = text . unqual . pprint . toClause


instance Pretty Specification where
    pretty ctx = linebreak <$> text "Context: " <$>
               (indent 2 $ text "Bindings: " <$> indent 2 (pretty (spec_bindings ctx)) <$>
                           text "Types   : " <$> indent 2 (pretty (spec_types ctx)) <$>
                           text "Ctors   : " <$> indent 2 (pretty (spec_ctors ctx)) <$>
                           text "Classes : " <$> indent 2 (pretty (spec_classes ctx)) <$>
                           text "Members : " <$> indent 2 (pretty (spec_members ctx)) <$>
                           text "Instancs: " <$> indent 2 (pretty (spec_instances ctx)) <$>
                           text "Synonyms: " <$> indent 2 (pretty (spec_typesyns ctx)))

instance Pretty Context where
    pretty ctx = linebreak <$> text "Context: " <$>
               (indent 2 $ text "Types   : " <$> pretty (ctx_types ctx) <$>
                           text "Ctors   : " <$> pretty (ctx_ctors ctx) <$>
                           text "Classes : " <$> pretty (ctx_classes ctx) <$>
                           text "Members : " <$> pretty (ctx_members ctx) <$>
                           text "Instancs: " <$> pretty (ctx_instances ctx) <$>
                           text "Synonyms: " <$> pretty (ctx_typesyns ctx))