module Pfe4Cmds where

import PfeParse(runCmds,moduleArgs,moduleArgs',just,qualIds,( #@ ),(<@),
		kwOption)
import Pfe3Cmds(pfe3Cmds)

import PFE0(pput,epput)
import PFE2(getExports)
import PFE4(runPFE4,topTypes,typeCheck,rewriteAndTypeCheck,modEnv)
import PFE_Rewrites
import Ents(Ent(..))
import QualNames(mkUnqual,unqual)
import Relations(relToList)
import TypedIds(isValue,IdTy(MethodOf),owner,belongsTo,idTy)
import TI(Typing(..),TypeInfo(..),tdom,envFrom,topVal,topType,ppKinded)
import TiInstanceDB(InstEntry(..))
import HasBaseName(getBaseName)
import HsIdent(HsIdentI(..),accHsIdent2,getHSName,mapHsIdent)
import SrcLoc1(srcLoc)
import UniqueNames(orig,Orig(G),noSrcLoc)
import MUtils(( # ),( <# ),apBoth)
import PrettyPrint
import PrettySymbols hiding (not)
import PrettyUtil(ppContext,ppWhere)
import Products((><))
import OpTypes(cmpBy)
import List(partition,sortBy)

{-+
The type checker can return different types, so to avoid an ambiguity when
the result is used only for pretty printing, the function tcOutput can be passed
in to restrict the result type.
-}

pfe4 ext tcOutput = runPFE4Cmds ext (pfe4Cmds tcOutput)

runPFE4Cmds ext = runCmds (runPFE4 ext)

pfe4Cmds tcOutput=
    pfe3Cmds ++
    [("tc",       (tcmd tcrw,     "type check and display decorated modules")),
     ("types",    (tcmd0 types,    "show types/kinds of top-level entities")),
     ("typeof",   (tqcmd typeof,  "show types of named top-level entities")),
     ("kindof",   (tqcmd kindof,  "show kinds of named top-level entities")),
     ("instances",(tcmd0 instances,"list instances defined in a module")),
     ("iface",    (tcmd0 ppIfaces, "show the interfaces of modules")),
     ("usedtypes",(tcmd0 utypes,   "show what types identifers are used at"))]
  where
    tcmd0 f = moduleArgs (f tcOutput)
    tcmd f = moduleArgs' rwopts (f tcOutput)
    tqcmd f = qualIds (f tcOutput)

    rwopts = o pmRewrite ## o pbRewrite ## o lcRewrite

    o rw@(Rewrite n _) = (\ b -> if b then rw else idRw) # kwOption ('-':n)
    rw1 ## rw2 = compRw #@ rw1 <@ rw2

instances tcOutput ms =
  do pfe4info <- tcOutput # topTypes (Just ms)
     pput.vcat $ [ppContext ps<+>p |(m,(_,(_,(insts,_))))<-pfe4info,
		                    m `elem` ms,
		                    (p,IE _ _ ps)<-insts]

types tcOutput ms =
  do pfe4info <- tcOutput # topTypes (Just ms)
     pput.vcat $ [map (fmap fst) ks$$ts |(m,(_,(_,(_,(ks,ts)))))<-pfe4info,
		                    m `elem` ms]

typeof tcOutput qids =
  do pfe4info <- tcOutput # topTypes (Just (map fst qids))
     mapM_ (typeof1 pfe4info) qids
{-
typeof1 pfe4info (m,s) = pput (vcat bs)
  where
    q=topVal m s
    bs = [b|(m',(_,(_,(_,(ks,ts)))))<-pfe4info,
		m'==m,
		b@(x:>:_)<-ts,
		getHSName x==q]
-}
kindof tcOutput qids =
  do pfe4info <- tcOutput # topTypes (Just (map fst qids))
     mapM_ (kindof1 pfe4info) qids
{-
kindof1 pfe4info (m,s) = pput (vcat bs)
  where
    q=topType m s
    bs = [fmap fst b|(m',(_,(_,(_,(ks,ts)))))<-pfe4info,
		     m'==m,
		     b@(x:>:_)<-ks,
		     getHSName x==q]
-}
typeof1 = info1 snd id
kindof1 = info1 fst fst

info1 envsel infosel pfe4info (m,s) = pput (vcat bs)
  where
    q=topType m s
    bs = [fmap infosel b|Just env<-[modEnv pfe4info m],
		     b@(x:>:_)<-envsel env,
		     getHSName x==q]

utypes tcOutput ms =
  do pfe4info <- tcOutput # typeCheck (Just ms)
     mapM_ (utypes1' pfe4info) ms
  where
    utypes1' pfe4info mn =
        maybe (epput $ "Unknown module:"<+>mn) utypes1
		      (lookup "".fst.snd=<<lookup mn pfe4info)
      where
        utypes1 m =
          pput (mn<>":"$$
		nest 2 (vcat.map u.sortBy (cmpBy fst).map pos.snd.envFrom $ m))

        pos xt@(x:>:_) = (srcLoc x,xt)

        u (pos,x:>:(sc,optt)) =
	    sep [x<+>"at"<+>pos<+>"::",
		 nest 4 (maybe (ppi sc) ppi optt)]

tc tcOutput ms = pptc ms =<< (tcOutput # typeCheck (just ms))

pptc ms = pptc' "" ms

pptc' rname ms pfe4info =
  pput.vcat $ [tm |(m,(_,(tms,_)))<-pfe4info, m `elem` ms,(n,tm)<-tms,n==rname++"fl"]

tcrw tcOutput rw@(Rewrite rwn _) ms =
  pptc' rwn ms . tcOutput =<< rewriteAndTypeCheck rw (just ms)

ppIfaces tcOutput ms =
  do exports <- getExports (Just ms)
     pfe4info <- tcOutput # topTypes (Just ms)
     mapM_ (pput.ppIface.iface exports pfe4info) ms

moduleInterface m =
  do exports <- getExports (Just [m])
     types <- topTypes (Just [m])
     return (iface exports types m)

iface expRels pfe4info m =
    (m,((types><kinds).partition isValue.map snd.relToList.snd
        # lookup m expRels))
  where
    kinds = map (info fst id)
    types = map (info snd id)

    info envsel infosel e@(Ent m' n _) = (e,i)
      where
        Just env = conv . envsel # modEnv pfe4info m'
	i = lift n (infosel # lookup (mkUnqual(getBaseName n)) env)


    conv env = [(unqual' (getBaseName x),y)|x:>:y<-env]
    unqual' = unqual `asTypeOf` id

    lift x = maybe (error $ pp $ "Not found:"<+>x) id
      
ppIface (m,Nothing) = "Unknown module:"<+>m
ppIface (m,Just (ts,ks)) =
    kw "module"<+>modn m<>":" $$
    nest 2 (vcat (map ppTInfo ks) $$
	    "" $$
	    vcat (map ppVInfo vs))
  where
    (subs,vs) = partition isExportedSubordinate ts

    ppV = accHsIdent2 ppi con
    ppTInfo (e,(k,ti)) = ppTypeInfo e k ti
    ppVInfo (Ent m' n _,ty) = {-ppName m'-}ppV n<+>el<+>ty
    {-
    ppName m' n =
      if m'==m
      then ppi n
      else m'<>"."<>n
    -}

    isExportedValue (x:>:_) = mapHsIdent orig x `elem` values

    isExportedSubordinate (e,_) = maybe False (`elem` types) (origOwner e)

    ppTypeInfo e@(Ent m n idty) k ti =
	case ti of
          Data    -> ppData "data"
	  Newtype -> ppData "newtype"
	  Class ps aks pds allms ->
	      sep [kw "class"<+>
		   sep [ppContext ps,
			tcon n<+>hsep (map ppKinded aks)<+>ppDeps vds],
		   nest 2 $ ppWhere (map ppi visms++more)]
	    where
	      as = tdom aks
              vds = map (apBoth (map (as!!))) pds
	      (visms,hidms) = partition isExportedValue allms
	      more = if null hidms then [] else [kw "..."]
	  Synonym as t ->
              sep [kw "type"<+>tcon n<+>hsep as<+>equals,nest 4 (ppi t)]
	  Tyvar -> var n<+>el<+>k -- ??
      where
        o = ent2orig e

        ppData dkw =
	    sep [kw dkw<+>tcon n<+>el<+>k,
		 nest 2 $ ppWhere (map ppVInfo ss)]
	  where
	    ss = filter ((==Just o).origOwner.fst) subs

    ppDeps [] = empty
    ppDeps ds = kw "|"<+>ppiFSeq (map ppDep ds)
    ppDep (as,bs) = hsep as<+>rarrow<+>hsep bs

    values = map (ent2orig.fst) ts
    types = map (ent2orig.fst) ks

    ent2orig (Ent m n _) = mapHsIdent (\n->G m n noSrcLoc) (getBaseName n)

    origOwner (Ent m n idty) = fmap orig (owner idty)
      where orig t = ent2orig (Ent m (HsCon t) undefined)