Verified Commit 28ccd730 authored by Camil Staps's avatar Camil Staps 🚀

Add parsing of documentation of type definitions

parent abaa6767
......@@ -14,8 +14,8 @@ from Data.Maybe import :: Maybe
= ClassMemberDoc (Maybe Description) [ParamDoc] (Maybe ResultDoc)
:: TypeRhsDoc
= ADTDoc [Documentation] // Only uses ConstructorDoc
| RecordDoc [RecordFieldDoc]
= ADTDoc [Maybe Documentation] // Only uses ConstructorDoc
| RecordDoc [Maybe RecordFieldDoc]
| SynonymDoc (Maybe Description)
:: ParamDoc :== Description
......@@ -25,8 +25,8 @@ from Data.Maybe import :: Maybe
:: Description :== String
:: ParseError
= MissingAsterisk // At least one line did not start with a *
| IllegalState String // Incorrect usage of this module
= MissingAsterisk String // At least one line did not start with a *
| IllegalState String // Incorrect usage of this module
:: ParseWarning
= UnknownField String // Unknown @-field
......@@ -39,6 +39,10 @@ getDocDescription :: Documentation -> Maybe Description
getParamDocs :: Documentation -> [ParamDoc]
getVarDocs :: Documentation -> [ParamDoc]
getResultDoc :: Documentation -> Maybe String
getTypeRhsDoc :: Documentation -> Maybe TypeRhsDoc
getFieldDoc :: Documentation -> Maybe [Maybe RecordFieldDoc]
getConstructorDoc :: Documentation -> Maybe [Maybe Documentation]
getRepresentationDoc :: Documentation -> Maybe Description
parseModuleDoc :: (String -> Either ParseError (Documentation, [ParseWarning]))
parseFunctionDoc :: (String -> Either ParseError (Documentation, [ParseWarning]))
......@@ -51,6 +55,9 @@ parseRecordTypeDoc :: (String -> Either ParseError (Documentation, [ParseWarning
parseConstructorDoc :: String Documentation
-> Either ParseError (Documentation, [ParseWarning])
// Second argument should be a TypeDoc with an ADTDoc
parseFieldDoc :: String Documentation
-> Either ParseError (Documentation, [ParseWarning])
// Second argument should be a TypeDoc with an ADTDoc
traceParseWarnings :: [ParseWarning] !a -> a
traceParseError :: ParseError !a -> a
......@@ -19,7 +19,6 @@ import Data.Tuple
= Param String
| Var String
| Result String
| Field String
| Representation String
:: FieldUpdateFunction :==
......@@ -29,7 +28,6 @@ fieldName :: DocField -> String
fieldName (Param _) = "param"
fieldName (Var _) = "var"
fieldName (Result _) = "result"
fieldName (Field _) = "field"
fieldName (Representation _) = "representation"
getDocDescription :: Documentation -> Maybe Description
......@@ -54,6 +52,25 @@ getResultDoc :: Documentation -> Maybe String
getResultDoc (FunctionDoc _ _ _ r) = r
getResultDoc _ = Nothing
getTypeRhsDoc :: Documentation -> Maybe TypeRhsDoc
getTypeRhsDoc (TypeDoc _ _ rhs) = rhs
getTypeRhsDoc _ = Nothing
getFieldDoc :: Documentation -> Maybe [Maybe RecordFieldDoc]
getFieldDoc doc = case getTypeRhsDoc doc of
Just (RecordDoc fs) = Just fs
_ = Nothing
getConstructorDoc :: Documentation -> Maybe [Maybe Documentation]
getConstructorDoc doc = case getTypeRhsDoc doc of
Just (ADTDoc cs) = Just cs
_ = Nothing
getRepresentationDoc :: Documentation -> Maybe Description
getRepresentationDoc doc = case getTypeRhsDoc doc of
Just (SynonymDoc d) = d
_ = Nothing
parseModuleDoc :: (String -> Either ParseError (Documentation, [ParseWarning]))
parseModuleDoc = parseDocBlock $ ModuleDoc Nothing
......@@ -78,8 +95,18 @@ parseRecordTypeDoc = parseDocBlock $ TypeDoc Nothing [] $ Just $ RecordDoc []
parseConstructorDoc :: String Documentation
-> Either ParseError (Documentation, [ParseWarning])
parseConstructorDoc s (TypeDoc d vs (Just (ADTDoc cs)))
= appFst (TypeDoc d vs o Just o ADTDoc o (\c -> [c:cs]))
= appFst (TypeDoc d vs o Just o ADTDoc o (\c -> [c:cs]) o Just)
<$> parseDocBlock (ConstructorDoc Nothing []) s
parseConstructorDoc _ _
= Left $ IllegalState "parseConstructorDoc"
parseFieldDoc :: String Documentation
-> Either ParseError (Documentation, [ParseWarning])
parseFieldDoc s (TypeDoc d vs (Just (RecordDoc fs)))
= prepareString s >>= \ls ->
Right (TypeDoc d vs $ Just $ RecordDoc [Just $ linesToString ls:fs], [])
parseFieldDoc _ _
= Left $ IllegalState "parseFieldDoc"
updateDesc :: [[Char]] Documentation -> Documentation
updateDesc desc doc = case doc of
......@@ -87,8 +114,9 @@ updateDesc desc doc = case doc of
ModuleDoc _ = ModuleDoc desc`
ClassDoc _ vs cms = ClassDoc desc` vs cms
TypeDoc _ vs rhs = TypeDoc desc` vs rhs
ConstructorDoc _ ps = ConstructorDoc desc` ps
where
desc` = Just $ toString $ flatten $ intersperse ['\n'] desc
desc` = Just $ linesToString desc
parseDocBlock :: Documentation String
-> Either ParseError (Documentation, [ParseWarning])
......@@ -113,8 +141,6 @@ where
(concatWarnings upd (Result $ prepField desc) =<< parseFields org rest)
parseFields org [['@':'v':'a':'r':desc]:rest]
= concatWarnings upd (Var $ prepField desc) =<< parseFields org rest
parseFields org [['@':'f':'i':'e':'l':'d':desc]:rest]
= concatWarnings upd (Field $ prepField desc) =<< parseFields org rest
parseFields org [['@':'r':'e':'p':'r':'e':'s':'e':'n':'t':'a':'t':'i':'o':'n':desc]:rest]
= concatWarnings upd (Representation $ prepField desc) =<< parseFields org rest
parseFields org [['@':line]:rest]
......@@ -131,8 +157,6 @@ where
upd (Param d) (ConstructorDoc t ps) = Right (ConstructorDoc t [d:ps], [])
upd (Var d) (ClassDoc t vs ms) = Right (ClassDoc t [d:vs] ms, [])
upd (Var d) (TypeDoc t vs rhs) = Right (TypeDoc t [d:vs] rhs, [])
upd (Field d) (TypeDoc t vs (Just (RecordDoc fs)))
= Right (TypeDoc t vs $ Just $ RecordDoc [d:fs], [])
upd (Representation d) (TypeDoc t vs (Just (SynonymDoc _)))
= Right (TypeDoc t vs $ Just $ SynonymDoc $ Just d, [])
upd f doc = Right (doc, [IllegalField $ fieldName f])
......@@ -144,28 +168,32 @@ where
-> Either ParseError (Documentation, [ParseWarning])
concatWarnings f df (doc, ws) = appSnd ((++) ws) <$> f df doc
prepareString :: String -> Either ParseError [[Char]]
prepareString s
= filter (not o isEmpty) <$>
( checkAsterisks
$ filter (not o isEmpty)
$ map (twice (reverse o trim))
$ break '\n'
$ fromString s
)
prepareString :: String -> Either ParseError [[Char]]
prepareString s
= filter (not o isEmpty) <$>
( checkAsterisks
$ filter (not o isEmpty)
$ map (twice (reverse o trim))
$ break '\n'
$ fromString s
)
where
checkAsterisks :: [[Char]] -> Either ParseError [[Char]]
checkAsterisks lines
| all ((==) '*' o hd) lines
= Right $ map (trim o tl) lines
= Left $ MissingAsterisk $ toString $ hd $ filter ((<>) '*' o hd) lines
break :: a -> [a] -> [[a]] | == a
break e = foldr f []
where
checkAsterisks :: [[Char]] -> Either ParseError [[Char]]
checkAsterisks lines
| all ((==) '*' o hd) lines = Right $ map (trim o tl) lines
| otherwise = Left MissingAsterisk
f x [] = if (x == e) [] [[x]]
f x [y:ys] = if (x == e) [[]:y:ys] [[x:y]:ys]
break :: a -> [a] -> [[a]] | == a
break e = foldr f []
where
f x [] = if (x == e) [] [[x]]
f x [y:ys] = if (x == e) [[]:y:ys] [[x:y]:ys]
linesToString :: ([[Char]] -> String)
linesToString = toString o flatten o intersperse ['\n']
trim = dropWhile isSpace
trim :== dropWhile isSpace
instance toString ParseWarning
where
......@@ -177,8 +205,8 @@ where
instance toString ParseError
where
toString MissingAsterisk = "Doc error: missing leading asterisk"
toString (IllegalState s) = "Doc error: illegal state: " +++ s
toString (MissingAsterisk l) = "Doc error: missing leading asterisk in '" +++ l +++ "'"
toString (IllegalState s) = "Doc error: illegal state: " +++ s
traceParseWarnings :: [ParseWarning] !a -> a
traceParseWarnings [] x = x
......
......@@ -47,7 +47,6 @@ The following documentation fields are recognised:
- `@result` for function, macro and generic results.
- `@return` is a deprecated synonym of `@result`.
- `@var` for type, class and generic type variables.
- `@field` for record fields.
- `@representation` for the representation of a synonym type.
For short documentation items, doclines, starting with `//*` can be used. When
......
......@@ -46,7 +46,7 @@ search {unify,name,className,typeName,modules,libraries,page,include_builtins,in
# typeName = fromJust typeName
# types = findType typeName db
= [makeTypeResult (Just typeName) l td db \\ (l,td) <- types]
# mbPreppedType = prepare_unification True (allTypes db_org)
# mbPreppedType = prepare_unification True (map getTypeDef $ allTypes db_org)
<$> (unify >>= parseType o fromString)
# usedSynonyms = 'Foldable'.concat (fst <$> mbPreppedType)
# mbType = snd <$> mbPreppedType
......@@ -155,8 +155,8 @@ where
print_fun f=:(_,ET _ et) = fromJust $
et.te_representation <|> (pure $ concat $ print False f)
makeTypeResult :: (Maybe String) Location TypeDef TypeDB -> Result
makeTypeResult mbName (Location lib mod line iclline t) td db
makeTypeResult :: (Maybe String) Location ExtendedTypeDef TypeDB -> Result
makeTypeResult mbName (Location lib mod line iclline t) etd db
= TypeResult
( { library = lib
, filename = modToFilename mod
......@@ -166,15 +166,18 @@ makeTypeResult mbName (Location lib mod line iclline t) td db
, distance
= if (isNothing mbName) -100 (levenshtein` t (fromJust mbName))
, builtin = Nothing
, documentation = Nothing
, documentation = getDocDescription =<< etd.etd_doc
}
, { type = concat $ print False td
, type_instances = map (appSnd3 (map snd)) $
, { type = concat $ print False etd.etd_typedef
, type_instances = map (appSnd3 (map snd)) $
map (appThd3 (map loc)) $ getTypeInstances t db
, type_derivations = map (appSnd (map loc)) $ getTypeDerivations t db
, type_derivations = map (appSnd (map loc)) $ getTypeDerivations t db
, type_field_doc = getFieldDoc =<< etd.etd_doc
, type_constructor_doc = map ((=<<) getDocDescription) <$> (getConstructorDoc =<< etd.etd_doc)
, type_representation_doc = getRepresentationDoc =<< etd.etd_doc
}
)
makeTypeResult mbName (Builtin t) td db
makeTypeResult mbName (Builtin t) etd db
= TypeResult
( { library = ""
, filename = ""
......@@ -184,12 +187,15 @@ makeTypeResult mbName (Builtin t) td db
, distance
= if (isNothing mbName) -100 (levenshtein` t (fromJust mbName))
, builtin = Just True
, documentation = Nothing
, documentation = getDocDescription =<< etd.etd_doc
}
, { type = concat $ print False td
, type_instances = map (appSnd3 (map snd)) $
, { type = concat $ print False etd.etd_typedef
, type_instances = map (appSnd3 (map snd)) $
map (appThd3 (map loc)) $ getTypeInstances t db
, type_derivations = map (appSnd (map loc)) $ getTypeDerivations t db
, type_derivations = map (appSnd (map loc)) $ getTypeDerivations t db
, type_field_doc = getFieldDoc =<< etd.etd_doc
, type_constructor_doc = map ((=<<) getDocDescription) <$> (getConstructorDoc =<< etd.etd_doc)
, type_representation_doc = getRepresentationDoc =<< etd.etd_doc
}
)
......@@ -297,7 +303,7 @@ where
typeComplexity (Uniq t) = 3.0 + typeComplexity t
prepare_unification` :: !Bool !TypeDB -> Type -> ([TypeDef], Type)
prepare_unification` b db = prepare_unification b (allTypes db)
prepare_unification` b db = prepare_unification b $ map getTypeDef $ allTypes db
levenshtein` :: String String -> Int
levenshtein` a b = if (indexOf a b == -1) 0 -100 +
......
......@@ -28,6 +28,11 @@ from Doc import ::Documentation
:: ExtendedType = ET Type TypeExtras
:: ExtendedTypeDef
= { etd_typedef :: TypeDef
, etd_doc :: Maybe Documentation
}
:: Macro = { macro_as_string :: String
, macro_extras :: TypeExtras
}
......@@ -56,6 +61,10 @@ getName :: Location -> Name
isBuiltin :: Location -> Bool
isCore :: Location TypeDB -> Bool
toExtendedTypeDef :: TypeDef (Maybe Documentation) -> ExtendedTypeDef
getTypeDef :: ExtendedTypeDef -> TypeDef
getTypeDefDoc :: ExtendedTypeDef -> Maybe Documentation
functionCount :: TypeDB -> Int
macroCount :: TypeDB -> Int
classCount :: TypeDB -> Int
......@@ -99,13 +108,13 @@ findClassMembers` :: (Location [TypeVar] ClassContext Name ExtendedType -> Bool)
findClassMembers`` :: [Location [TypeVar] ClassContext Name ExtendedType -> Bool]
TypeDB -> [(Location, [TypeVar], ClassContext, Name, ExtendedType)]
getType :: Location TypeDB -> Maybe TypeDef
putType :: Location TypeDef TypeDB -> TypeDB
putTypes :: [(Location, TypeDef)] TypeDB -> TypeDB
findType :: Name TypeDB -> [(Location, TypeDef)]
findType` :: (Location TypeDef -> Bool) TypeDB -> [(Location, TypeDef)]
findType`` :: [(Location TypeDef -> Bool)] TypeDB -> [(Location, TypeDef)]
allTypes :: (TypeDB -> [TypeDef])
getType :: Location TypeDB -> Maybe ExtendedTypeDef
putType :: Location ExtendedTypeDef TypeDB -> TypeDB
putTypes :: [(Location, ExtendedTypeDef)] TypeDB -> TypeDB
findType :: Name TypeDB -> [(Location, ExtendedTypeDef)]
findType` :: (Location ExtendedTypeDef -> Bool) TypeDB -> [(Location, ExtendedTypeDef)]
findType`` :: [(Location ExtendedTypeDef -> Bool)] TypeDB -> [(Location, ExtendedTypeDef)]
allTypes :: (TypeDB -> [ExtendedTypeDef])
getDerivations :: Name TypeDB -> [(Type, String, [Location])]
putDerivation :: Name Type String Location TypeDB -> TypeDB
......
......@@ -27,7 +27,7 @@ import Doc
, macromap :: Map Location Macro
, classmap :: Map Location ([TypeVar],ClassContext,[(Name, ExtendedType)])
, instancemap :: Map Class [([(Type,String)], [Location])]
, typemap :: Map Location TypeDef
, typemap :: Map Location ExtendedTypeDef
, derivemap :: Map Name [(Type, String, [Location])]
, modulemap :: Map (Library, Module) ModuleInfo
// Derived maps
......@@ -46,10 +46,12 @@ derive gEq ClassOrGeneric, Location, Type, TypeExtras, Priority,
Documentation, TypeRhsDoc, ClassMemberDoc
derive JSONEncode ClassOrGeneric, Location, Type, TypeDB, TypeExtras,
Priority, ExtendedType, TypeDef, TypeDefRhs, RecordField, Constructor,
Kind, Macro, ModuleInfo, Documentation, TypeRhsDoc, ClassMemberDoc
Kind, Macro, ModuleInfo, Documentation, TypeRhsDoc, ClassMemberDoc,
ExtendedTypeDef
derive JSONDecode ClassOrGeneric, Location, Type, TypeDB, TypeExtras,
Priority, ExtendedType, TypeDef, TypeDefRhs, RecordField, Constructor,
Kind, Macro, ModuleInfo, Documentation, TypeRhsDoc, ClassMemberDoc
Kind, Macro, ModuleInfo, Documentation, TypeRhsDoc, ClassMemberDoc,
ExtendedTypeDef
instance zero TypeDB
where
......@@ -119,6 +121,15 @@ isCore (Location lib mod _ _ _) db = case getModule lib mod db of
Nothing = False
(Just b) = b.is_core
toExtendedTypeDef :: TypeDef (Maybe Documentation) -> ExtendedTypeDef
toExtendedTypeDef td doc = {etd_typedef=td, etd_doc=doc}
getTypeDef :: ExtendedTypeDef -> TypeDef
getTypeDef {etd_typedef} = etd_typedef
getTypeDefDoc :: ExtendedTypeDef -> Maybe Documentation
getTypeDefDoc {etd_doc} = etd_doc
functionCount :: TypeDB -> Int
functionCount {functionmap} = mapSize functionmap
......@@ -261,27 +272,28 @@ findClassMembers`` fs {classmap} = foldr (filter o app5) all_members fs
where
all_members = [(cl,vs,cc,f,t) \\ (cl,(vs,cc,fs)) <- toList classmap, (f,t) <- fs]
getType :: Location TypeDB -> Maybe TypeDef
getType :: Location TypeDB -> Maybe ExtendedTypeDef
getType loc {typemap} = get loc typemap
putType :: Location TypeDef TypeDB -> TypeDB
putType :: Location ExtendedTypeDef TypeDB -> TypeDB
putType tl td db=:{typemap} = {db & typemap = put tl td typemap}
putTypes :: [(Location, TypeDef)] TypeDB -> TypeDB
putTypes :: [(Location, ExtendedTypeDef)] TypeDB -> TypeDB
putTypes ts db = foldr (\(loc,td) -> putType loc td) db ts
findType :: Name TypeDB -> [(Location, TypeDef)]
findType :: Name TypeDB -> [(Location, ExtendedTypeDef)]
findType t db=:{typemap}
= toList $ filterWithKey (\tl _ -> getName tl == t) typemap
findType` :: (Location TypeDef -> Bool) TypeDB
-> [(Location, TypeDef)]
findType` :: (Location ExtendedTypeDef -> Bool) TypeDB
-> [(Location, ExtendedTypeDef)]
findType` f {typemap} = toList $ filterWithKey f typemap
findType`` :: [(Location TypeDef -> Bool)] TypeDB -> [(Location, TypeDef)]
findType`` :: [(Location ExtendedTypeDef -> Bool)] TypeDB
-> [(Location, ExtendedTypeDef)]
findType`` fs {typemap} = toList $ foldr filterWithKey typemap fs
allTypes :: (TypeDB -> [TypeDef])
allTypes :: (TypeDB -> [ExtendedTypeDef])
allTypes = map snd o findType` (\_ _ -> True)
getDerivations :: Name TypeDB -> [(Type, String, [Location])]
......
......@@ -8,5 +8,5 @@ findModules :: ![String] !String !Library (Module -> Bool) !String !*World
-> *(![(Library, Module, Bool)], !*World)
getModuleTypes :: String Module Library Bool TypeDB *World -> *(TypeDB, *World)
constructor_functions :: (Location, TypeDef) -> [(Location, ExtendedType)]
record_functions :: (Location, TypeDef) -> [(Location, ExtendedType)]
constructor_functions :: (Location, ExtendedTypeDef) -> [(Location, ExtendedType)]
record_functions :: (Location, ExtendedTypeDef) -> [(Location, ExtendedType)]
......@@ -3,7 +3,7 @@ implementation module TypeDBFactory
import StdArray
import StdBool
import StdFile
from StdFunc import flip, id, o
from StdFunc import const, flip, id, o
import StdList
import StdMisc
import StdString
......@@ -38,9 +38,12 @@ from syntax import :: ClassDef{class_args,class_context,class_ident,class_pos},
:: ParsedDefinition(PD_Class,PD_Derive,PD_Function,PD_Generic,PD_Instance,PD_Instances,PD_Type,PD_TypeSpec),
:: ParsedExpr, :: ParsedInstance{pi_ident,pi_pos,pi_types},
:: ParsedInstanceAndMembers{pim_pi}, :: ParsedModule, :: ParsedTypeDef,
:: Position(FunPos,LinePos,NoPos), :: Priority, :: Rhs, :: RhsDefsOfType,
:: SymbolTable, :: SymbolTableEntry, :: SymbolType, :: Type,
:: TypeContext, :: TypeDef{td_ident,td_pos}, :: TypeVar, :: OptionalDoc
:: Position(FunPos,LinePos,NoPos), :: Priority, :: Rhs, :: ATypeVar,
:: RhsDefsOfType(ConsList,ExtensibleConses,SelectorList,TypeSpec,EmptyRhs),
:: SymbolTable, :: SymbolTableEntry, :: SymbolType, :: Type, :: BITVECT,
:: TypeContext, :: TypeDef{td_ident,td_pos,td_rhs}, :: TypeVar,
:: ParsedConstructor{pc_doc}, :: ParsedSelector{ps_doc},
:: OptionalDoc
import CoclUtils
import qualified Type as T
......@@ -51,8 +54,12 @@ from TypeDB import :: Macro{macro_as_string,macro_extras},
:: Location(Location), filterLocations, :: ModuleInfo{is_core},
:: TypeExtras{te_generic_vars,te_isconstructor,te_isrecordfield,te_priority,te_representation,te_documentation},
instance zero TypeExtras, instance zero ModuleInfo
from Doc import :: Documentation, :: ParseWarning(UsedReturn), :: ParseError,
parseFunctionDoc, traceParseError, traceParseWarnings
from Doc import :: Documentation(FunctionDoc), :: ResultDoc, :: VarDoc,
:: ParamDoc, :: Description, :: TypeRhsDoc(RecordDoc), :: RecordFieldDoc,
:: ParseWarning(UsedReturn), :: ParseError(IllegalState),
parseFunctionDoc, parseConstructorDoc, parseADTypeDoc, parseRecordTypeDoc,
parseSynonymTypeDoc, parseAbstractTypeDoc, parseFieldDoc,
traceParseError, traceParseWarnings, getTypeRhsDoc
// Exclude Root Library Check for core Base module
findModules :: ![String] !String !'DB'.Library ('DB'.Module -> Bool) !String !*World
......@@ -91,7 +98,7 @@ getModuleTypes root mod lib iscore db w
# db = 'DB'.putFunctions (pd_typespecs lib modname dcl.mod_defs icl symbols) db
# db = 'DB'.putInstances (pd_instances lib modname dcl.mod_defs icl) db
# db = 'DB'.putClasses (pd_classes lib modname dcl.mod_defs icl symbols) db
# typedefs = pd_types lib modname dcl.mod_defs icl
# typedefs = pd_types lib modname dcl.mod_defs icl symbols
# db = 'DB'.putTypes typedefs db
# db = 'DB'.putFunctions (flatten $ map constructor_functions typedefs) db
# db = 'DB'.putFunctions (flatten $ map record_functions typedefs) db
......@@ -221,12 +228,17 @@ where
[LinePos _ l:_] = Just l
_ = Nothing
pd_types :: String String [ParsedDefinition] (Maybe ParsedModule)
-> [('DB'.Location, 'DB'.TypeDef)]
pd_types lib mod dcl icl
pd_types :: String String [ParsedDefinition] (Maybe ParsedModule) SymbolTable
-> [('DB'.Location, 'DB'.ExtendedTypeDef)]
pd_types lib mod dcl icl st
= [let name = 'T'.td_name td in
('DB'.Location lib mod (toLine ptd.td_pos) (findIclLine name =<< icl) name, td)
\\ PD_Type ptd <- dcl, td <- ['T'.toTypeDef ptd]]
( 'DB'.Location lib mod (toLine ptd.td_pos) (findIclLine name =<< icl) name
, 'DB'.toExtendedTypeDef td $ findRhsDoc ptd =<<
(case findDoc (parsef ptd.td_rhs) ptd.td_ident st of
Just d -> Just d
Nothing -> docParseResultToMaybe $ parsef ptd.td_rhs ""
)
) \\ PD_Type ptd <- dcl, td <- ['T'.toTypeDef ptd]]
where
findIclLine :: String ParsedModule -> Maybe Int
findIclLine name {mod_defs=pms}
......@@ -234,6 +246,36 @@ where
[LinePos _ l:_] = Just l
_ = Nothing
parsef :: RhsDefsOfType -> String -> Either ParseError (Documentation, [ParseWarning])
parsef (ConsList _) = parseADTypeDoc
parsef (ExtensibleConses _) = parseADTypeDoc
parsef (SelectorList _ _ _ _) = parseRecordTypeDoc
parsef (TypeSpec _) = parseSynonymTypeDoc
parsef (EmptyRhs _) = parseAbstractTypeDoc
parsef _ = const $ Left $ IllegalState "Unknown RhsDefsOfType"
findRhsDoc :: ParsedTypeDef Documentation -> Maybe Documentation
findRhsDoc {td_rhs=ConsList cs} doc = addConses cs doc
findRhsDoc {td_rhs=ExtensibleConses cs} doc = addConses cs doc
findRhsDoc {td_rhs=SelectorList _ _ _ fs} doc = addFields fs doc
findRhsDoc _ doc = Just doc
addFields :: [ParsedSelector] Documentation -> Maybe Documentation
addFields [] doc
= Just doc
addFields [{ps_doc=Yes d}:fs] doc
= addFields fs doc >>= docParseResultToMaybe o parseFieldDoc d
addFields [_:fs] doc
= addFields fs doc
addConses :: [ParsedConstructor] Documentation -> Maybe Documentation
addConses [] doc
= Just doc
addConses [{pc_doc=Yes d}:cs] doc
= addConses cs doc >>= docParseResultToMaybe o parseConstructorDoc d
addConses [_:cs] doc
= addConses cs doc
toLine :: Position -> 'DB'.LineNr
toLine (FunPos _ l _) = Just l
toLine (LinePos _ l) = Just l
......@@ -258,45 +300,56 @@ where
# (b1,b2,pm,ht,f,fs) = wantModule f s b1 i p b2 ht io fs
= ((b1,b2,pm,ht,f),fs)
docParseResultToMaybe :: (Either ParseError (Documentation, [ParseWarning]))
-> Maybe Documentation
docParseResultToMaybe (Left e)
= traceParseError e Nothing
docParseResultToMaybe (Right (doc,ws))
= traceParseWarnings (filter (not o isUsedReturn) ws) (Just doc)
findDoc :: (String -> Either ParseError (Documentation, [ParseWarning]))
Ident SymbolTable -> Maybe Documentation
findDoc parse {id_info} st = case sreadPtr id_info st of
{ste_doc=Yes doc} = case parse doc of
(Right (doc,ws)) = traceParseWarnings (filter (not o isUsedReturn) ws) (Just doc)
(Left e) = traceParseError e Nothing
{ste_doc=Yes doc} = docParseResultToMaybe $ parse doc
_ = Nothing
where isUsedReturn UsedReturn = True; isUsedReturn _ = False
constructor_functions :: ('DB'.Location, 'DB'.TypeDef)
isUsedReturn :: ParseWarning -> Bool
isUsedReturn UsedReturn = True; isUsedReturn _ = False
constructor_functions :: ('DB'.Location, 'DB'.ExtendedTypeDef)
-> [('DB'.Location, 'DB'.ExtendedType)]
constructor_functions ('DB'.Builtin _, td)
= [('DB'.Builtin c, 'DB'.ET f
{zero & te_isconstructor=True
, te_representation=Just $ concat $
[c] ++ print_prio p ++ [" :: "] ++ print False f
, te_priority=p})
\\ (c,f,p) <- 'T'.constructorsToFunctions td]
constructor_functions ('DB'.Location lib mod line iclline _, td)
= [('DB'.Location lib mod line iclline c, 'DB'.ET f
{zero & te_isconstructor=True
, te_representation=Just $ concat $
[c] ++ print_prio p ++ [" :: "] ++ print False f
, te_priority=p})
\\ (c,f,p) <- 'T'.constructorsToFunctions td]
constructor_functions (loc, etd)
= [(loc` c, 'DB'.ET f
{ zero
& te_isconstructor=True
, te_representation=Just $ concat $ [c] ++ print_prio p ++ [" :: "] ++ print False f
, te_priority=p
})
\\ (c,f,p) <- 'T'.constructorsToFunctions ('DB'.getTypeDef etd)]
where
loc` c = case loc of
'DB'.Builtin _ -> 'DB'.Builtin c
'DB'.Location lib mod line iclline _ -> 'DB'.Location lib mod line iclline c
print_prio :: (Maybe 'T'.Priority) -> [String]
print_prio Nothing = []
print_prio (Just p) = [" "] ++ print False p
record_functions :: ('DB'.Location, 'DB'.TypeDef)
record_functions :: ('DB'.Location, 'DB'.ExtendedTypeDef)
-> [('DB'.Location, 'DB'.ExtendedType)]
record_functions ('DB'.Builtin _, td)
= [('DB'.Builtin f, 'DB'.ET t
{zero & te_isrecordfield=True
, te_representation=Just $ concat $ [".", f, " :: " : print False t]})
\\ (f,t) <- 'T'.recordsToFunctions td]
record_functions ('DB'.Location lib mod line iclline _, td)
= [('DB'.Location lib mod line iclline f, 'DB'.ET t
{zero & te_isrecordfield=True
, te_representation=Just $ concat $ [".", f, " :: " : print False t]})
\\ (f,t) <- 'T'.recordsToFunctions td]
record_functions (loc, etd)
= [(loc` f, 'DB'.ET t
{ zero
& te_isrecordfield<