Pfe4Cmds.hs

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 SrcLoc(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)

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 "fl".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)