Verified Commit 12d1a74a authored by Camil Staps's avatar Camil Staps 🙂

Avoid run-time errors

parent 94c4bb99
......@@ -74,6 +74,7 @@ where
// PD_Derive [GenericCaseDef]
// PD_Documentation DocType String
// PD_Erroneous
_ -> abort "idents of unknown ParsedDefinition\n"
instance idents ParsedExpr
where
......@@ -118,6 +119,7 @@ where
instance idents Rhs
where
idents ICExpression rhs = noLocals (idents ICExpression rhs.rhs_alts + idents ICPattern rhs.rhs_locals)
idents ICPattern _ = abort "idents Rhs must be called as ICExpression\n"
instance idents LocalDefs
where
......@@ -129,6 +131,7 @@ where
idents ICExpression alts = case alts of
UnGuardedExpr e -> idents ICExpression e
GuardedAlts es oth -> idents ICExpression es + idents ICExpression oth
idents ICPattern _ = abort "idents OptGuardedAlts must be called as ICExpression\n"
instance idents ExprWithLocalDefs
where
......@@ -136,6 +139,7 @@ where
idents ICExpression e.ewl_locals +
idents ICExpression e.ewl_expr +
idents ICExpression e.ewl_nodes
idents ICPattern _ = abort "idents ExprWithLocalDefs must be called as ICExpression\n"
instance idents NodeDefWithLocals
where
......@@ -148,10 +152,12 @@ where
idents ICExpression e.alt_guard +
idents ICExpression e.alt_expr +
idents ICPattern e.alt_nodes
idents ICPattern _ = abort "idents GuardedExpr must be called as ICExpression\n"
instance idents CaseAlt
where
idents ICExpression a = noLocals (idents ICPattern a.calt_pattern + idents ICExpression a.calt_rhs)
idents ICPattern _ = abort "idents CaseAlt must be called as ICExpression\n"
instance idents Qualifier
where
......@@ -159,6 +165,7 @@ where
idents ICPattern q.qual_generators +
idents ICPattern q.qual_let_defs +
idents ICExpression q.qual_filter
idents ICExpression _ = abort "idents Qualifier must be called as ICPattern\n"
instance idents FieldNameOrQualifiedFieldName
where
......@@ -168,6 +175,7 @@ where
instance idents Generator
where
idents ICPattern g = idents ICPattern g.gen_pattern + idents ICExpression g.gen_expr
idents ICExpression _ = abort "idents Generator must be called as ICPattern\n"
instance idents Sequence
where
......@@ -176,6 +184,7 @@ where
SQ_FromThenTo _ a b c -> idents ICExpression [a,b]
SQ_From _ a -> idents ICExpression a
SQ_FromTo _ a b -> idents ICExpression [a,b]
idents ICPattern _ = abort "idents Sequence must be called as ICExpression\n"
instance idents ParsedSelection
where
......
Subproject commit 38ddb57139493f82fbb31eaedf1b5eeaea002eb9
Subproject commit 526028f7fc2d5a10db66d65ef911466fd888cab8
......@@ -172,10 +172,12 @@ getIclLine _ = Nothing
getName :: !Location -> Name
getName (Location _ _ _ _ _ name) = name
getName (Builtin name _) = name
getName NoLocation = abort "getName NoLocation called\n"
setName :: !Name !Location -> Location
setName n (Location lib mod fname dcl icl _) = Location lib mod fname dcl icl n
setName n (Builtin _ doc) = Builtin n doc
setName _ NoLocation = abort "setName NoLocation called\n"
isBuiltin :: !Location -> Bool
isBuiltin (Builtin _ _) = True
......@@ -468,7 +470,7 @@ where
// Efficient union on sorted lists
mergeUnion :: !['Database.Native'.Index] !['Database.Native'.Index] -> ['Database.Native'.Index]
mergeUnion [] is = is
mergeUnion is [] = is
mergeUnion is=:[_:_] [] = is
mergeUnion orgis=:[i:is] orgjs=:[j:js]
| i < j = [i:mergeUnion is orgjs]
| i > j = [j:mergeUnion orgis js]
......@@ -476,7 +478,7 @@ where
mergeUnionWithAnnots :: ![('Database.Native'.Index,a)] ![('Database.Native'.Index,a)] -> [('Database.Native'.Index,a)]
mergeUnionWithAnnots [] is = is
mergeUnionWithAnnots is [] = is
mergeUnionWithAnnots is=:[_:_] [] = is
mergeUnionWithAnnots orgis=:[a=:(i,_):is] orgjs=:[b=:(j,_):js]
| i < j = [a:mergeUnionWithAnnots is orgjs]
| i > j = [b:mergeUnionWithAnnots orgis js]
......@@ -485,7 +487,7 @@ where
// Efficient intersection on sorted lists
mergeIntersect :: !['Database.Native'.Index] !['Database.Native'.Index] -> ['Database.Native'.Index]
mergeIntersect [] is = []
mergeIntersect is [] = []
mergeIntersect is=:[_:_] [] = []
mergeIntersect orgis=:['Database.Native'.Index i:is] orgjs=:['Database.Native'.Index j:js]
| i < j = mergeIntersect is orgjs
| i > j = mergeIntersect orgis js
......@@ -495,12 +497,15 @@ allTypeSynonyms :: !*CloogleDB -> *(Map Name [TypeDef], *CloogleDB)
allTypeSynonyms wrap=:{db}
# (es,db) = 'Database.Native'.allEntries db
= (fromList
$ map (\syns=:[(t,_):_] -> (t,map snd syns))
$ map collect
$ groupBy ((==) `on` fst)
$ sortBy ((<) `on` fst)
[(td.td_name, td) \\ TypeDefEntry {tde_typedef=td=:{td_rhs=TDRSynonym t}} <- es]
, {wrap & db=db}
)
where
collect syns=:[(t,_):_] = (t,[s \\ (_,s) <- syns])
collect [] = abort "internal error in allTypeSynonyms\n"
alwaysUniquePredicate :: !*CloogleDB -> *(String -> Bool, *CloogleDB)
alwaysUniquePredicate wrap=:{always_unique} = (isJust o flip get always_unique, wrap)
......@@ -551,6 +556,8 @@ where
where (match,nomatch) = partition (\a->a=:MatchingNGramsResult _) m
updateAnnots [a=:Unifier _:as] m = updateAnnots as [a:[a \\ a <- m | not (a=:Unifier _)]]
updateAnnots [a=:ExactResult:as] m = updateAnnots as [a:[a \\ a <- m | not a=:ExactResult]]
updateAnnots [a=:UsedSynonyms _:as] m = updateAnnots as [a:[a \\ a <- m | not (a=:UsedSynonyms _)]]
updateAnnots [a=:RequiredContext _:as] m = updateAnnots as [a:[a \\ a <- m | not (a=:RequiredContext _)]]
getEntries :: !*CloogleDB -> *([(CloogleEntry, [Annotation])], *CloogleDB)
getEntries wrap=:{db}
......
......@@ -180,16 +180,19 @@ finaliseDB extra tdb =
, library_map = libmap
, module_map = modmap
, derive_map = 'Data.Map'.fromList
$ map (\ds=:[(g,_):_] -> (g,{i \\ (_,i) <- ds}))
$ map collect_snds
$ groupBy ((==) `on` fst) $ sort
[(de.de_generic, i) \\ (i,DeriveEntry de) <- entridxs]
, instance_map = 'Data.Map'.fromList
$ map (\is=:[(c,_):_] -> (c,{i \\ (_,i) <- is}))
$ map collect_snds
$ groupBy ((==) `on` fst) $ sort
[(ie.ie_class, i) \\ (i,InstanceEntry ie) <- entridxs]
, always_unique = always_unique
}
where
collect_snds xys=:[(x,_):_] = (x,{#y \\ (_,y) <- xys})
collect_snds [] = abort "collect_snds requires at least one element\n"
link :: !Int !CloogleEntry -> CloogleEntry
link i e = case e of
TypeDefEntry tde -> TypeDefEntry
......@@ -204,7 +207,7 @@ where
DeriveEntry {de_type='Clean.Types'.Arrow _} -> name == "(->)"
DeriveEntry {de_type='Clean.Types'.Func _ _ _} -> name == "(->)"
_ -> False
, tde_usages={u \\ u <- fromMaybe [] ('Data.Map'.get name type_usages_map)}
, tde_usages=fromMaybe {} ('Data.Map'.get name type_usages_map)
}
with name = 'Clean.Types'.td_name $ 'Cloogle.DB'.getTypeDef tde
ClassEntry ce -> ClassEntry
......@@ -215,7 +218,7 @@ where
, ce_members=idxarr \e -> case e of
FunctionEntry fe -> fe.fe_class == Just (Index i)
_ -> False
, ce_usages={u \\ u <- fromMaybe [] ('Data.Map'.get name class_usages_map)}
, ce_usages=fromMaybe {} ('Data.Map'.get name class_usages_map)
}
with name = 'Cloogle.DB'.getName ce.ce_loc
FunctionEntry fe -> FunctionEntry
......@@ -225,19 +228,19 @@ where
Just _ -> Just $ idxarr \e -> case e of
DeriveEntry de -> de.de_generic == name
_ -> False
, fe_usages={u \\ u <- fromMaybe [] ('Data.Map'.get name function_usages_map)}
, fe_usages=fromMaybe {} ('Data.Map'.get name function_usages_map)
}
with name = 'Cloogle.DB'.getName fe.fe_loc
ModuleEntry me -> ModuleEntry
{ me
& me_usages={u \\ u <- fromMaybe [] ('Data.Map'.get name module_usages_map)}
& me_usages=fromMaybe {} ('Data.Map'.get name module_usages_map)
}
with name = 'Cloogle.DB'.getName me.me_loc
e -> e
make_usage_map :: ([[(a,b)]] -> 'Data.Map'.Map a [b]) | <, == a
make_usage_map :: ([[(a,Index)]] -> 'Data.Map'.Map a {#Index}) | <, == a
make_usage_map = 'Data.Map'.fromList
o map (\gidxs=:[(g,_):_] -> (g,map snd gidxs))
o map collect_snds
o groupBy ((==) `on` fst)
o sortBy ((<) `on` fst)
o flatten
......@@ -266,7 +269,10 @@ where
function_entries = flatten tdb.temp_functions ++
[({ fun
& fe_kind=case fun.fe_kind of Function -> ClassMember; Macro -> ClassMacro
& fe_kind=case fun.fe_kind of
Function -> ClassMember
Macro -> ClassMacro
_ -> abort "error while transforming class members to function entries\n"
, fe_loc='Cloogle.DB'.setName fname cls.ce_loc
, fe_class=Just $ idxhd \ce -> case ce of
ClassEntry ce -> ce.ce_loc == cls.ce_loc
......@@ -327,8 +333,7 @@ where
classes = sortBy contextOrd [cls \\ clss <- tdb.temp_classes, (cls,_) <- clss]
where
contextOrd :: ClassEntry ClassEntry -> Bool
contextOrd a b = isMember aname [c \\ 'Clean.Types'.Instance c _ <- classContext b]
where [aname,bname:_] = map 'Cloogle.DB'.getName [a.ce_loc,b.ce_loc]
contextOrd a b = isMember ('Cloogle.DB'.getName a.ce_loc) [c \\ 'Clean.Types'.Instance c _ <- classContext b]
instanceEq :: (String, [('Cloogle.DB'.Type, a)], b) (String, [('Cloogle.DB'.Type, a)], b) -> Bool
instanceEq (s, ts, _) (s2, ts2, _) = s == s2 && all (uncurry (isomorphic_to)) (zip2 (map fst ts) (map fst ts2))
......@@ -365,7 +370,7 @@ where
where mods = removeDup [fromJust ('Cloogle.DB'.getModule me.me_loc) \\ (me,_) <- tdb.temp_modules]
synonymmap = 'Data.Map'.fromList
$ map (\syns=:[(t,_):_] -> (t,map snd syns))
$ map (appSnd (\is->[i\\i<-:is]) o collect_snds)
$ groupBy ((==) `on` fst)
$ sortBy ((<) `on` fst)
[let td = 'Cloogle.DB'.getTypeDef tde in ('Clean.Types'.td_name td, td)
......@@ -594,7 +599,9 @@ where
signature _ (Just pd) (Just t) = cpp pd <+ " :: " <+ t <+ "\n"
findPrio :: Ident -> Maybe Priority
findPrio id = (\(PD_TypeSpec _ _ p _ _) -> p) <$> findTypeSpec id defs
findPrio id = (\pd -> case pd of
PD_TypeSpec _ _ p _ _ -> p
_ -> abort "error in findPrio\n") <$> findTypeSpec id defs
findTypeSpec :: Ident [ParsedDefinition] -> Maybe ParsedDefinition
findTypeSpec _ [] = Nothing
......@@ -690,6 +697,7 @@ where
| otherwise = flip (foldl addClassMemberDoc)
[functionToClassMemberDoc <$> fe.fe_documentation \\ (_,fe,_) <- members]
<$> findDoc hideIsUsedReturn pd comments
parseClassDoc _ _ _ = abort "parseClassDoc called with non-PD_Class\n"
isSingleFunction :: [(LocationInModule, 'Cloogle.DB'.FunctionEntry, a)] Ident -> Bool
isSingleFunction members id = length members == 1
......
This diff is collapsed.
......@@ -174,6 +174,7 @@ where
"rs_resolved_context" -> {rs & rs_resolved_context =val}
"rs_unresolved_context" -> {rs & rs_unresolved_context=val}
"rs_lib_stdenv" -> {rs & rs_lib_stdenv =val}
_ -> abort ("unknown setting " +++ name +++ "\n")
= findSettings ss rs
findSettings [s:ss] rs = findSettings ss rs
findSettings [] rs = rs
......@@ -252,4 +253,5 @@ where
sum [t:ts]
# s = sum ts
= "+ (" +++ t +++ ") (" +++ s +++ ")"
sum [] = abort "error in findConstraints\n"
findConstraints [] _ cdb = ([],cdb)
Subproject commit 2dacc462b44da3a54599fcf4622bc287cb85c640
Subproject commit 9b3230c26b83eb59d2d6e26930803b5aa198e79b
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment