git.iko.soy/Idris-dev
on master help sign in
Merge pull request #2027 from david-christiansen/issue/2019
abe0f32David Christiansen
idris.cabal+4−1
compare with master
unifiedsplit
@@ -631,7 +631,10 @@ Extra-source-files:
631 test/docs002/input
631 test/docs002/input
632 test/docs002/*.idr
632 test/docs002/*.idr
633 test/docs002/expected
633 test/docs002/expected
634−
634+ test/docs003/run
635+ test/docs003/input
636+ test/docs003/*.idr
637+ test/docs003/expected
635
638
636
639
637source-repository head
640source-repository head
src/Idris/Delaborate.hs+1−1
@@ -1,6 +1,6 @@
1{-# LANGUAGE PatternGuards #-}
1{-# LANGUAGE PatternGuards #-}
2{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}
2{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}
3−module Idris.Delaborate (bugaddr, delab, delab', delabMV, delabTy, delabTy', fancifyAnnots, pprintDelab, pprintDelabTy, pprintErr) where
3+module Idris.Delaborate (annName, bugaddr, delab, delab', delabMV, delabTy, delabTy', fancifyAnnots, pprintDelab, pprintDelabTy, pprintErr) where
4
4
5-- Convert core TT back into high level syntax, primarily for display
5-- Convert core TT back into high level syntax, primarily for display
6-- purposes.
6-- purposes.
src/Idris/Docs.hs+55−19
@@ -1,4 +1,5 @@
1−{-# LANGUAGE DeriveFunctor, PatternGuards #-}
1+{-# LANGUAGE DeriveFunctor, PatternGuards, MultiWayIf #-}
2+{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}
2module Idris.Docs (pprintDocs, getDocs, pprintConstDocs, FunDoc, FunDoc'(..), Docs, Docs'(..)) where
3module Idris.Docs (pprintDocs, getDocs, pprintConstDocs, FunDoc, FunDoc'(..), Docs, Docs'(..)) where
3
4
4import Idris.AbsSyntax
5import Idris.AbsSyntax
@@ -10,6 +11,8 @@ import Idris.Docstrings (Docstring, emptyDocstring, noDocs, nullDocstring, rende
10
11
11import Util.Pretty
12import Util.Pretty
12
13
14+import Control.Arrow (first)
15+
13import Data.Maybe
16import Data.Maybe
14import Data.List
17import Data.List
15import qualified Data.Text as T
18import qualified Data.Text as T
@@ -32,9 +35,10 @@ data Docs' d = FunDoc (FunDoc' d)
32 | ClassDoc Name d -- class docs
35 | ClassDoc Name d -- class docs
33 [FunDoc' d] -- method docs
36 [FunDoc' d] -- method docs
34 [(Name, Maybe d)] -- parameters and their docstrings
37 [(Name, Maybe d)] -- parameters and their docstrings
35− [(PTerm, (d, [(Name, d)]))] -- instances
38+ [(Maybe Name, PTerm, (d, [(Name, d)]))] -- instances: name for named instances, the constraint term, the docs
36 [PTerm] -- subclasses
39 [PTerm] -- subclasses
37 [PTerm] -- superclasses
40 [PTerm] -- superclasses
41+ | NamedInstanceDoc Name (FunDoc' d) -- name is class
38 | ModDoc [String] -- Module name
42 | ModDoc [String] -- Module name
39 d
43 d
40 deriving Functor
44 deriving Functor
@@ -102,7 +106,11 @@ pprintDocs ist (ClassDoc n doc meths params instances subclasses superclasses)
102 <$>
106 <$>
103 nest 4 (text "Instances:" <$>
107 nest 4 (text "Instances:" <$>
104 vsep (if null instances then [text "<no instances>"]
108 vsep (if null instances then [text "<no instances>"]
105− else map pprintInstance 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)))
106 <>
114 <>
107 (if null subclasses then empty
115 (if null subclasses then empty
108 else line <$> nest 4 (text "Subclasses:" <$>
116 else line <$> nest 4 (text "Subclasses:" <$>
@@ -113,14 +121,17 @@ pprintDocs ist (ClassDoc n doc meths params instances subclasses superclasses)
113 vsep (map dumpInstance superclasses)))
121 vsep (map dumpInstance superclasses)))
114 where
122 where
115 params' = zip pNames (repeat False)
123 params' = zip pNames (repeat False)
124+
125+ (normalInstances, namedInstances) = partition (\(n, _, _) -> not $ isJust n)
126+ instances
116
127
117 pNames = map fst params
128 pNames = map fst params
118
129
119 ppo = ppOptionIst ist
130 ppo = ppOptionIst ist
120 infixes = idris_infixes ist
131 infixes = idris_infixes ist
121
132
122− pprintInstance (term, (doc, argDocs)) =
133+ pprintInstance (mname, term, (doc, argDocs)) =
123− nest 4 (dumpInstance term <>
134+ nest 4 (iname mname <> dumpInstance term <>
124 (if nullDocstring doc
135 (if nullDocstring doc
125 then empty
136 then empty
126 else line <>
137 else line <>
@@ -133,6 +144,10 @@ pprintDocs ist (ClassDoc n doc meths params instances subclasses superclasses)
133 then empty
144 then empty
134 else line <> vsep (map (prettyInstanceParam (map fst argDocs)) argDocs))
145 else line <> vsep (map (prettyInstanceParam (map fst argDocs)) argDocs))
135
146
147+
148+ iname Nothing = empty
149+ iname (Just n) = annName n <+> colon <> space
150+
136 prettyInstanceParam params (name, doc) =
151 prettyInstanceParam params (name, doc) =
137 if nullDocstring doc
152 if nullDocstring doc
138 then empty
153 then empty
@@ -170,6 +185,9 @@ pprintDocs ist (ClassDoc n doc meths params instances subclasses superclasses)
170 then vsep (map (\(nm,md) -> prettyName True False params' nm <+> maybe empty (showDoc ist) md) params)
185 then vsep (map (\(nm,md) -> prettyName True False params' nm <+> maybe empty (showDoc ist) md) params)
171 else hsep (punctuate comma (map (prettyName True False params' . fst) params))
186 else hsep (punctuate comma (map (prettyName True False params' . fst) params))
172
187
188+pprintDocs ist (NamedInstanceDoc _cls doc)
189+ = nest 4 (text "Named instance:" <$> pprintFD ist doc)
190+
173pprintDocs ist (ModDoc mod docs)
191pprintDocs ist (ModDoc mod docs)
174 = nest 4 $ text "Module" <+> text (concat (intersperse "." mod)) <> colon <$>
192 = nest 4 $ text "Module" <+> text (concat (intersperse "." mod)) <> colon <$>
175 renderDocstring (renderDocTerm (pprintDelab ist) (normaliseAll (tt_ctxt ist) [])) docs
193 renderDocstring (renderDocTerm (pprintDelab ist) (normaliseAll (tt_ctxt ist) [])) docs
@@ -190,13 +208,23 @@ getDocs n@(NS n' ns) w | n' == modDocName
190 " do not exist! This shouldn't have happened and is a bug."
208 " do not exist! This shouldn't have happened and is a bug."
191getDocs n w
209getDocs n w
192 = do i <- getIState
210 = do i <- getIState
193− docs <- case lookupCtxt n (idris_classes i) of
211+ docs <- if | Just ci <- lookupCtxtExact n (idris_classes i)
194− [ci] -> docClass n ci
212+ -> docClass n ci
195− _ -> case lookupCtxt n (idris_datatypes i) of
213+ | Just ti <- lookupCtxtExact n (idris_datatypes i)
196− [ti] -> docData n ti
214+ -> docData n ti
215+ | Just class_ <- classNameForInst i n
216+ -> do fd <- docFun n
217+ return $ NamedInstanceDoc class_ fd
218+ | otherwise
197− _ -> do fd <- docFun n
219+ -> do fd <- docFun n
198− return (FunDoc fd)
220+ return (FunDoc fd)
199 return $ fmap (howMuch w) docs
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+ ]
200
228
201docData :: Name -> TypeInfo -> Idris Docs
229docData :: Name -> TypeInfo -> Idris Docs
202docData n ti
230docData n ti
@@ -209,19 +237,26 @@ docClass n ci
209 = do i <- getIState
237 = do i <- getIState
210 let docStrings = listToMaybe $ lookupCtxt n $ idris_docstrings i
238 let docStrings = listToMaybe $ lookupCtxt n $ idris_docstrings i
211 docstr = maybe emptyDocstring fst docStrings
239 docstr = maybe emptyDocstring fst docStrings
212− params = map (\pn -> (pn, docStrings >>= (lookup pn . snd))) (class_params ci)
240+ params = map (\pn -> (pn, docStrings >>= (lookup pn . snd)))
241+ (class_params ci)
213− instanceDocs = map (fromMaybe (emptyDocstring, []) .
242+ docsForInstance inst = fromMaybe (emptyDocstring, []) .
214− listToMaybe .
215− flip lookupCtxt (idris_docstrings i))
243+ flip lookupCtxtExact (idris_docstrings i) $
216− (class_instances ci)
244+ inst
245+ instances = map (\inst -> (namedInst inst,
246+ delabTy i inst,
247+ docsForInstance inst))
217− instances = zip (map (delabTy i) (class_instances ci)) instanceDocs
248+ (nub (class_instances ci))
218− (subclasses, instances') = partition (isSubclass . fst) instances
249+ (subclasses, instances') = partition (isSubclass . (\(_,tm,_) -> tm)) instances
219 superclasses = catMaybes $ map getDInst (class_default_superclasses ci)
250 superclasses = catMaybes $ map getDInst (class_default_superclasses ci)
220 mdocs <- mapM (docFun . fst) (class_methods ci)
251 mdocs <- mapM (docFun . fst) (class_methods ci)
221 return $ ClassDoc
252 return $ ClassDoc
222 n docstr mdocs params
253 n docstr mdocs params
223− instances' (map fst subclasses) superclasses
254+ instances' (map (\(_,tm,_) -> tm) subclasses) superclasses
224 where
255 where
256+ namedInst (NS n ns) = fmap (flip NS ns) (namedInst n)
257+ namedInst n@(UN _) = Just n
258+ namedInst _ = Nothing
259+
225 getDInst (PInstance _ _ _ _ _ _ _ t _ _) = Just t
260 getDInst (PInstance _ _ _ _ _ _ _ t _ _) = Just t
226 getDInst _ = Nothing
261 getDInst _ = Nothing
227
262
@@ -250,6 +285,7 @@ docFun n
250 where funName :: Name -> String
285 where funName :: Name -> String
251 funName (UN n) = str n
286 funName (UN n) = str n
252 funName (NS n _) = funName n
287 funName (NS n _) = funName n
288+ funName n = show n
253
289
254getPArgNames :: PTerm -> [(Name, Docstring DocTerm)] -> [(Name, PTerm, Plicity, Maybe (Docstring DocTerm))]
290getPArgNames :: PTerm -> [(Name, Docstring DocTerm)] -> [(Name, PTerm, Plicity, Maybe (Docstring DocTerm))]
255getPArgNames (PPi plicity name ty body) ds =
291getPArgNames (PPi plicity name ty body) ds =
test/docs003/docs003.idrnew file+9
@@ -0,0 +1,9 @@
1+module docs003
2+
3+instance [mine] Functor List where
4+ map m [] = []
5+ map m (x :: xs) = m x :: map m xs
6+
7+||| More functors!
8+instance [another] Functor List where
9+ map f xs = map @{mine} f xs
test/docs003/expectednew file+37
@@ -0,0 +1,37 @@
1+Type checking ./docs003.idr
2+Type class Functor
3+ Functors
4+
5+Parameters:
6+ f -- the action of the functor on objects
7+
8+Methods:
9+ map : Functor f => (m : a -> b) -> f a -> f b
10+ The action of the functor on morphisms
11+
12+Instances:
13+ Functor List
14+ Functor Stream
15+ Functor Provider
16+ Functor Binder
17+ Functor PrimIO
18+ Functor (IO' ffi)
19+ Functor Maybe
20+ Functor (Either e)
21+
22+Named instances:
23+ docs003.mine : Functor List
24+ docs003.another : Functor List
25+ More functors!
26+
27+Subclasses:
28+ Traversable f
29+ Applicative f
30+Named instance:
31+ mine : Functor List
32+
33+
34+Named instance:
35+ another : Functor List
36+ More functors!
37+
test/docs003/inputnew file+3
@@ -0,0 +1,3 @@
1+:doc Functor
2+:doc mine
3+:doc another
test/docs003/runnew file+3
@@ -0,0 +1,3 @@
1+#!/usr/bin/env bash
2+idris --consolewidth 80 --quiet --nocolor docs003.idr < input
3+rm *.ibc