Browse.hs

{-# Language OverloadedStrings, BlockArguments #-}
module Cryptol.REPL.Browse (BrowseHow(..), browseModContext) where

import qualified Data.Set as Set
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe(mapMaybe)
import Data.List(sortBy)

import Cryptol.Parser.AST(Pragma(..))
import qualified Cryptol.TypeCheck.Type as T

import Cryptol.Utils.PP
import Cryptol.Utils.Ident (OrigName(..), modPathIsNormal, identIsNormal)

import Cryptol.ModuleSystem.Env(ModContext(..),ModContextParams(..))
import Cryptol.ModuleSystem.NamingEnv(namingEnvNames)
import Cryptol.ModuleSystem.Name
import Cryptol.ModuleSystem.Interface

data BrowseHow = BrowseExported | BrowseInScope

browseModContext :: BrowseHow -> ModContext -> PPDoc
browseModContext how mc =
  runDoc (env disp) (vcat sections)
  where
  sections = concat
    [ browseMParams (env disp) (mctxParams mc)
    , browseSignatures disp decls
    , browseMods disp decls
    , browseFunctors disp decls
    , browseTSyns disp decls
    , browsePrimTys disp decls
    , browseNominalTypes disp decls
    , browseVars disp decls
    ]

  disp     = DispInfo { dispHow = how, env = mctxNameDisp mc }
  decls    = filterIfaceDecls (`Set.member` visUserNames) (mctxDecls mc)
  allNames = namingEnvNames (mctxNames mc)
  notAnon nm = identIsNormal (nameIdent nm) &&
               case nameModPathMaybe nm of
                  Just p -> modPathIsNormal p
                  _      -> True    -- shouldn't happen?
  visNames = Set.filter notAnon
             case how of
               BrowseInScope  -> allNames
               BrowseExported -> mctxExported mc
  visUserNames = Set.filter (\n -> nameSrc n == UserName) visNames

data DispInfo = DispInfo { dispHow :: BrowseHow, env :: NameDisp }

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


browseMParams :: NameDisp -> ModContextParams -> [Doc]
browseMParams disp pars =
  case pars of
    NoParams -> []
    FunctorParams params ->
      ppSectionHeading "Module Parameters"
      $ [ "parameter" <+> pp (T.mpName p) <+> ":" <+>
          "interface" <+> pp (T.mpIface p) $$
           indent 2 (vcat $
            map ppParamTy (sortByName disp (Map.toList (T.mpnTypes names))) ++
            map ppParamFu (sortByName disp (Map.toList (T.mpnFuns  names)))
           )
        | p <- Map.elems params
        , let names = T.mpParameters p
        ] ++
        ["   "]
    InterfaceParams ps -> [pp ps] -- XXX
  where
  ppParamTy p = nest 2 (sep ["type", pp (T.mtpName p) <+> ":", pp (T.mtpKind p)])
  ppParamFu p = nest 2 (sep [pp (T.mvpName p) <+> ":", pp (T.mvpType p)])
  -- XXX: should we print the constraints somewhere too?


browseMods :: DispInfo -> IfaceDecls -> [Doc]
browseMods disp decls =
  ppSection disp "Submodules" ppM (ifModules decls)
  where
  ppM m = pp (ifsName m)

browseFunctors :: DispInfo -> IfaceDecls -> [Doc]
browseFunctors disp decls =
  ppSection disp "Parameterized Submodules" ppM (ifFunctors decls)
  where
  ppM m = pp (ifModName m)




browseSignatures :: DispInfo -> IfaceDecls -> [Doc]
browseSignatures disp decls =
  ppSection disp "Interface Submodules"
    ppS (Map.mapWithKey (,) (ifSignatures decls))
  where
  ppS (x,_s) = pp x


browseTSyns :: DispInfo -> IfaceDecls -> [Doc]
browseTSyns disp decls =
     ppSection disp "Type Synonyms" pp tss
  ++ ppSection disp "Constraint Synonyms" pp cts
  where
  (cts,tss)  = Map.partition isCtrait (ifTySyns decls)
  isCtrait t = T.kindResult (T.kindOf (T.tsDef t)) == T.KProp

browsePrimTys :: DispInfo -> IfaceDecls -> [Doc]
browsePrimTys disp decls =
  ppSection disp "Primitive Types" ppA ats
  where
  ats = Map.filter T.nominalTypeIsAbstract (ifNominalTypes decls)
  ppA a = nest 2 (sep [pp (T.ntName a) <+> ":", pp (T.kindOf a)])

browseNominalTypes :: DispInfo -> IfaceDecls -> [Doc]
browseNominalTypes disp decls =
  ppSection disp "Nominal Types" T.ppNominalShort
    (Map.filter (not . T.nominalTypeIsAbstract) (ifNominalTypes decls))

browseVars :: DispInfo -> IfaceDecls -> [Doc]
browseVars disp decls =
     ppSection disp "Properties" ppVar props
  ++ ppSection disp "Symbols"    ppVar syms
  where
  isProp p     = PragmaProperty `elem` ifDeclPragmas p
  (props,syms) = Map.partition isProp (ifDecls decls)

  ppVar d      = nest 2 (sep [pp (ifDeclName d) <+> ":", pp (ifDeclSig d)])

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

ppSection :: DispInfo -> String -> (a -> Doc) -> Map Name a -> [Doc]
ppSection disp heading ppThing mp =
  ppSectionHeading heading
  case dispHow disp of
    BrowseExported | [(_,xs)] <- grouped -> ppThings xs
    _ -> concatMap ppMod grouped
  where
  grouped = groupDecls (env disp) mp

  ppThings xs = map ppThing xs ++ [" "]

  ppMod (nm,things) =
    [ "From" <+> pp nm
    , "-----" <.> text (map (const '-') (show (runDoc (env disp) (pp nm))))
    , "     "
    , indent 2 (vcat (ppThings things))
    ]

ppSectionHeading :: String -> [Doc] -> [Doc]
ppSectionHeading heading body
  | null body = []
  | otherwise =
     [ text heading
     , text (map (const '=') heading)
     , "    "
     , indent 2 (vcat body)
     ]




-- | Organize by module where defined, then sort by name.
groupDecls :: NameDisp -> Map Name a -> [(ModPath,[a])]
groupDecls disp = Map.toList
                . fmap (sortByName disp)
                . Map.fromListWith (++)
                . mapMaybe toEntry
                . Map.toList
  where
  toEntry (n,a) =
    case nameInfo n of
      GlobalName _ og -> Just (ogModule og,[(n,a)])
      _               -> Nothing


sortByName :: NameDisp -> [(Name,a)] -> [a]
sortByName disp = map snd . sortBy cmpByDispName
  where
  cmpByDispName (x,_) (y,_) =  cmpNameDisplay disp x y