git.iko.soy/Idris-dev
on 465cc1c help sign in
Idris-dev/src/Idris/Docs.hs
305 lines 13 kB history raw
1{-# LANGUAGE DeriveFunctor, PatternGuards, MultiWayIf #-}
2{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}
3module Idris.Docs (pprintDocs, getDocs, pprintConstDocs, FunDoc, FunDoc'(..), Docs, Docs'(..)) where
5import Idris.AbsSyntax
6import Idris.AbsSyntaxTree
7import Idris.Delaborate
8import Idris.Core.TT
9import Idris.Core.Evaluate
10import Idris.Docstrings (Docstring, emptyDocstring, noDocs, nullDocstring, renderDocstring, DocTerm, renderDocTerm, overview)
12import Util.Pretty
14import Control.Arrow (first)
16import Data.Maybe
17import Data.List
18import qualified Data.Text as T
20-- TODO: Only include names with public/abstract accessibility
21--
22-- Issue #1573 on the Issue tracker.
23-- https://github.com/idris-lang/Idris-dev/issues/1573
24data FunDoc' d = FD Name d
25 [(Name, PTerm, Plicity, Maybe d)] -- args: name, ty, implicit, docs
26 PTerm -- function type
27 (Maybe Fixity)
28 deriving Functor
30type FunDoc = FunDoc' (Docstring DocTerm)
32data Docs' d = FunDoc (FunDoc' d)
33 | DataDoc (FunDoc' d) -- type constructor docs
34 [FunDoc' d] -- data constructor docs
35 | ClassDoc Name d -- class docs
36 [FunDoc' d] -- method docs
37 [(Name, Maybe d)] -- parameters and their docstrings
38 [(Maybe Name, PTerm, (d, [(Name, d)]))] -- instances: name for named instances, the constraint term, the docs
39 [PTerm] -- subclasses
40 [PTerm] -- superclasses
41 | NamedInstanceDoc Name (FunDoc' d) -- name is class
42 | ModDoc [String] -- Module name
43 d
44 deriving Functor
46type Docs = Docs' (Docstring DocTerm)
48showDoc ist d
49 | nullDocstring d = empty
50 | otherwise = text " -- " <>
51 renderDocstring (renderDocTerm (pprintDelab ist) (normaliseAll (tt_ctxt ist) [])) d
53pprintFD :: IState -> FunDoc -> Doc OutputAnnotation
54pprintFD ist (FD n doc args ty f)
55 = nest 4 (prettyName True (ppopt_impl ppo) [] n <+> colon <+>
56 pprintPTerm ppo [] [ n | (n@(UN n'),_,_,_) <- args
57 , not (T.isPrefixOf (T.pack "__") n') ] infixes ty <$>
58 renderDocstring (renderDocTerm (pprintDelab ist) (normaliseAll (tt_ctxt ist) [])) doc <$>
59 maybe empty (\f -> text (show f) <> line) f <>
60 let argshow = showArgs args [] in
61 if not (null argshow)
62 then nest 4 $ text "Arguments:" <$> vsep argshow
63 else empty)
65 where ppo = ppOptionIst ist
66 infixes = idris_infixes ist
67 showArgs ((n, ty, Exp {}, Just d):args) bnd
68 = bindingOf n False <+> colon <+>
69 pprintPTerm ppo bnd [] infixes ty <>
70 showDoc ist d <> line
71 :
72 showArgs args ((n, False):bnd)
73 showArgs ((n, ty, Constraint {}, Just d):args) bnd
74 = text "Class constraint" <+>
75 pprintPTerm ppo bnd [] infixes ty <> showDoc ist d <> line
76 :
77 showArgs args ((n, True):bnd)
78 showArgs ((n, ty, Imp {}, Just d):args) bnd
79 = text "(implicit)" <+>
80 bindingOf n True <+> colon <+>
81 pprintPTerm ppo bnd [] infixes ty <>
82 showDoc ist d <> line
83 :
84 showArgs args ((n, True):bnd)
85 showArgs ((n, _, _, _):args) bnd = showArgs args ((n, True):bnd)
86 showArgs [] _ = []
89pprintDocs :: IState -> Docs -> Doc OutputAnnotation
90pprintDocs ist (FunDoc d) = pprintFD ist d
91pprintDocs ist (DataDoc t args)
92 = text "Data type" <+> pprintFD ist t <$>
93 if null args then text "No constructors."
94 else nest 4 (text "Constructors:" <> line <>
95 vsep (map (pprintFD ist) args))
96pprintDocs ist (ClassDoc n doc meths params instances subclasses superclasses)
97 = nest 4 (text "Type class" <+> prettyName True (ppopt_impl ppo) [] n <>
98 if nullDocstring doc
99 then empty
100 else line <> renderDocstring (renderDocTerm (pprintDelab ist) (normaliseAll (tt_ctxt ist) [])) doc)
101 <> line <$>
102 nest 4 (text "Parameters:" <$> prettyParameters)
103 <> line <$>
104 nest 4 (text "Methods:" <$>
105 vsep (map (pprintFD ist) meths))
106 <$>
107 nest 4 (text "Instances:" <$>
108 vsep (if null instances then [text "<no instances>"]
109 else map pprintInstance normalInstances))
110 <>
111 (if null namedInstances then empty
112 else line <$> nest 4 (text "Named instances:" <$>
113 vsep (map pprintInstance namedInstances)))
114 <>
115 (if null subclasses then empty
116 else line <$> nest 4 (text "Subclasses:" <$>
117 vsep (map (dumpInstance . prettifySubclasses) subclasses)))
118 <>
119 (if null superclasses then empty
120 else line <$> nest 4 (text "Default superclass instances:" <$>
121 vsep (map dumpInstance superclasses)))
122 where
123 params' = zip pNames (repeat False)
125 (normalInstances, namedInstances) = partition (\(n, _, _) -> not $ isJust n)
126 instances
128 pNames = map fst params
130 ppo = ppOptionIst ist
131 infixes = idris_infixes ist
133 pprintInstance (mname, term, (doc, argDocs)) =
134 nest 4 (iname mname <> dumpInstance term <>
135 (if nullDocstring doc
136 then empty
137 else line <>
138 renderDocstring
139 (renderDocTerm
140 (pprintDelab ist)
141 (normaliseAll (tt_ctxt ist) []))
142 doc) <>
143 if null argDocs
144 then empty
145 else line <> vsep (map (prettyInstanceParam (map fst argDocs)) argDocs))
148 iname Nothing = empty
149 iname (Just n) = annName n <+> colon <> space
151 prettyInstanceParam params (name, doc) =
152 if nullDocstring doc
153 then empty
154 else prettyName True False (zip params (repeat False)) name <+>
155 showDoc ist doc
157-- if any (isJust . snd) params
158-- then vsep (map (\(nm,md) -> prettyName True False params' nm <+> maybe empty (showDoc ist) md) params)
159-- else hsep (punctuate comma (map (prettyName True False params' . fst) params))
161 dumpInstance :: PTerm -> Doc OutputAnnotation
162 dumpInstance = pprintPTerm ppo params' [] infixes
164 prettifySubclasses (PPi (Constraint _ _) _ tm _) = prettifySubclasses tm
165 prettifySubclasses (PPi plcity nm t1 t2) = PPi plcity (safeHead nm pNames) (prettifySubclasses t1) (prettifySubclasses t2)
166 prettifySubclasses (PApp fc ref args) = PApp fc ref $ updateArgs pNames args
167 prettifySubclasses tm = tm
169 safeHead _ (y:_) = y
170 safeHead x [] = x
172 updateArgs (p:ps) ((PExp prty opts _ ref):as) = (PExp prty opts p (updateRef p ref)) : updateArgs ps as
173 updateArgs ps (a:as) = a : updateArgs ps as
174 updateArgs _ _ = []
176 updateRef nm (PRef fc _) = PRef fc nm
177 updateRef _ pt = pt
179 isSubclass (PPi (Constraint _ _) _ (PApp _ _ args) (PApp _ (PRef _ nm) args')) = nm == n && map getTm args == map getTm args'
180 isSubclass (PPi _ _ _ pt) = isSubclass pt
181 isSubclass _ = False
183 prettyParameters =
184 if any (isJust . snd) params
185 then vsep (map (\(nm,md) -> prettyName True False params' nm <+> maybe empty (showDoc ist) md) params)
186 else hsep (punctuate comma (map (prettyName True False params' . fst) params))
188pprintDocs ist (NamedInstanceDoc _cls doc)
189 = nest 4 (text "Named instance:" <$> pprintFD ist doc)
191pprintDocs ist (ModDoc mod docs)
192 = nest 4 $ text "Module" <+> text (concat (intersperse "." mod)) <> colon <$>
193 renderDocstring (renderDocTerm (pprintDelab ist) (normaliseAll (tt_ctxt ist) [])) docs
195-- | Determine a truncation function depending how much docs the user
196-- wants to see
197howMuch FullDocs = id
198howMuch OverviewDocs = overview
200-- | Given a fully-qualified, disambiguated name, construct the
201-- documentation object for it
202getDocs :: Name -> HowMuchDocs -> Idris Docs
203getDocs n@(NS n' ns) w | n' == modDocName
204 = do i <- getIState
205 case lookupCtxtExact n (idris_moduledocs i) of
206 Just doc -> return . ModDoc (reverse (map T.unpack ns)) $ howMuch w doc
207 Nothing -> fail $ "Module docs for " ++ show (reverse (map T.unpack ns)) ++
208 " do not exist! This shouldn't have happened and is a bug."
209getDocs n w
210 = do i <- getIState
211 docs <- if | Just ci <- lookupCtxtExact n (idris_classes i)
212 -> docClass n ci
213 | Just ti <- lookupCtxtExact n (idris_datatypes i)
214 -> docData n ti
215 | Just class_ <- classNameForInst i n
216 -> do fd <- docFun n
217 return $ NamedInstanceDoc class_ fd
218 | otherwise
219 -> do fd <- docFun n
220 return (FunDoc fd)
221 return $ fmap (howMuch w) docs
222 where classNameForInst :: IState -> Name -> Maybe Name
223 classNameForInst ist n =
224 listToMaybe [ cn
225 | (cn, ci) <- toAlist (idris_classes ist)
226 , n `elem` class_instances ci
227 ]
229docData :: Name -> TypeInfo -> Idris Docs
230docData n ti
231 = do tdoc <- docFun n
232 cdocs <- mapM docFun (con_names ti)
233 return (DataDoc tdoc cdocs)
235docClass :: Name -> ClassInfo -> Idris Docs
236docClass n ci
237 = do i <- getIState
238 let docStrings = listToMaybe $ lookupCtxt n $ idris_docstrings i
239 docstr = maybe emptyDocstring fst docStrings
240 params = map (\pn -> (pn, docStrings >>= (lookup pn . snd)))
241 (class_params ci)
242 docsForInstance inst = fromMaybe (emptyDocstring, []) .
243 flip lookupCtxtExact (idris_docstrings i) $
244 inst
245 instances = map (\inst -> (namedInst inst,
246 delabTy i inst,
247 docsForInstance inst))
248 (nub (class_instances ci))
249 (subclasses, instances') = partition (isSubclass . (\(_,tm,_) -> tm)) instances
250 superclasses = catMaybes $ map getDInst (class_default_superclasses ci)
251 mdocs <- mapM (docFun . fst) (class_methods ci)
252 return $ ClassDoc
253 n docstr mdocs params
254 instances' (map (\(_,tm,_) -> tm) subclasses) superclasses
255 where
256 namedInst (NS n ns) = fmap (flip NS ns) (namedInst n)
257 namedInst n@(UN _) = Just n
258 namedInst _ = Nothing
260 getDInst (PInstance _ _ _ _ _ _ _ t _ _) = Just t
261 getDInst _ = Nothing
263 isSubclass (PPi (Constraint _ _) _ (PApp _ _ args) (PApp _ (PRef _ nm) args'))
264 = nm == n && map getTm args == map getTm args'
265 isSubclass (PPi _ _ _ pt)
266 = isSubclass pt
267 isSubclass _
268 = False
270docFun :: Name -> Idris FunDoc
271docFun n
272 = do i <- getIState
273 let (docstr, argDocs) = case lookupCtxt n (idris_docstrings i) of
274 [d] -> d
275 _ -> noDocs
276 let ty = delabTy i n
277 let args = getPArgNames ty argDocs
278 let infixes = idris_infixes i
279 let fixdecls = filter (\(Fix _ x) -> x == funName n) infixes
280 let f = case fixdecls of
281 [] -> Nothing
282 (Fix x _:_) -> Just x
284 return (FD n docstr args ty f)
285 where funName :: Name -> String
286 funName (UN n) = str n
287 funName (NS n _) = funName n
288 funName n = show n
290getPArgNames :: PTerm -> [(Name, Docstring DocTerm)] -> [(Name, PTerm, Plicity, Maybe (Docstring DocTerm))]
291getPArgNames (PPi plicity name ty body) ds =
292 (name, ty, plicity, lookup name ds) : getPArgNames body ds
293getPArgNames _ _ = []
295pprintConstDocs :: IState -> Const -> String -> Doc OutputAnnotation
296pprintConstDocs ist c str = text "Primitive" <+> text (if constIsType c then "type" else "value") <+>
297 pprintPTerm (ppOptionIst ist) [] [] [] (PConstant c) <+> colon <+>
298 pprintPTerm (ppOptionIst ist) [] [] [] (t c) <>
299 nest 4 (line <> text str)
301 where t (Fl _) = PConstant $ AType ATFloat
302 t (BI _) = PConstant $ AType (ATInt ITBig)
303 t (Str _) = PConstant StrType
304 t (Ch c) = PConstant $ AType (ATInt ITChar)
305 t _ = PType