...
 
Commits (3)
......@@ -10,7 +10,7 @@
TODO
-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Base.PrettyKinds where
import Curry.Base.Pretty
......
......@@ -10,7 +10,8 @@
TODO
-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Base.PrettyTypes where
#if __GLASGOW_HASKELL__ >= 804
......
......@@ -19,10 +19,9 @@
-}
module Checks.InstanceCheck (instanceCheck) where
import Control.Monad.Extra (concatMapM, whileM, when)
import Control.Monad.Extra (concatMapM, whileM, unless)
import qualified Control.Monad.State as S (State, execState, gets, modify)
import Data.List (nub, partition, sortBy)
import Data.Maybe (catMaybes)
import qualified Data.Map as Map
import qualified Data.Set.Extra as Set
......@@ -202,38 +201,26 @@ groupDeriveInfos = scc bound free
free (DeriveInfo _ _ _ tys _) = concatMap typeConstrs tys
bindDerivedInstances :: ClassEnv -> [DeriveInfo] -> INCM ()
bindDerivedInstances clsEnv dis = do
-- If any registration of initial pred sets failed, return immediately, as
-- there are no other (Data-)Instances that might succeed.
bs <- mapM (enterInitialPredSet clsEnv) dis
when (any or bs) $
whileM $ concatMapM (inferPredSets clsEnv) dis >>= updatePredSets
bindDerivedInstances clsEnv dis = unless (any hasDataFunType dis) $ do
mapM_ (enterInitialPredSet clsEnv) dis
whileM $ concatMapM (inferPredSets clsEnv) dis >>= updatePredSets
where
hasDataFunType (DeriveInfo _ _ _ tys clss) =
clss == [qDataId] && any isFunType tys
enterInitialPredSet :: ClassEnv -> DeriveInfo -> INCM [Bool]
enterInitialPredSet clsEnv (DeriveInfo p tc pty tys clss) =
mapM (bindDerivedInstance clsEnv p tc pty tys) clss
enterInitialPredSet :: ClassEnv -> DeriveInfo -> INCM ()
enterInitialPredSet clsEnv (DeriveInfo p tc pty _ clss) =
mapM_ (bindDerivedInstance clsEnv p tc pty) clss
-- Note: The methods and arities entered into the instance environment have
-- to match methods and arities of the later generated instance declarations.
bindDerivedInstance :: ClassEnv -> Position -> QualIdent -> PredType -> [Type]
-> QualIdent -> INCM Bool
bindDerivedInstance clsEnv p tc pty tys cls = do
bindDerivedInstance :: ClassEnv -> Position -> QualIdent -> PredType -> QualIdent
-> INCM ()
bindDerivedInstance clsEnv p tc pty cls = do
m <- getModuleIdent
-- immediately return if asked to derive Data for functional Datatype
if any isFunType tys && cls == qDataId
then return False
else do
-- bindDerivedInstances normally infers the PredSet with empty `tys`
-- in order to always bind the instance in a first step.
-- For DataDeriving, this leads to problems.
let tys' = if cls == qDataId then tys else []
mps <- inferPredSet clsEnv p tc pty tys' cls
case mps of
Just (i, ps) -> modifyInstEnv (bindInstInfo i (m, ps, impls)) >>
return True
-- encountered unsatisfied DataClass constraint -> dont derive it here
Nothing -> return False
((i, ps), _) <- inferPredSet clsEnv p tc pty [] cls
modifyInstEnv (bindInstInfo i (m, ps, impls))
where impls | cls == qEqId = [(eqOpId, 2)]
| cls == qOrdId = [(leqOpId, 2)]
| cls == qEnumId = [ (succId, 1), (predId, 1), (toEnumId, 1)
......@@ -247,12 +234,12 @@ bindDerivedInstance clsEnv p tc pty tys cls = do
| otherwise =
internalError "InstanceCheck.bindDerivedInstance.impls"
inferPredSets :: ClassEnv -> DeriveInfo -> INCM [(InstIdent, PredSet)]
inferPredSets :: ClassEnv -> DeriveInfo -> INCM [((InstIdent, PredSet), Bool)]
inferPredSets clsEnv (DeriveInfo p tc pty tys clss) =
catMaybes <$> mapM (inferPredSet clsEnv p tc pty tys) clss
mapM (inferPredSet clsEnv p tc pty tys) clss
inferPredSet :: ClassEnv -> Position -> QualIdent -> PredType -> [Type]
-> QualIdent -> INCM (Maybe (InstIdent, PredSet))
-> QualIdent -> INCM ((InstIdent, PredSet), Bool)
inferPredSet clsEnv p tc (PredType ps inst) tys cls = do
m <- getModuleIdent
let doc = ppPred m $ Pred cls inst
......@@ -264,23 +251,24 @@ inferPredSet clsEnv p tc (PredType ps inst) tys cls = do
reducePredSet (cls == qDataId) p "derived instance" doc clsEnv ps'''
let ps5 = filter noPolyPred $ Set.toList ps4
if any (isDataPred m) (Set.toList novarps ++ ps5) && cls == qDataId
then return Nothing
then return (((cls, tc), ps4), False)
else mapM_ (reportUndecidable p "derived instance" doc) ps5
>> return (Just ((cls, tc), ps4))
>> return (((cls, tc), ps4), True)
where
noPolyPred (Pred _ (TypeVariable _)) = False
noPolyPred (Pred _ _ ) = True
isDataPred _ (Pred qid _) = qid == qDataId
inferPredSet _ _ _ _ _ _ = internalError "InstanceCheck.inferPredSet"
updatePredSets :: [(InstIdent, PredSet)] -> INCM Bool
updatePredSets :: [((InstIdent, PredSet), Bool)] -> INCM Bool
updatePredSets = fmap or . mapM (uncurry updatePredSet)
updatePredSet :: InstIdent -> PredSet -> INCM Bool
updatePredSet i ps = do
updatePredSet :: (InstIdent, PredSet) -> Bool -> INCM Bool
updatePredSet (i, ps) enter = do
inEnv <- getInstEnv
case lookupInstInfo i inEnv of
Just (m, ps', is)
| not enter -> modifyInstEnv (removeInstInfo i) >> return False
| ps == ps' -> return False
| otherwise -> do
modifyInstEnv $ bindInstInfo i (m, ps, is)
......
This diff is collapsed.
......@@ -502,7 +502,7 @@ parseCppDefinition arg optErr
= onCppOpts (addCppDefinition s v) optErr
| otherwise
= addErr (cppDefinitionErr arg) optErr
where (s, v) = fmap (drop 1) $ break ('=' ==) arg
where (s, v) = drop 1 <$> break ('=' ==) arg
addCppDefinition :: String -> String -> CppOpts -> CppOpts
addCppDefinition s v opts =
......
......@@ -20,10 +20,10 @@
module Env.Instance
( InstIdent, ppInstIdent, InstInfo
, InstEnv, initInstEnv, bindInstInfo, lookupInstInfo
, InstEnv, initInstEnv, bindInstInfo, removeInstInfo, lookupInstInfo
) where
import qualified Data.Map as Map (Map, empty, insert, lookup)
import qualified Data.Map as Map (Map, empty, insert, delete, lookup)
import Curry.Base.Ident
import Curry.Base.Pretty
......@@ -46,5 +46,8 @@ initInstEnv = Map.empty
bindInstInfo :: InstIdent -> InstInfo -> InstEnv -> InstEnv
bindInstInfo = Map.insert
removeInstInfo :: InstIdent -> InstEnv -> InstEnv
removeInstInfo = Map.delete
lookupInstInfo :: InstIdent -> InstEnv -> Maybe InstInfo
lookupInstInfo = Map.lookup
......@@ -12,38 +12,44 @@
This module defines a function for generating HTML documentation pages
for Curry source modules.
-}
{-# LANGUAGE TemplateHaskell #-}
module Html.CurryHtml (source2html) where
import Prelude as P
import Control.Monad.Writer
import Data.List (mapAccumL)
import Data.Maybe (fromMaybe, isJust)
import Data.ByteString as BS (ByteString, writeFile)
import Data.FileEmbed
import Network.URI (escapeURIString, isUnreserved)
import System.Directory (copyFile, doesFileExist)
import System.FilePath ((</>))
import Curry.Base.Ident ( ModuleIdent (..), Ident (..), QualIdent (..)
, unqualify, moduleName)
import Curry.Base.Monad (CYIO, failMessages)
import Curry.Base.Monad (CYIO)
import Curry.Base.Position (Position)
import Curry.Base.Pretty ((<+>), text, vcat)
import Curry.Files.Filenames (htmlName)
import Curry.Syntax (Module (..), Token)
import Html.SyntaxColoring
import Base.Messages (message)
import CompilerOpts (Options (..))
import Paths_curry_frontend (getDataFileName)
-- |'FilePath' of the CSS style file to be added to the documentation.
cssFile :: FilePath
cssFile = "currysource.css"
-- |Read file via TemplateHaskell at compile time
cssContent :: ByteString
cssContent = $(makeRelativeToProject "data/currysource.css" >>= embedFile)
-- | Name of the css file
-- NOTE: The relative path is given above
cssFileName :: String
cssFileName = "currysource.css"
-- |Translate source file into HTML file with syntaxcoloring
source2html :: Options -> ModuleIdent -> [(Position, Token)] -> Module a
-> CYIO ()
source2html opts mid toks mdl = do
liftIO $ writeFile (outDir </> htmlName mid) doc
liftIO $ P.writeFile (outDir </> htmlName mid) doc
updateCSSFile outDir
where
doc = program2html mid (genProgram mdl toks)
......@@ -52,16 +58,8 @@ source2html opts mid toks mdl = do
-- |Update the CSS file
updateCSSFile :: FilePath -> CYIO ()
updateCSSFile dir = do
src <- liftIO $ getDataFileName cssFile
let target = dir </> cssFile
srcExists <- liftIO $ doesFileExist src
if srcExists then liftIO $ copyFile src target
else failMessages [message $ missingStyleFile src]
where
missingStyleFile f = vcat
[ text "Could not copy CSS style file:"
, text "File" <+> text ("`" ++ f ++ "'") <+> text "does not exist"
]
let target = dir </> cssFileName
liftIO $ BS.writeFile target cssContent
-- generates htmlcode with syntax highlighting
-- @param modulname
......@@ -73,7 +71,7 @@ program2html m codes = unlines
, "<html>", "<head>"
, "<meta http-equiv=\"Content-Type\" content=\"text/html;charset=utf-8\" />"
, "<title>" ++ titleHtml ++ "</title>"
, "<link rel=\"stylesheet\" type=\"text/css\" href=\"" ++ cssFile ++ "\"/>"
, "<link rel=\"stylesheet\" href=\"" ++ cssFileName ++ "\" />"
, "</head>"
, "<body>"
, "<table><tbody><tr>"
......
......@@ -164,10 +164,11 @@ importClasses m = flip $ foldr (bindClass m)
bindClass :: ModuleIdent -> IDecl -> ClassEnv -> ClassEnv
bindClass m (HidingClassDecl p cx cls k tv) =
bindClass m (IClassDecl p cx cls k tv [] [])
bindClass m (IClassDecl _ cx cls _ _ ds _ ) =
bindClass m (IClassDecl _ cx cls _ _ ds ids) =
bindClassInfo (qualQualify m cls) (sclss, ms)
where sclss = map (\(Constraint _ scls _) -> qualQualify m scls) cx
ms = map (\d -> (imethod d, isJust $ imethodArity d)) ds
ms = map (\d -> (imethod d, isJust $ imethodArity d)) $ filter isVis ds
isVis (IMethodDecl _ idt _ _ ) = idt `notElem` ids
bindClass _ _ = id
importInstances :: ModuleIdent -> [IDecl] -> InstEnv -> InstEnv
......@@ -219,9 +220,10 @@ types m (ITypeDecl _ tc k tvs ty) =
[typeCon aliasType m tc k tvs (toQualType m tvs ty)]
where
aliasType tc' k' = AliasType tc' k' (length tvs)
types m (IClassDecl _ _ qcls k tv ds _) =
[typeCls m qcls k (map mkMethod ds)]
types m (IClassDecl _ _ qcls k tv ds ids) =
[typeCls m qcls k (map mkMethod $ filter isVis ds)]
where
isVis (IMethodDecl _ f _ _ ) = f `notElem` ids
mkMethod (IMethodDecl _ f a qty) = ClassMethod f a $
qualifyPredType m $ normalize 1 $ toMethodType qcls tv qty
types _ _ = []
......
......@@ -28,7 +28,10 @@ import Control.Applicative ((<$>))
import qualified Control.Exception as E (SomeException, catch)
import Data.List (isInfixOf, sort)
import Distribution.TestSuite
import qualified Data.Map as Map (insert)
import Distribution.TestSuite ( Test (..), TestInstance (..)
, Progress (..), Result (..)
, OptionDescr)
import System.FilePath (FilePath, (</>), (<.>))
import Curry.Base.Message (Message, message, ppMessages, ppError)
......@@ -36,11 +39,12 @@ import Curry.Base.Monad (CYIO, runCYIO)
import Curry.Base.Pretty (text)
import qualified CompilerOpts as CO ( Options (..), WarnOpts (..)
, WarnFlag (..), Verbosity (VerbQuiet)
, defaultOptions, defaultWarnOpts)
, CppOpts (..)
, defaultOptions)
import CurryBuilder (buildCurry)
tests :: IO [Test]
tests = return [passingTests, warningTests, failingTests]
tests = return [failingTests, passingTests, warningTests]
runSecure :: CYIO a -> IO (Either [Message] (a, [Message]))
runSecure act = runCYIO act `E.catch` handler
......@@ -54,7 +58,7 @@ runTest opts test errorMsgs =
else catchE <$> runSecure (buildCurry opts' test)
where
cppOpts = CO.optCppOpts opts
cppDefs = Map.insert "__PAKCS__" 300 (CO.cppDefinitions cppOpts)
cppDefs = Map.insert "__PAKCS__" 3 (CO.cppDefinitions cppOpts)
wOpts = CO.optWarnOpts opts
wFlags = CO.WarnUnusedBindings
: CO.WarnUnusedGlobalBindings
......@@ -82,6 +86,13 @@ runTest opts test errorMsgs =
showMessages :: [Message] -> String
showMessages = show . ppMessages ppError . sort
-- group of test which should fail yielding a specific error message
failingTests :: Test
failingTests = Group { groupName = "Failing Tests"
, concurrently = False
, groupTests = map (mkTest "test/fail/") failInfos
}
-- group of tests which should pass
passingTests :: Test
passingTests = Group { groupName = "Passing Tests"
......@@ -89,13 +100,6 @@ passingTests = Group { groupName = "Passing Tests"
, groupTests = map (mkTest "test/pass/") passInfos
}
-- group of test which should fail yielding a specific error message
failingTests :: Test
failingTests = Group { groupName = "Failing Tests"
, concurrently = False
, groupTests = map (mkTest "test/fail/") failInfos
}
-- group of tests which should pass producing a specific warning message
warningTests :: Test
warningTests = Group { groupName = "Warning Tests"
......@@ -129,61 +133,6 @@ type TestInfo = (String, [String], [OptionDescr], Maybe SetOption, [String])
type SetOption = String -> String -> Either String TestInstance
--------------------------------------------------------------------------------
-- Definition of passing tests
--------------------------------------------------------------------------------
-- generate a simple passing test
mkPassTest :: String -> TestInfo
mkPassTest name = (name, [], [], Nothing, [])
-- To add a passing test to the test suite simply add the module name of the
-- test code to the following list
passInfos :: [TestInfo]
passInfos = map mkPassTest
[ "AbstractCurryBug"
, "ACVisibility"
, "AnonymVar"
, "CaseComplete"
-- MARK
-- , "ChurchEncoding"
-- , "ClassMethods"
, "DataPass"
, "DefaultPrecedence"
, "Dequeue"
, "ExplicitLayout"
, "FCase"
, "FP_Lifting"
, "FP_NonCyclic"
, "FP_NonLinearity"
, "FunctionalPatterns"
, "HaskellRecords"
, "Hierarchical"
, "Infix"
, "Inline"
, "Lambda"
, "Maybe"
, "NegLit"
, "Newtype1"
, "Newtype2"
, "NonLinearLHS"
, "OperatorDefinition"
, "PatDecl"
, "Prelude"
, "Pretty"
, "RecordsPolymorphism"
, "RecordTest1"
, "RecordTest2"
, "RecordTest3"
, "ReexportTest"
, "SelfExport"
, "SpaceLeak"
, "TyConsTest"
, "TypedExpr"
, "UntypedAcy"
, "Unzip"
]
--------------------------------------------------------------------------------
-- Definition of failing tests
--------------------------------------------------------------------------------
......@@ -205,10 +154,10 @@ failInfos = map (uncurry mkFailTest)
, "applyFunTest2 = applyFun funA 'a' 'b'"
]
)
[ ("DataFail",
, ("DataFail",
[ "Missing instance for Prelude.Data Test1"
, "Missing instance for Prelude.Data (Test2 _3)"
, "Missing instance for Prelude.Data (Test2 _5)"
, "Missing instance for Prelude.Data (Test2"
, "Missing instance for Prelude.Data (Test2"
, "Missing instance for Prelude.Data Test1"
]
)
......@@ -288,6 +237,67 @@ failInfos = map (uncurry mkFailTest)
)
]
--------------------------------------------------------------------------------
-- Definition of passing tests
--------------------------------------------------------------------------------
-- generate a simple passing test
mkPassTest :: String -> TestInfo
mkPassTest = flip mkFailTest []
-- To add a passing test to the test suite simply add the module name of the
-- test code to the following list
passInfos :: [TestInfo]
passInfos = map mkPassTest
[ "AbstractCurryBug"
, "ACVisibility"
, "AnonymVar"
, "CaseComplete"
, "DataPass"
, "DefaultPrecedence"
, "Dequeue"
, "EmptyWhere"
, "ExplicitLayout"
, "FCase"
, "FP_Lifting"
, "FP_NonCyclic"
, "FP_NonLinearity"
, "FunctionalPatterns"
, "HaskellRecords"
, "Hierarchical"
, "ImportRestricted"
, "ImportRestricted2"
, "ImpredDollar"
, "Infix"
, "Inline"
, "Lambda"
, "Maybe"
, "Monad"
, "NegLit"
, "Newtype1"
, "Newtype2"
, "NonLinearLHS"
, "OperatorDefinition"
, "PatDecl"
, "Prelude"
, "Pretty"
, "RecordsPolymorphism"
, "RecordTest1"
, "RecordTest2"
, "RecordTest3"
, "ReexportTest"
, "ScottEncoding"
, "SelfExport"
, "SpaceLeak"
, "Subsumption"
, "TermInv"
, "TyConsTest"
, "TypedExpr"
, "UntypedAcy"
, "Unzip"
, "WhereAfterDo"
]
--------------------------------------------------------------------------------
-- Definition of warning tests
--------------------------------------------------------------------------------
......
module ClassHiddenExport (A(methodA), mb) where
class A a where
methodA :: a
methodB :: a
methodB = error ""
mb = methodB
module ClassHiddenFail where
import ClassHiddenExport
instance A Bool where
methodA = True
methodB = False
This source diff could not be displayed because it is too large. You can view the blob instead.
f :: Eq a => a -> Bool
f x = g x
where
g y = x == y
h :: a -> Bool
h x = g x
f' :: [a] -> [a]
f' xs = g' (reverse xs)
where
g' :: [b] -> [b]
g' ys = xs ++ ys
......@@ -9,5 +9,4 @@ data Entry b = Entry b (Entry b) (Entry b) | Empty
f' :: [a] -> [a]
f' xs = g' (reverse xs)
where
g' :: [b] -> [b]
g' ys = xs ++ ys
module ClassHiddenExport (A(methodA), mb) where
class A a where
methodA :: a
methodB :: a
methodB = error ""
mb = methodB
module ClassHiddenPass where
import ClassHiddenExport
instance A Bool where
methodA = True
......@@ -2,18 +2,17 @@
f x = g x &> x
where
g (h y) = success
-- causes an error since h is not global
--h y = x
g (h y) = success
where z = y :: Int
h y = error "undefined"
main = f z
where z free
{-
f2 x = g2 x x &> x
g2 x1 z = h2 x2 y =:<= z &> x1 =:= x2 &> success
g2 x1 z = h2 x2 (y :: Int) =:<= z &> x1 =:= x2 &> success
where x2, y free
h2 x y = x
......@@ -24,6 +23,7 @@ main2 = f2 z
f3 x = g3 x x &> x
g3 x (h3 x y) = success
where z = y :: Int
h3 x y = x
......@@ -34,4 +34,3 @@ patid x (id x) = x
f5 (id x) (id x) = x
-}
......@@ -56,19 +56,19 @@ k a b | id x =:<= a &> id y =:<= b &> x =:= y = x
{-# LANGUAGE FunctionalPatterns #-}
f :: a -> a -> a
f :: Data a => a -> a -> a
f x (id x) = x
-- Expected translation:
-- f x y = let z free in id z =:<= y &> x =:= z &> x
g :: a -> a -> a
g :: Data a => a -> a -> a
g (id x) (id x) = x
-- Expected translation:
-- g x y = let a, b free in id a =:<= x &> id b =:<= y &> a =:= b &> a
h :: (a, a) -> a
h :: Data a => (a, a) -> a
h (pair x x) = x
-- Expected translation:
......
......@@ -7,7 +7,7 @@ data R1 a = C { l :: Int, x :: a }
r1 :: R1 Bool
r1 = C { l = 42, x = True }
r2 :: R1 a
r2 :: Data a => R1 a
r2 = C {}
-- pattern matching
......
This source diff could not be displayed because it is too large. You can view the blob instead.
This source diff could not be displayed because it is too large. You can view the blob instead.