...
 
Commits (5)
......@@ -6,6 +6,10 @@ Version 2.0.0
* Implemented the "MonadFail-Proposal" for curry
(see <https://wiki.haskell.org/MonadFail_Proposal>)
* Data class (see <https://arxiv.org/abs/1908.10607>)
* Fixed bug with partially imported Typeclasses
* Fixed bug with parsing of empty blocks
* Fixed bug with re-export of record labels
Version 1.0.4
=============
......
/* Use always white background */
:root {
--link-bg-color: lightyellow;
--line-number-color: grey;
--pragma-color: green;
--comment-color: green;
--keyword-color: blue;
--symbol-color: red;
--type-color: orange;
--cons-color: magenta;
--label-color: darkgreen;
--func-color: purple;
--ident-color: black;
--module-color: brown;
--number-color: teal;
--string-color: maroon;
--char-color: maroon;
color-scheme: light dark;
}
body {
background : white;
color : black;
font-family: monospace;
text-size-adjust: none;
-moz-text-size-adjust: none;
-ms-text-size-adjust: none;
-webkit-text-size-adjust: none;
}
table {
border-collapse: collapse;
}
/* Show hyperlinks without text decoration, but in light yellow */
a:visited, a:link, a:active {
/* Hyperlinks */
a:link,
a:visited,
a:active {
background: var(--link-bg-color);
text-decoration: none;
background : lightyellow;
}
/* Line numbers */
.linenumbers {
width : 40px;
text-align : right;
color : grey;
padding-right: 10px;
border-right : 1px solid grey;
.line-numbers {
border-right: 1px solid var(--line-number-color);
color: var(--line-number-color);
min-width: 5ch;
padding-right: 1em;
text-align: right;
}
/* Source code */
.sourcecode {
padding-left: 10px;
.source-code {
padding-left: 1em;
}
/* Code highlighting */
.pragma { color : green }
.comment { color : green }
.keyword { color : blue }
.symbol { color : red }
.type { color : orange }
.cons { color : magenta }
.label { color : darkgreen }
.func { color : purple }
.ident { color : black }
.module { color : brown }
.number { color : teal }
.string { color : maroon }
.char { color : maroon }
.pragma { color: var(--pragma-color) }
.comment { color: var(--comment-color) }
.keyword { color: var(--keyword-color) }
.symbol { color: var(--symbol-color) }
.type { color: var(--type-color) }
.cons { color: var(--cons-color) }
.label { color: var(--label-color) }
.func { color: var(--func-color) }
.ident { color: var(--ident-color) }
.module { color: var(--module-color) }
.number { color: var(--number-color) }
.string { color: var(--string-color) }
.char { color: var(--char-color) }
@supports not (color-scheme: light dark) {
@media (prefers-color-scheme: dark) {
html {
background: hsl(0, 0%, 12%);
color: white;
}
}
}
@media (prefers-color-scheme: dark) {
:root {
--link-bg-color: hsl(0, 0%, 17%);
--pragma-color: hsl(0, 0%, 60%);
--comment-color: hsl(0, 0%, 60%);
--keyword-color: hsl(300, 66%, 70%);
--symbol-color: hsl(0, 66%, 70%);
--type-color: hsl(60, 66%, 70%);
--cons-color: hsl(330, 66%, 70%);
--label-color: hsl(240, 66%, 70%);
--func-color: hsl(200, 66%, 70%);
--ident-color: hsl(0, 0%, 85%);
--module-color: hsl(20, 66%, 70%);
--number-color: hsl(180, 66%, 70%);
--string-color: hsl(120, 66%, 70%);
--char-color: hsl(120, 66%, 70%);
}
}
......@@ -70,6 +70,7 @@ import CompilerOpts
-- - overlapping case alternatives
-- - non-adjacent function rules
-- - wrong case mode
-- - redundant context
warnCheck :: WarnOpts -> CaseMode -> AliasEnv -> ValueEnv -> TCEnv -> ClassEnv
-> Module a -> [Message]
warnCheck wOpts cOpts aEnv valEnv tcEnv clsEnv mdl
......@@ -80,6 +81,7 @@ warnCheck wOpts cOpts aEnv valEnv tcEnv clsEnv mdl
checkMissingTypeSignatures ds
checkModuleAlias is
checkCaseMode ds
checkRedContext ds
where Module _ _ _ mid es is ds = fmap (const ()) mdl
type ScopeEnv = NestEnv IdInfo
......@@ -1471,6 +1473,129 @@ isDataDeclName CaseModeGoedel (x:_) | isAlpha x = isUpper x
isDataDeclName CaseModeHaskell (x:_) | isAlpha x = isUpper x
isDataDeclName _ _ = True
-- ---------------------------------------------------------------------------
-- Warn for redundant context
-- ---------------------------------------------------------------------------
--traverse the AST for QualTypeExpr/Context and check for redundancy
checkRedContext :: [Decl a] -> WCM ()
checkRedContext = warnFor WarnRedundantContext . mapM_ checkRedContextDecl
getRedPredSet :: ModuleIdent -> ClassEnv -> TCEnv -> PredSet -> PredSet
getRedPredSet m cenv tcEnv ps =
Set.map (pm Map.!) $ Set.difference qps $ minPredSet cenv qps --or fromJust $ Map.lookup
where (qps, pm) = Set.foldr qualifyAndAddPred (Set.empty, Map.empty) ps
qualifyAndAddPred p@(Pred qid ty) (ps', pm') =
let qp = Pred (getOrigName m qid tcEnv) ty
in (Set.insert qp ps', Map.insert qp p pm')
getPredFromContext :: Context -> ([Ident], PredSet)
getPredFromContext cx =
let vs = concatMap (\(Constraint _ _ ty) -> typeVariables ty) cx
in (vs, toPredSet vs cx)
checkRedContext' :: (Pred -> Message) -> PredSet -> WCM ()
checkRedContext' f ps = do
m <- gets moduleId
cenv <- gets classEnv
tcEnv <- gets tyConsEnv
mapM_ (report . f) (getRedPredSet m cenv tcEnv ps)
checkRedContextDecl :: Decl a -> WCM ()
checkRedContextDecl (TypeSig _ ids (QualTypeExpr _ cx _)) =
checkRedContext' (warnRedContext (warnRedFuncString ids) vs) ps
where (vs, ps) = getPredFromContext cx
checkRedContextDecl (FunctionDecl _ _ _ eqs) = mapM_ checkRedContextEq eqs
checkRedContextDecl (PatternDecl _ _ rhs) = checkRedContextRhs rhs
checkRedContextDecl (ClassDecl _ _ cx i _ ds) = do
checkRedContext'
(warnRedContext (text ("class declaration " ++ escName i)) vs)
ps
mapM_ checkRedContextDecl ds
where (vs, ps) = getPredFromContext cx
checkRedContextDecl (InstanceDecl _ _ cx qid _ ds) = do
checkRedContext'
(warnRedContext (text ("instance declaration " ++ escQualName qid)) vs)
ps
mapM_ checkRedContextDecl ds
where (vs, ps) = getPredFromContext cx
checkRedContextDecl _ = return ()
checkRedContextEq :: Equation a -> WCM ()
checkRedContextEq (Equation _ _ rhs) = checkRedContextRhs rhs
checkRedContextRhs :: Rhs a -> WCM ()
checkRedContextRhs (SimpleRhs _ _ e ds) = do
checkRedContextExpr e
mapM_ checkRedContextDecl ds
checkRedContextRhs (GuardedRhs _ _ cs ds) = do
mapM_ checkRedContextCond cs
mapM_ checkRedContextDecl ds
checkRedContextCond :: CondExpr a -> WCM ()
checkRedContextCond (CondExpr _ e1 e2) = do
checkRedContextExpr e1
checkRedContextExpr e2
checkRedContextExpr :: Expression a -> WCM ()
checkRedContextExpr (Paren _ e) = checkRedContextExpr e
checkRedContextExpr (Typed _ e (QualTypeExpr _ cx _)) = do
checkRedContextExpr e
checkRedContext' (warnRedContext (text "type signature") vs) ps
where (vs, ps) = getPredFromContext cx
checkRedContextExpr (Record _ _ _ fs) = mapM_ checkRedContextFieldExpr fs
checkRedContextExpr (RecordUpdate _ e fs) = do
checkRedContextExpr e
mapM_ checkRedContextFieldExpr fs
checkRedContextExpr (Tuple _ es) = mapM_ checkRedContextExpr es
checkRedContextExpr (List _ _ es) = mapM_ checkRedContextExpr es
checkRedContextExpr (ListCompr _ e sts) = do
checkRedContextExpr e
mapM_ checkRedContextStmt sts
checkRedContextExpr (EnumFrom _ e) = checkRedContextExpr e
checkRedContextExpr (EnumFromThen _ e1 e2) = do
checkRedContextExpr e1
checkRedContextExpr e2
checkRedContextExpr (EnumFromTo _ e1 e2) = do
checkRedContextExpr e1
checkRedContextExpr e2
checkRedContextExpr (EnumFromThenTo _ e1 e2 e3) = do
checkRedContextExpr e1
checkRedContextExpr e2
checkRedContextExpr e3
checkRedContextExpr (UnaryMinus _ e) = checkRedContextExpr e
checkRedContextExpr (Apply _ e1 e2) = do
checkRedContextExpr e1
checkRedContextExpr e2
checkRedContextExpr (InfixApply _ e1 _ e2) = do
checkRedContextExpr e1
checkRedContextExpr e2
checkRedContextExpr (LeftSection _ e _) = checkRedContextExpr e
checkRedContextExpr (RightSection _ _ e) = checkRedContextExpr e
checkRedContextExpr (Lambda _ _ e) = checkRedContextExpr e
checkRedContextExpr (Let _ _ ds e) = do
mapM_ checkRedContextDecl ds
checkRedContextExpr e
checkRedContextExpr (IfThenElse _ e1 e2 e3) = do
checkRedContextExpr e1
checkRedContextExpr e2
checkRedContextExpr e3
checkRedContextExpr (Case _ _ _ e as) = do
checkRedContextExpr e
mapM_ checkRedContextAlt as
checkRedContextExpr _ = return ()
checkRedContextStmt :: Statement a -> WCM ()
checkRedContextStmt (StmtExpr _ e) = checkRedContextExpr e
checkRedContextStmt (StmtDecl _ _ ds) = mapM_ checkRedContextDecl ds
checkRedContextStmt (StmtBind _ _ e) = checkRedContextExpr e
checkRedContextAlt :: Alt a -> WCM ()
checkRedContextAlt (Alt _ _ rhs) = checkRedContextRhs rhs
checkRedContextFieldExpr :: Field (Expression a) -> WCM ()
checkRedContextFieldExpr (Field _ _ e) = checkRedContextExpr e
-- ---------------------------------------------------------------------------
-- Warnings messages
-- ---------------------------------------------------------------------------
......
......@@ -68,15 +68,17 @@ updateCSSFile dir = do
program2html :: ModuleIdent -> [Code] -> String
program2html m codes = unlines
[ "<!DOCTYPE html>"
, "<html>", "<head>"
, "<meta http-equiv=\"Content-Type\" content=\"text/html;charset=utf-8\" />"
, "<html lang=\"en\">"
, "<head>"
, "<meta charset=\"utf-8\">"
, "<meta name=\"viewport\" content=\"width=device-width, initial-scale=1.0\">"
, "<title>" ++ titleHtml ++ "</title>"
, "<link rel=\"stylesheet\" href=\"" ++ cssFileName ++ "\" />"
, "<link rel=\"stylesheet\" href=\"" ++ cssFileName ++ "\">"
, "</head>"
, "<body>"
, "<table><tbody><tr>"
, "<td class=\"linenumbers\"><pre>" ++ lineHtml ++ "</pre></td>"
, "<td class=\"sourcecode\"><pre>" ++ codeHtml ++ "</pre></td>"
, "<td class=\"line-numbers\"><pre>" ++ lineHtml ++ "</pre></td>"
, "<td class=\"source-code\"><pre>" ++ codeHtml ++ "</pre></td>"
, "</tr></tbody></table>"
, "</body>"
, "</html>"
......
......@@ -376,7 +376,7 @@ idsTypeExpr (ListType _ ty) = idsTypeExpr ty
idsTypeExpr (ArrowType _ ty1 ty2) = concatMap idsTypeExpr [ty1, ty2]
idsTypeExpr (ParenType _ ty) = idsTypeExpr ty
idsTypeExpr (ForallType _ vs ty) =
map (Identifier IdDeclare False . qualify) vs ++ idsTypeExpr ty
map (Identifier IdDeclare False . qualify) vs ++ Symbol "." : idsTypeExpr ty
idsFieldDecl :: FieldDecl -> [Code]
idsFieldDecl (FieldDecl _ ls ty) =
......
......@@ -202,6 +202,8 @@ failInfos = map (uncurry mkFailTest)
, "Type variable b occurs more than once in left hand side of type declaration"
]
)
, ("MissingLabelInUpdate",
["Undefined record label `l1'"] )
, ("MultipleArities", ["Equations for `test' have different arities"])
, ("MultipleDefinitions",
["Multiple definitions for data/record constructor `Rec'"]
......@@ -267,12 +269,10 @@ passInfos = map mkPassTest
, "Hierarchical"
, "ImportRestricted"
, "ImportRestricted2"
, "ImpredDollar"
, "Infix"
, "Inline"
, "Lambda"
, "Maybe"
, "Monad"
, "NegLit"
, "Newtype1"
, "Newtype2"
......@@ -286,11 +286,8 @@ passInfos = map mkPassTest
, "RecordTest2"
, "RecordTest3"
, "ReexportTest"
, "ScottEncoding"
, "SelfExport"
, "SpaceLeak"
, "Subsumption"
, "TermInv"
, "TyConsTest"
, "TypedExpr"
, "UntypedAcy"
......
module MissingLabelInUpdate where
import MissingLabelInUpdateExport
-- test :: R -> R
test r = r { l1 = "" }
module MissingLabelInUpdateExport(R(C1)) where
data R = C1 { l1 :: String, l2 :: Int }
| C2 { l1 :: String }
fun :: a -> Int
fun x = case x of
_ -> 1
where
where
module ImportRestricted (module ImportRestrictedExport) where
import ImportRestrictedExport (Test(test))
module ImportRestricted2 where
import ImportRestricted
import ImportRestrictedExport (Test(Test))
testexpr1 :: Test
testexpr1 = Test testexpr1
testexpr2 :: Test
testexpr2 = test testexpr1
module ImportRestrictedExport where
data Test = Test { test :: Test }
main :: IO ()
main = do
x
where x = return ()
other :: Int -> Int
other f = case f of
_ -> x
where x = 1