{-# 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 -> PP.Doc Void
browseModContext :: BrowseHow -> ModContext -> Doc Void
browseModContext BrowseHow
how ModContext
mc =
  NameDisp -> Doc -> Doc Void
runDoc (DispInfo -> NameDisp
env DispInfo
disp) ([Doc] -> Doc
vcat [Doc]
sections)
  where
  sections :: [Doc]
sections = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ NameDisp -> ModContextParams -> [Doc]
browseMParams (DispInfo -> NameDisp
env DispInfo
disp) (ModContext -> ModContextParams
mctxParams ModContext
mc)
    , DispInfo -> IfaceDecls -> [Doc]
browseSignatures DispInfo
disp IfaceDecls
decls
    , DispInfo -> IfaceDecls -> [Doc]
browseMods DispInfo
disp IfaceDecls
decls
    , DispInfo -> IfaceDecls -> [Doc]
browseFunctors DispInfo
disp IfaceDecls
decls
    , DispInfo -> IfaceDecls -> [Doc]
browseTSyns DispInfo
disp IfaceDecls
decls
    , DispInfo -> IfaceDecls -> [Doc]
browsePrimTys DispInfo
disp IfaceDecls
decls
    , DispInfo -> IfaceDecls -> [Doc]
browseNewtypes DispInfo
disp IfaceDecls
decls
    , DispInfo -> IfaceDecls -> [Doc]
browseVars DispInfo
disp IfaceDecls
decls
    ]

  disp :: DispInfo
disp     = DispInfo { dispHow :: BrowseHow
dispHow = BrowseHow
how, env :: NameDisp
env = ModContext -> NameDisp
mctxNameDisp ModContext
mc }
  decls :: IfaceDecls
decls    = (Name -> Bool) -> IfaceDecls -> IfaceDecls
filterIfaceDecls (forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Name
visNames) (ModContext -> IfaceDecls
mctxDecls ModContext
mc)
  allNames :: Set Name
allNames = NamingEnv -> Set Name
namingEnvNames (ModContext -> NamingEnv
mctxNames ModContext
mc)
  notAnon :: Name -> Bool
notAnon Name
nm = Ident -> Bool
identIsNormal (Name -> Ident
nameIdent Name
nm) Bool -> Bool -> Bool
&&
               case Name -> Maybe ModPath
nameModPathMaybe Name
nm of
                  Just ModPath
p -> ModPath -> Bool
modPathIsNormal ModPath
p
                  Maybe ModPath
_      -> Bool
True    -- shouldn't happen?
  visNames :: Set Name
visNames = forall a. (a -> Bool) -> Set a -> Set a
Set.filter Name -> Bool
notAnon
             case BrowseHow
how of
               BrowseHow
BrowseInScope  -> Set Name
allNames
               BrowseHow
BrowseExported -> ModContext -> Set Name
mctxExported ModContext
mc

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

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


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


browseMods :: DispInfo -> IfaceDecls -> [Doc]
browseMods :: DispInfo -> IfaceDecls -> [Doc]
browseMods DispInfo
disp IfaceDecls
decls =
  forall a. DispInfo -> String -> (a -> Doc) -> Map Name a -> [Doc]
ppSection DispInfo
disp String
"Submodules" forall {a}. PP a => IfaceNames a -> Doc
ppM (IfaceDecls -> Map Name (IfaceNames Name)
ifModules IfaceDecls
decls)
  where
  ppM :: IfaceNames a -> Doc
ppM IfaceNames a
m = forall a. PP a => a -> Doc
pp (forall name. IfaceNames name -> name
ifsName IfaceNames a
m)

browseFunctors :: DispInfo -> IfaceDecls -> [Doc]
browseFunctors :: DispInfo -> IfaceDecls -> [Doc]
browseFunctors DispInfo
disp IfaceDecls
decls =
  forall a. DispInfo -> String -> (a -> Doc) -> Map Name a -> [Doc]
ppSection DispInfo
disp String
"Parameterized Submodules" forall {a}. PP a => IfaceG a -> Doc
ppM (IfaceDecls -> Map Name (IfaceG Name)
ifFunctors IfaceDecls
decls)
  where
  ppM :: IfaceG a -> Doc
ppM IfaceG a
m = forall a. PP a => a -> Doc
pp (forall name. IfaceG name -> name
ifModName IfaceG a
m)




