{-# 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.ModuleSystem.Env(ModContext(..))
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 = [[Doc]] -> [Doc]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ NameDisp -> IfaceParams -> [Doc]
browseMParams (DispInfo -> NameDisp
env DispInfo
disp) (ModContext -> IfaceParams
mctxParams ModContext
mc)
    , DispInfo -> IfaceDecls -> [Doc]
browseMods 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 :: BrowseHow -> NameDisp -> DispInfo
DispInfo { dispHow :: BrowseHow
dispHow = BrowseHow
how, env :: NameDisp
env = ModContext -> NameDisp
mctxNameDisp ModContext
mc }
  decls :: IfaceDecls
decls    = (Name -> Bool) -> IfaceDecls -> IfaceDecls
filterIfaceDecls (Name -> Set Name -> Bool
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)
  visNames :: Set Name
visNames = 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 -> IfaceParams -> [Doc]
browseMParams :: NameDisp -> IfaceParams -> [Doc]
browseMParams NameDisp
disp IfaceParams
params =
  String -> [Doc] -> [Doc]
ppSectionHeading String
"Module Parameters"
  ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$ [Doc] -> [Doc]
forall a. IsString a => [a] -> [a]
addEmpty
  ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$ (ModTParam -> Doc) -> [ModTParam] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ModTParam -> Doc
ppParamTy (NameDisp -> [(Name, ModTParam)] -> [ModTParam]
forall a. NameDisp -> [(Name, a)] -> [a]
sortByName NameDisp
disp (Map Name ModTParam -> [(Name, ModTParam)]
forall k a. Map k a -> [(k, a)]
Map.toList (IfaceParams -> Map Name ModTParam
ifParamTypes IfaceParams
params))) [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++
    (ModVParam -> Doc) -> [ModVParam] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ModVParam -> Doc
ppParamFu (NameDisp -> [(Name, ModVParam)] -> [ModVParam]
forall a. NameDisp -> [(Name, a)] -> [a]
sortByName NameDisp
disp (Map Name ModVParam -> [(Name, ModVParam)]
forall k a. Map k a -> [(k, a)]
Map.toList (IfaceParams -> Map Name ModVParam
ifParamFuns  IfaceParams
params)))
  where
  ppParamTy :: ModTParam -> Doc
ppParamTy ModTParam
p = Int -> Doc -> Doc
nest Int
2 ([Doc] -> Doc
sep [Doc
"type", Name -> Doc
forall a. PP a => a -> Doc
pp (ModTParam -> Name
T.mtpName ModTParam
p) Doc -> Doc -> Doc
<+> Doc
":", Kind -> 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 [Name -> Doc
forall a. PP a => a -> Doc
pp (ModVParam -> Name
T.mvpName ModVParam
p) Doc -> Doc -> Doc
<+> Doc
":", Schema -> Doc
forall a. PP a => a -> Doc
pp (ModVParam -> Schema
T.mvpType ModVParam
p)])
  -- XXX: should we print the constraints somewhere too?

  addEmpty :: [a] -> [a]
addEmpty [a]
xs = case [a]
xs of
                  [] -> []
                  [a]
_  -> [a]
xs [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a
"    "]


browseMods :: DispInfo -> IfaceDecls -> [Doc]
browseMods :: DispInfo -> IfaceDecls -> [Doc]
browseMods DispInfo
disp IfaceDecls
decls =
  DispInfo
-> String
-> (IfaceG Name -> Doc)
-> Map Name (IfaceG Name)
-> [Doc]
forall a. DispInfo -> String -> (a -> Doc) -> Map Name a -> [Doc]
ppSection DispInfo
disp String
"Modules" IfaceG Name -> Doc
forall a. PP a => IfaceG a -> Doc
ppM (IfaceDecls -> Map Name (IfaceG Name)
ifModules IfaceDecls
decls)
  where
  ppM :: IfaceG a -> Doc
ppM IfaceG a
m = Doc
"submodule" Doc -> Doc -> Doc
<+> a -> Doc
forall a. PP a => a -> Doc
pp (IfaceG a -> a
forall mname. IfaceG mname -> mname
ifModName IfaceG a
m)
  -- XXX: can print a lot more information about the moduels, but
  -- might be better to do that with a separate command




browseTSyns :: DispInfo -> IfaceDecls -> [Doc]
browseTSyns :: DispInfo -> IfaceDecls -> [Doc]
browseTSyns DispInfo
disp IfaceDecls
decls =
     DispInfo -> String -> (TySyn -> Doc) -> Map Name TySyn -> [Doc]
forall a. DispInfo -> String -> (a -> Doc) -> Map Name a -> [Doc]
ppSection DispInfo
disp String
"Type Synonyms" TySyn -> Doc
forall a. PP a => a -> Doc
pp Map Name TySyn
tss
  [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ DispInfo -> String -> (TySyn -> Doc) -> Map Name TySyn -> [Doc]
forall a. DispInfo -> String -> (a -> Doc) -> Map Name a -> [Doc]
ppSection DispInfo
disp String
"Constraint Synonyms" TySyn -> Doc
forall a. PP a => a -> Doc
pp Map Name TySyn
cts
  where
  (Map Name TySyn
cts,Map Name TySyn
tss)  = (TySyn -> Bool)
-> Map Name TySyn -> (Map Name TySyn, Map Name TySyn)
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 (Type -> Kind
forall t. HasKind t => t -> Kind
T.kindOf (TySyn -> Type
T.tsDef TySyn
t)) Kind -> Kind -> Bool
forall a. Eq a => a -> a -> Bool
== Kind
T.KProp

browsePrimTys :: DispInfo -> IfaceDecls -> [Doc]
browsePrimTys :: DispInfo -> IfaceDecls -> [Doc]
browsePrimTys DispInfo
disp IfaceDecls
decls =
  DispInfo
-> String
-> (AbstractType -> Doc)
-> Map Name AbstractType
-> [Doc]
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 [Name -> Doc
forall a. PP a => a -> Doc
pp (AbstractType -> Name
T.atName AbstractType
a) Doc -> Doc -> Doc
<+> Doc
":", Kind -> 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 =
  DispInfo -> String -> (Newtype -> Doc) -> Map Name Newtype -> [Doc]
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 =
     DispInfo
-> String -> (IfaceDecl -> Doc) -> Map Name IfaceDecl -> [Doc]
forall a. DispInfo -> String -> (a -> Doc) -> Map Name a -> [Doc]
ppSection DispInfo
disp String
"Properties" IfaceDecl -> Doc
ppVar Map Name IfaceDecl
props
  [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ DispInfo
-> String -> (IfaceDecl -> Doc) -> Map Name IfaceDecl -> [Doc]
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 Pragma -> [Pragma] -> Bool
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) = (IfaceDecl -> Bool)
-> Map Name IfaceDecl -> (Map Name IfaceDecl, Map Name IfaceDecl)
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 [Name -> Doc
forall a. PP a => a -> Doc
pp (IfaceDecl -> Name
ifDeclName IfaceDecl
d) Doc -> Doc -> Doc
<+> Doc
":", Schema -> Doc
forall a. PP a => a -> Doc
pp (IfaceDecl -> Schema
ifDeclSig IfaceDecl
d)])

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

ppSection :: DispInfo -> String -> (a -> Doc) -> Map Name a -> [Doc]
ppSection :: 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
_ -> ((ModPath, [a]) -> [Doc]) -> [(ModPath, [a])] -> [Doc]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (ModPath, [a]) -> [Doc]
forall a. PP a => (a, [a]) -> [Doc]
ppMod [(ModPath, [a])]
grouped
  where
  grouped :: [(ModPath, [a])]
grouped = NameDisp -> Map Name a -> [(ModPath, [a])]
forall a. NameDisp -> Map Name a -> [(ModPath, [a])]
groupDecls (DispInfo -> NameDisp
env DispInfo
disp) Map Name a
mp

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

  ppMod :: (a, [a]) -> [Doc]
ppMod (a
nm,[a]
things) =
    [ Doc
"From" Doc -> Doc -> Doc
<+> a -> Doc
forall a. PP a => a -> Doc
pp a
nm
    , Doc
"-----" Doc -> Doc -> Doc
<.> String -> Doc
text ((Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map (Char -> Char -> Char
forall a b. a -> b -> a
const Char
'-') (Doc Void -> String
forall a. Show a => a -> String
show (NameDisp -> Doc -> Doc Void
runDoc (DispInfo -> NameDisp
env DispInfo
disp) (a -> Doc
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
  | [Doc] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Doc]
body = []
  | Bool
otherwise = 
     [ String -> Doc
text String
heading
     , String -> Doc
text ((Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map (Char -> Char -> Char
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 :: NameDisp -> Map Name a -> [(ModPath, [a])]
groupDecls NameDisp
disp = Map ModPath [a] -> [(ModPath, [a])]
forall k a. Map k a -> [(k, a)]
Map.toList
                (Map ModPath [a] -> [(ModPath, [a])])
-> (Map Name a -> Map ModPath [a])
-> Map Name a
-> [(ModPath, [a])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(Name, a)] -> [a]) -> Map ModPath [(Name, a)] -> Map ModPath [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (NameDisp -> [(Name, a)] -> [a]
forall a. NameDisp -> [(Name, a)] -> [a]
sortByName NameDisp
disp)
                (Map ModPath [(Name, a)] -> Map ModPath [a])
-> (Map Name a -> Map ModPath [(Name, a)])
-> Map Name a
-> Map ModPath [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(Name, a)] -> [(Name, a)] -> [(Name, a)])
-> [(ModPath, [(Name, a)])] -> Map ModPath [(Name, a)]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [(Name, a)] -> [(Name, a)] -> [(Name, a)]
forall a. [a] -> [a] -> [a]
(++)
                ([(ModPath, [(Name, a)])] -> Map ModPath [(Name, a)])
-> (Map Name a -> [(ModPath, [(Name, a)])])
-> Map Name a
-> Map ModPath [(Name, a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Name, a) -> Maybe (ModPath, [(Name, a)]))
-> [(Name, a)] -> [(ModPath, [(Name, a)])]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Name, a) -> Maybe (ModPath, [(Name, a)])
forall b. (Name, b) -> Maybe (ModPath, [(Name, b)])
toEntry
                ([(Name, a)] -> [(ModPath, [(Name, a)])])
-> (Map Name a -> [(Name, a)])
-> Map Name a
-> [(ModPath, [(Name, a)])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Name a -> [(Name, a)]
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
      Declared ModPath
m NameSource
_ -> (ModPath, [(Name, b)]) -> Maybe (ModPath, [(Name, b)])
forall a. a -> Maybe a
Just (ModPath
m,[(Name
n,b
a)])
      NameInfo
_            -> Maybe (ModPath, [(Name, b)])
forall a. Maybe a
Nothing


sortByName :: NameDisp -> [(Name,a)] -> [a]
sortByName :: NameDisp -> [(Name, a)] -> [a]
sortByName NameDisp
disp = ((Name, a) -> a) -> [(Name, a)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (Name, a) -> a
forall a b. (a, b) -> b
snd ([(Name, a)] -> [a])
-> ([(Name, a)] -> [(Name, a)]) -> [(Name, a)] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Name, a) -> (Name, a) -> Ordering) -> [(Name, a)] -> [(Name, a)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Name, a) -> (Name, a) -> Ordering
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