content: {-# 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 Data.Void (Void)
  import qualified Prettyprinter as PP
  
  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` visNames) (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
  
  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
  
  
  
  