browseSignatures :: DispInfo -> IfaceDecls -> [Doc]
browseSignatures :: DispInfo -> IfaceDecls -> [Doc]
browseSignatures DispInfo
disp IfaceDecls
decls =
  forall a. DispInfo -> String -> (a -> Doc) -> Map Name a -> [Doc]
ppSection DispInfo
disp String
"Interface Submodules"
    forall {a} {b}. PP a => (a, b) -> Doc
ppS (forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey (,) (IfaceDecls -> Map Name ModParamNames
ifSignatures IfaceDecls
decls))
  where
  ppS :: (a, b) -> Doc
ppS (a
x,b
s) = forall a. PP a => a -> Doc
pp a
x


browseTSyns :: DispInfo -> IfaceDecls -> [Doc]
browseTSyns :: DispInfo -> IfaceDecls -> [Doc]
browseTSyns DispInfo
disp IfaceDecls
decls =
     forall a. DispInfo -> String -> (a -> Doc) -> Map Name a -> [Doc]
ppSection DispInfo
disp String
"Type Synonyms" forall a. PP a => a -> Doc
pp Map Name TySyn
tss
  forall a. [a] -> [a] -> [a]
++ forall a. DispInfo -> String -> (a -> Doc) -> Map Name a -> [Doc]
ppSection DispInfo
disp String
"Constraint Synonyms" forall a. PP a => a -> Doc
pp Map Name TySyn
cts
  where
  (Map Name TySyn
cts,Map Name TySyn
tss)  = forall a k. (a -> Bool) -> Map k a -> (Map k a, Map k a)
Map.partition TySyn -> Bool
isCtrait (IfaceDecls -> Map Name TySyn
ifTySyns IfaceDecls
decls)
  isCtrait :: TySyn -> Bool
isCtrait TySyn
t = Kind -> Kind
T.kindResult (forall t. HasKind t => t -> Kind
T.kindOf (TySyn -> Type
T.tsDef TySyn
t)) forall a. Eq a => a -> a -> Bool
== Kind
T.KProp

browsePrimTys :: DispInfo -> IfaceDecls -> [Doc]
browsePrimTys :: DispInfo -> IfaceDecls -> [Doc]
browsePrimTys DispInfo
disp IfaceDecls
decls =
  forall a. DispInfo -> String -> (a -> Doc) -> Map Name a -> [Doc]
ppSection DispInfo
disp String
"Primitive Types" AbstractType -> Doc
ppA (IfaceDecls -> Map Name AbstractType
ifAbstractTypes IfaceDecls
decls)
  where
  ppA :: AbstractType -> Doc
ppA AbstractType
a = Int -> Doc -> Doc
nest Int
2 ([Doc] -> Doc
sep [forall a. PP a => a -> Doc
pp (AbstractType -> Name
T.atName AbstractType
a) Doc -> Doc -> Doc
<+> Doc
":", forall a. PP a => a -> Doc
pp (AbstractType -> Kind
T.atKind AbstractType
a)])

browseNewtypes :: DispInfo -> IfaceDecls -> [Doc]
browseNewtypes :: DispInfo -> IfaceDecls -> [Doc]
browseNewtypes DispInfo
disp IfaceDecls
decls =
  forall a. DispInfo -> String -> (a -> Doc) -> Map Name a -> [Doc]
ppSection DispInfo
disp String
"Newtypes" Newtype -> Doc
T.ppNewtypeShort (IfaceDecls -> Map Name Newtype
ifNewtypes IfaceDecls
decls)

browseVars :: DispInfo -> IfaceDecls -> [Doc]
browseVars :: DispInfo -> IfaceDecls -> [Doc]
browseVars DispInfo
disp IfaceDecls
decls =
     forall a. DispInfo -> String -> (a -> Doc) -> Map Name a -> [Doc]
ppSection DispInfo
disp String
"Properties" IfaceDecl -> Doc
ppVar Map Name IfaceDecl
props
  forall a. [a] -> [a] -> [a]
++ forall a. DispInfo -> String -> (a -> Doc) -> Map Name a -> [Doc]
ppSection DispInfo
disp String
"Symbols"    IfaceDecl -> Doc
ppVar Map Name IfaceDecl
syms
  where
  isProp :: IfaceDecl -> Bool
