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