isProp IfaceDecl
p     = Pragma
PragmaProperty forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` IfaceDecl -> [Pragma]
ifDeclPragmas IfaceDecl
p
  (Map Name IfaceDecl
props,Map Name IfaceDecl
syms) = forall a k. (a -> Bool) -> Map k a -> (Map k a, Map k a)
Map.partition IfaceDecl -> Bool
isProp (IfaceDecls -> Map Name IfaceDecl
ifDecls IfaceDecls
decls)

  ppVar :: IfaceDecl -> Doc
ppVar IfaceDecl
d      = Int -> Doc -> Doc
nest Int
2 ([Doc] -> Doc
sep [forall a. PP a => a -> Doc
pp (IfaceDecl -> Name
ifDeclName IfaceDecl
d) Doc -> Doc -> Doc
<+> Doc
":", forall a. PP a => a -> Doc
pp (IfaceDecl -> Schema
ifDeclSig IfaceDecl
d)])

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

ppSection :: DispInfo -> String -> (a -> Doc) -> Map Name a -> [Doc]
ppSection :: forall a. DispInfo -> String -> (a -> Doc) -> Map Name a -> [Doc]
ppSection DispInfo
disp String
heading a -> Doc
ppThing Map Name a
mp =
  String -> [Doc] -> [Doc]
ppSectionHeading String
heading 
  case DispInfo -> BrowseHow
dispHow DispInfo
disp of
    BrowseHow
BrowseExported | [(ModPath
_,[a]
xs)] <- [(ModPath, [a])]
grouped -> [a] -> [Doc]
ppThings [a]
xs
    BrowseHow
_ -> forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {a}. PP a => (a, [a]) -> [Doc]
ppMod [(ModPath, [a])]
grouped
  where
  grouped :: [(ModPath, [a])]
grouped = forall a. NameDisp -> Map Name a -> [(ModPath, [a])]
groupDecls (DispInfo -> NameDisp
env DispInfo
disp) Map Name a
mp

  ppThings :: [a] -> [Doc]
ppThings [a]
xs = forall a b. (a -> b) -> [a] -> [b]
map a -> Doc
ppThing [a]
xs forall a. [a] -> [a] -> [a]
++ [Doc
" "]

  ppMod :: (a, [a]) -> [Doc]
ppMod (a
nm,[a]
things) =
    [ Doc
"From" Doc -> Doc -> Doc
<+> forall a. PP a => a -> Doc
pp a
nm
    , Doc
"-----" Doc -> Doc -> Doc
<.> String -> Doc
text (forall a b. (a -> b) -> [a] -> [b]
map (forall a b. a -> b -> a
const Char
'-') (forall a. Show a => a -> String
show (NameDisp -> Doc -> Doc Void
runDoc (DispInfo -> NameDisp
env DispInfo
disp) (forall a. PP a => a -> Doc
pp a
nm))))
    , Doc
"     "
    , Int -> Doc -> Doc
indent Int
2 ([Doc] -> Doc
vcat ([a] -> [Doc]
ppThings [a]
things))
    ]

ppSectionHeading :: String -> [Doc] -> [Doc]
ppSectionHeading :: String -> [Doc] -> [Doc]
ppSectionHeading String
heading [Doc]
body
  | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Doc]
body = []
  | Bool
otherwise = 
     [ String -> Doc
text String
heading
     , String -> Doc
text (forall a b. (a -> b) -> [a] -> [b]
map (forall a b. a -> b -> a
const Char
'=') String
heading)
     , Doc
"    "
     , Int -> Doc -> Doc
indent Int
2 ([Doc] -> Doc
vcat [Doc]
body)
     ]




-- | Organize by module where defined, then sort by name.
groupDecls :: NameDisp -> Map Name a -> [(ModPath,[a])]
groupDecls :: forall a. NameDisp -> Map Name a -> [(ModPath, [a])]
groupDecls NameDisp
disp = forall k a. Map k a -> [(k, a)]
Map.toList
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. NameDisp -> [(Name, a)] -> [a]
sortByName NameDisp
disp)
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith forall a. [a] -> [a] -> [a]
(++)
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall {b}. (Name, b) -> Maybe (ModPath, [(Name, b)])
toEntry
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
Map.toList
  where
  toEntry :: (Name, b) -> Maybe (ModPath, [(Name, b)])
toEntry (Name
n,b
a) =
    case Name -> NameInfo
nameInfo Name
n of
      GlobalName NameSource
_ OrigName
og -> forall a. a -> Maybe a
Just (OrigName -> ModPath
ogModule OrigName
og,[(Name
n,b
a)])
      NameInfo
_               -> forall a. Maybe a
Nothing


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