diff --git a/free-theorems.cabal b/free-theorems.cabal --- a/free-theorems.cabal +++ b/free-theorems.cabal @@ -1,5 +1,5 @@ name: free-theorems -version: 0.3.1.3 +version: 0.3.2.0 license: PublicDomain license-file: LICENSE author: Sascha Boehme @@ -17,7 +17,7 @@ In the last two sublanguages, also inequational free theorems may be derived in addition to classical equational results. category: Language -tested-with: GHC==6.8.2, GHC==6.10.1, GHC==6.12.3 +tested-with: GHC==7.6.1 cabal-version: >= 1.2.3 build-type: Simple @@ -38,7 +38,7 @@ build-depends: mtl >= 1.0 , haskell-src >= 1.0 - , haskell-src-exts >= 0.3.9 && < 0.4 + , haskell-src-exts >= 1.13.5 , pretty >= 1.0.0.0 , containers >= 0.1.0.1 if impl(ghc >= 6.10) @@ -47,7 +47,7 @@ , syb >= 0.1.0.0 else build-depends: - base >= 1 && < 4 + base >= 1 && < 5 exposed-modules: Language.Haskell.FreeTheorems @@ -76,7 +76,6 @@ hs-source-dirs: src extensions: - Generics, DeriveDataTypeable, Rank2Types diff --git a/src/Arbitraries.hs b/src/Arbitraries.hs --- a/src/Arbitraries.hs +++ b/src/Arbitraries.hs @@ -25,6 +25,8 @@ instance Arbitrary ListOfDeclarations where arbitrary = do n <- choose (1, 100) liftM ListOfDeclarations (replicateM n arbitrary) + +instance CoArbitrary ListOfDeclarations where coarbitrary _ = id @@ -35,6 +37,8 @@ , liftM TypeDecl arbitrary , liftM ClassDecl arbitrary , liftM TypeSig arbitrary ] + +instance CoArbitrary Declaration where coarbitrary _ = id @@ -46,6 +50,8 @@ c <- choose (1, 7) liftM2 (Data n) (replicateM v arbitrary) (replicateM c arbitrary) + +instance CoArbitrary DataDeclaration where coarbitrary _ = id @@ -56,6 +62,8 @@ c <- arbIdent id 'D' [] liftM2 (\vs -> Newtype n vs c) (replicateM v arbitrary) arbitrary + +instance CoArbitrary NewtypeDeclaration where coarbitrary _ = id @@ -66,6 +74,8 @@ , "FilePath" ] v <- choose (0, 5) liftM2 (Type n) (replicateM v arbitrary) arbitrary + +instance CoArbitrary TypeDeclaration where coarbitrary _ = id @@ -79,6 +89,8 @@ , "RealFrac", "RealFloat" ] s <- choose (0, 10) liftM2 (Class p n) arbitrary (replicateM s arbitrary) + +instance CoArbitrary ClassDeclaration where coarbitrary _ = id @@ -91,6 +103,8 @@ , "div", "mod", "pi", "id", "flip", "const", "map" , "filter", "head", "tail", "length", "foldr", "foldl" ] liftM (Signature s) arbitrary + +instance CoArbitrary Signature where coarbitrary _ = id @@ -101,18 +115,24 @@ , "Just", "LT", "GT", "EQ" ] i <- choose (0, 5) liftM (DataCon con) (replicateM i arbitrary) + +instance CoArbitrary DataConstructorDeclaration where coarbitrary _ = id instance Arbitrary BangTypeExpression where arbitrary = oneof [ liftM Banged arbitrary, liftM Unbanged arbitrary ] + +instance CoArbitrary BangTypeExpression where coarbitrary _ = id instance Arbitrary TypeExpression where arbitrary = sized arbTypeExpr + +instance CoArbitrary TypeExpression where coarbitrary _ = id arbTypeExpr n = @@ -151,12 +171,16 @@ [ "Bool", "Maybe", "Either", "String", "Ordering" , "Rational", "ShowS", "ReadS", "FilePath" ] ] + +instance CoArbitrary TypeConstructor where coarbitrary _ = id instance Arbitrary TypeVariable where arbitrary = arbIdent TV 'a' ["a", "b", "c", "d", "e"] + +instance CoArbitrary TypeVariable where coarbitrary _ = id @@ -166,12 +190,17 @@ [ "Eq", "Ord", "Num", "Integral", "Show", "Read", "Bounded" , "Enum", "Real", "Fractional", "Floating", "RealFrac" , "RealFloat" ] + +instance CoArbitrary TypeClass where coarbitrary _ = id instance Arbitrary FixedTypeExpression where arbitrary = oneof (map (return . TF . Ident) [ "t1", "t2", "t3", "t4", "t5" ]) + + +instance CoArbitrary FixedTypeExpression where coarbitrary _ = id @@ -184,6 +213,8 @@ , return $ SubsetWithSeq EquationalTheorem , return $ SubsetWithSeq InequationalTheorem ] + +instance CoArbitrary LanguageSubset where coarbitrary _ = id diff --git a/src/FrontendCheckLocalTests.hs b/src/FrontendCheckLocalTests.hs --- a/src/FrontendCheckLocalTests.hs +++ b/src/FrontendCheckLocalTests.hs @@ -374,7 +374,7 @@ trivialCheck :: (a -> Bool) -> [a] -> Property trivialCheck prop xs = - trivial (null xs) (if null xs then True else prop (head xs)) + (`classify` "trivial") (null xs) (if null xs then True else prop (head xs)) diff --git a/src/FrontendOtherTests.hs b/src/FrontendOtherTests.hs --- a/src/FrontendOtherTests.hs +++ b/src/FrontendOtherTests.hs @@ -58,7 +58,7 @@ let getTypeSyn d = case d of { TypeDecl d -> Just d ; otherwise -> Nothing } process ds = fst . runWriter $ checkLocal ds >>= checkGlobal [] typeSyns = mapMaybe getTypeSyn . process . getDeclarations $ ds - in trivial (null typeSyns) $ prop typeSyns + in (`classify` "trivial") (null typeSyns) $ prop typeSyns diff --git a/src/Language/Haskell/FreeTheorems/Parser/Hsx.hs b/src/Language/Haskell/FreeTheorems/Parser/Hsx.hs --- a/src/Language/Haskell/FreeTheorems/Parser/Hsx.hs +++ b/src/Language/Haskell/FreeTheorems/Parser/Hsx.hs @@ -1,5 +1,3 @@ - - module Language.Haskell.FreeTheorems.Parser.Hsx (parse) where @@ -77,7 +75,7 @@ ++ ":" ++ show (srcColumn l) ++ ").")] return [] where - collectDeclarations :: [S.Declaration] -> HsDecl -> Parsed [S.Declaration] + collectDeclarations :: [S.Declaration] -> Decl -> Parsed [S.Declaration] collectDeclarations ds d = case mkDeclaration d of Left e -> tell [e] >> return ds @@ -93,29 +91,29 @@ -- | Filters all declarations of a Haskell module. -filterDeclarations :: HsModule -> [HsDecl] -filterDeclarations (HsModule _ _ _ _ ds) = filter isAcceptedDeclaration ds +filterDeclarations :: Module -> [Decl] +filterDeclarations (Module _ _ _ _ _ _ ds) = filter isAcceptedDeclaration ds where isAcceptedDeclaration decl = case decl of - HsTypeDecl _ _ _ _ -> True - HsDataDecl _ _ _ _ _ _ _ -> True - HsClassDecl _ _ _ _ _ _ -> True - HsTypeSig _ _ _ -> True - otherwise -> False + TypeDecl _ _ _ _ -> True + DataDecl _ _ _ _ _ _ _ -> True + ClassDecl _ _ _ _ _ _ -> True + TypeSig _ _ _ -> True + otherwise -> False -- | Transforms a list of declarations by simplifying type signatures. -transform :: [HsDecl] -> [HsDecl] +transform :: [Decl] -> [Decl] transform = everywhere (mkT extendTypeSignature) where -- Type signatures can be given for several names at once. -- This function transforms declarations such that every type signature is -- given for exactly one name only. - extendTypeSignature :: [HsDecl] -> [HsDecl] + extendTypeSignature :: [Decl] -> [Decl] extendTypeSignature ds = case ds of - ((HsTypeSig l ns t):ds') -> (map (\n -> HsTypeSig l [n] t) ns) ++ ds' + ((TypeSig l ns t):ds') -> (map (\n -> TypeSig l [n] t) ns) ++ ds' otherwise -> ds @@ -127,30 +125,41 @@ -- | Transforms a class declaration. -clsDeclToDecl :: HsClassDecl -> ErrorOr HsDecl +clsDeclToDecl :: ClassDecl -> ErrorOr Decl clsDeclToDecl decl = case decl of - HsClsDecl decl -> return decl - HsClsDataFam _ _ _ _ _ -> throwError noDataFam - HsClsTyFam _ _ _ _ -> throwError noTypeFam - HsClsTyDef _ _ _ -> throwError noTypeFam + ClsDecl decl -> return decl + ClsDataFam _ _ _ _ _ -> throwError noDataFam + ClsTyFam _ _ _ _ -> throwError noTypeFam + ClsTyDef _ _ _ -> throwError noTypeFam noDataFam = pp "Data Families are not allowed" noTypeFam = pp "Type Families are not allowed" -- | Transforms a declaration. -mkDeclaration :: HsDecl -> ErrorOr S.Declaration +mkDeclaration :: Decl -> ErrorOr S.Declaration mkDeclaration decl = case decl of - HsTypeDecl l n vs t -> addErr l n (mkType n vs t) - HsDataDecl l DataType _ n vs cs _ -> addErr l n (mkData n vs cs) - HsDataDecl l NewType _ n vs [c] _ -> addErr l n (mkNewtype n vs c) - HsClassDecl l scs n [v] _ ds -> addErr l n (mkClass scs n v ds) - HsTypeSig l [n] t -> addErr l n (mkSignature n t) + TypeDecl l n vs t -> do + ns <- sequence (map unkind vs) + addErr l n (mkType n ns t) + DataDecl l DataType _ n vs cs _ -> do + ns <- sequence (map unkind vs) + addErr l n (mkData n ns cs) + DataDecl l NewType _ n vs [c] _ -> do + ns <- sequence (map unkind vs) + addErr l n (mkNewtype n ns c) + ClassDecl l scs n [v] _ ds -> do + nv <- unkind v + addErr l n (mkClass scs n nv ds) + TypeSig l [n] t -> addErr l n (mkSignature n t) - HsClassDecl l _ n [] _ _ -> addErr l n (throwError missingVar) - HsClassDecl l _ n (_:_:_) _ _ -> addErr l n (throwError noMultiParam) + ClassDecl l _ n [] _ _ -> addErr l n (throwError missingVar) + ClassDecl l _ n (_:_:_) _ _ -> addErr l n (throwError noMultiParam) -- no other case con occur, see above function 'filterDeclarations'. + where + unkind (UnkindedVar x) = return x + unkind _ = throwError $ pp "Type variable declarations with explicit kind annotations are not allowed." missingVar = pp "Missing type variable to be constrained by the type class." @@ -161,7 +170,7 @@ -- | Adds an error message based on the name of a declaration if the given -- transformation caused an error. -addErr :: SrcLoc -> HsName -> ErrorOr S.Declaration-> ErrorOr S.Declaration +addErr :: SrcLoc -> Name -> ErrorOr S.Declaration-> ErrorOr S.Declaration addErr loc name e = case getError e of Nothing -> e Just doc -> throwError $ @@ -174,7 +183,7 @@ -- | Transforms the components of a type declaration. -mkType :: HsName -> [HsName] -> HsType -> ErrorOr S.Declaration +mkType :: Name -> [Name] -> Type -> ErrorOr S.Declaration mkType name vars ty = do ident <- mkIdentifier name tvs <- mapM mkTypeVariable vars @@ -185,7 +194,7 @@ -- | Transforms the components of a data declaration. -mkData :: HsName -> [HsName] -> [HsQualConDecl] -> ErrorOr S.Declaration +mkData :: Name -> [Name] -> [QualConDecl] -> ErrorOr S.Declaration mkData name vars cons = do ident <- mkIdentifier name tvs <- mapM mkTypeVariable vars @@ -197,12 +206,12 @@ -- | Transforms a data constructor declaration. mkDataConstructorDeclaration :: - HsQualConDecl -> ErrorOr S.DataConstructorDeclaration + QualConDecl -> ErrorOr S.DataConstructorDeclaration -mkDataConstructorDeclaration (HsQualConDecl _ _ _ (HsConDecl name btys)) = +mkDataConstructorDeclaration (QualConDecl _ _ _ (ConDecl name btys)) = mkDataConDecl name btys -mkDataConstructorDeclaration (HsQualConDecl _ _ _ (HsRecDecl name rbtys)) = +mkDataConstructorDeclaration (QualConDecl _ _ _ (RecDecl name rbtys)) = let btys = concatMap (\(l,ty) -> replicate (length l) ty) rbtys in mkDataConDecl name btys @@ -211,8 +220,8 @@ -- | Transforms the components of a data constructor declaration. mkDataConDecl :: - HsName - -> [HsBangType] + Name + -> [BangType] -> ErrorOr S.DataConstructorDeclaration mkDataConDecl name btys = do @@ -220,22 +229,22 @@ bts <- mapM mkBangTyEx btys return (S.DataCon ident bts) where - mkBangTyEx (HsBangedTy ty) = liftM S.Banged (mkTypeExpression ty) - mkBangTyEx (HsUnBangedTy ty) = liftM S.Unbanged (mkTypeExpression ty) + mkBangTyEx (BangedTy ty) = liftM S.Banged (mkTypeExpression ty) + mkBangTyEx (UnBangedTy ty) = liftM S.Unbanged (mkTypeExpression ty) -- | Transforms the components of a newtype declaration. -mkNewtype :: HsName -> [HsName] -> HsQualConDecl -> ErrorOr S.Declaration -mkNewtype name vars (HsQualConDecl _ _ _ con) = do +mkNewtype :: Name -> [Name] -> QualConDecl -> ErrorOr S.Declaration +mkNewtype name vars (QualConDecl _ _ _ con) = do ident <- mkIdentifier name tvs <- mapM mkTypeVariable vars (con,t) <- mkNewtypeConDecl con return (S.NewtypeDecl (S.Newtype ident tvs con t)) where - mkNewtypeConDecl (HsConDecl c bts) = mkNCD c bts - mkNewtypeConDecl (HsRecDecl c bts) = mkNCD c (snd $ unzip bts) + mkNewtypeConDecl (ConDecl c bts) = mkNCD c bts + mkNewtypeConDecl (RecDecl c bts) = mkNCD c (snd $ unzip bts) mkNCD c [bty] = liftM2 (,) (mkIdentifier c) (bang bty) mkNCD c [] = throwError errNewtype @@ -244,8 +253,8 @@ errNewtype = pp "A `newtype' declaration must have exactly one type expression." - bang (HsUnBangedTy ty) = mkTypeExpression ty - bang (HsBangedTy ty) = + bang (UnBangedTy ty) = mkTypeExpression ty + bang (BangedTy ty) = throwError (pp "A `newtype' declaration must not use a strictness flag.") @@ -253,7 +262,7 @@ -- | Transforms the components of a Haskell class declaration. -- Every declaration in the class body is ignored except of type signatures. -mkClass :: HsContext -> HsName -> HsName -> [HsClassDecl] -> ErrorOr S.Declaration +mkClass :: Context -> Name -> Name -> [ClassDecl] -> ErrorOr S.Declaration mkClass ctx name var clsDecls = do ident <- mkIdentifier name tv <- mkTypeVariable var @@ -266,9 +275,9 @@ return (S.ClassDecl (S.Class superCs ident tv sigs)) where -- Returns 'True' if a declaration is a type signature, otherwise 'False'. - isSig :: HsDecl -> Bool + isSig :: Decl -> Bool isSig decl = case decl of - HsTypeSig _ _ _ -> True + TypeSig _ _ _ -> True otherwise -> False -- Extracts a signature from a declaration. @@ -299,7 +308,7 @@ -- | Transforms the components of a Haskell type signature. -- The context is added to the type expression. -mkSignature :: HsName -> HsType -> ErrorOr S.Declaration +mkSignature :: Name -> Type -> ErrorOr S.Declaration mkSignature var ty = do ident <- mkIdentifier var t <- mkTypeExpression ty @@ -311,16 +320,16 @@ -- If the context contains not only variables, but also more complex types, -- this function fails with an appropriate error message. -mkContext :: HsContext -> ErrorOr [(S.TypeClass, S.TypeVariable)] +mkContext :: Context -> ErrorOr [(S.TypeClass, S.TypeVariable)] mkContext = mapM trans where - trans (HsClassA qname [HsTyVar var]) = do + trans (ClassA qname [TyVar var]) = do ident <- liftM S.TC (mkIdentifierQ qname) tv <- mkTypeVariable var return $ (ident, tv) - trans (HsClassA _ _) = throwError errContext - trans (HsIParam _ _) = throwError errImplicit + trans (ClassA _ _) = throwError errContext + trans (IParam _ _) = throwError errImplicit errContext = pp "Only a type variable may be constrained by a class in a context." @@ -339,7 +348,7 @@ -mkTypeExpression :: HsType -> ErrorOr S.TypeExpression +mkTypeExpression :: Type -> ErrorOr S.TypeExpression mkTypeExpression ty = runReaderT (mkTypeExpressionT ty) [] @@ -347,33 +356,43 @@ -- | Transforms a Haskell type. -- Note that a type variable is not allowed to be applied to some type. -mkTypeExpressionT :: HsType -> EnvErrorOr S.TypeExpression -mkTypeExpressionT (HsTyVar var) = liftM S.TypeVar +mkTypeExpressionT :: Type -> EnvErrorOr S.TypeExpression +mkTypeExpressionT (TyVar var) = liftM S.TypeVar (lift (mkTypeVariable var)) -mkTypeExpressionT (HsTyApp ty1 ty2) = lift (mkAppTyEx ty1 [ty2]) -mkTypeExpressionT (HsTyCon qname) = lift (mkTypeConstructorApp qname []) +mkTypeExpressionT (TyApp ty1 ty2) = lift (mkAppTyEx ty1 [ty2]) +mkTypeExpressionT (TyCon qname) = lift (mkTypeConstructorApp qname []) -mkTypeExpressionT (HsTyInfix ty1 qname ty2) = -- infix type constructor - mkTypeExpressionT (HsTyApp (HsTyApp (HsTyCon qname) ty1) ty2) +mkTypeExpressionT (TyInfix ty1 qname ty2) = -- infix type constructor + mkTypeExpressionT (TyApp (TyApp (TyCon qname) ty1) ty2) -mkTypeExpressionT (HsTyFun ty1 ty2) = do +mkTypeExpressionT (TyFun ty1 ty2) = do t1 <- mkTypeExpressionT ty1 t2 <- mkTypeExpressionT ty2 return (S.TypeFun t1 t2) -mkTypeExpressionT (HsTyTuple Boxed tys) = do +mkTypeExpressionT (TyTuple Boxed tys) = do ts <- mapM mkTypeExpressionT tys return (S.TypeCon (S.ConTuple (length ts)) ts) -mkTypeExpressionT (HsTyForall maybeVars ctx ty) = +mkTypeExpressionT (TyForall maybeVars ctx ty) = mkForallTyEx (maybe [] (map unKind) maybeVars) ctx ty - where unKind (HsKindedVar n _) = n - unKind (HsUnkindedVar n) = n + where unKind (KindedVar n _) = n + unKind (UnkindedVar n) = n -mkTypeExpressionT (HsTyPred _) = - throwError (pp "Implicit parameters are not allowed.") +--- daniel +mkTypeExpressionT (TyList ty) = do + t <- mkTypeExpressionT ty + return (S.TypeCon (S.ConList) [t]) -mkTypeExpressionT (HsTyTuple Unboxed _ ) = +mkTypeExpressionT (TyParen ty) = mkTypeExpressionT ty + +mkTypeExpressionT (TyKind ty kd) = + throwError (pp "Explicit kind signatures are not allowed.") + +-- mkTypeExpressionT (TyPred _) = +-- throwError (pp "Implicit parameters are not allowed.") + +mkTypeExpressionT (TyTuple Unboxed _ ) = throwError (pp "Unboxed tuples are not allowed.") @@ -381,7 +400,7 @@ -- | Checks type abstractions for unique variables, merges the contexts and -- creates a type expression. -mkForallTyEx :: [HsName] -> HsContext -> HsType -> EnvErrorOr S.TypeExpression +mkForallTyEx :: [Name] -> Context -> Type -> EnvErrorOr S.TypeExpression mkForallTyEx vars ctx ty = do vs <- unique vars cx <- lift (mkContext ctx) @@ -396,7 +415,7 @@ where -- Checks if the elements of the argument are unique, and throws an error -- otherwise. - unique :: [HsName] -> EnvErrorOr [S.TypeVariable] + unique :: [Name] -> EnvErrorOr [S.TypeVariable] unique [] = return [] unique (v:vs) = if v `elem` vs then throwError (pp $ @@ -420,14 +439,14 @@ -- | Collects applied types and transforms them into a type expression. -mkAppTyEx :: HsType -> [HsType] -> ErrorOr S.TypeExpression +mkAppTyEx :: Type -> [Type] -> ErrorOr S.TypeExpression mkAppTyEx ty tys = case ty of - HsTyFun _ _ -> throwError $ pp ("A function type must not be applied to a " + TyFun _ _ -> throwError $ pp ("A function type must not be applied to a " ++ "type.") - HsTyTuple _ _ -> throwError (pp "A tuple type must not be applied to a type.") - HsTyVar _ -> throwError (pp "A variable must not be applied to a type.") - HsTyApp t1 t2 -> mkAppTyEx t1 (t2 : tys) - HsTyCon qname -> mapM mkTypeExpression tys >>= mkTypeConstructorApp qname + TyTuple _ _ -> throwError (pp "A tuple type must not be applied to a type.") + TyVar _ -> throwError (pp "A variable must not be applied to a type.") + TyApp t1 t2 -> mkAppTyEx t1 (t2 : tys) + TyCon qname -> mapM mkTypeExpression tys >>= mkTypeConstructorApp qname @@ -437,12 +456,12 @@ -- exactly two arguments. mkTypeConstructorApp :: - HsQName + QName -> [S.TypeExpression] -> ErrorOr S.TypeExpression -mkTypeConstructorApp (Special HsFunCon) [t1,t2] = return $ S.TypeFun t1 t2 -mkTypeConstructorApp (Special HsFunCon) _ = throwError errorTypeConstructorApp +mkTypeConstructorApp (Special FunCon) [t1,t2] = return $ S.TypeFun t1 t2 +mkTypeConstructorApp (Special FunCon) _ = throwError errorTypeConstructorApp mkTypeConstructorApp qname ts = liftM (\con -> S.TypeCon con ts) (mkTypeConstructor qname) @@ -456,20 +475,21 @@ -- Special care is taken for primitive types which could be qualified by -- \'Prelude\'. -mkTypeConstructor :: HsQName -> ErrorOr S.TypeConstructor -mkTypeConstructor (Qual (Module mod) hsName) = +mkTypeConstructor :: QName -> ErrorOr S.TypeConstructor +mkTypeConstructor (Qual (ModuleName mod) hsName) = if mod == "Prelude" then return (asCon hsName) else return (S.Con $ hsNameToIdentifier hsName) -mkTypeConstructor (UnQual hsName) = return $ asCon hsName -mkTypeConstructor (Special HsUnitCon) = return $ S.ConUnit -mkTypeConstructor (Special HsListCon) = return $ S.ConList -mkTypeConstructor (Special (HsTupleCon n)) = return $ S.ConTuple n +mkTypeConstructor (UnQual hsName) = return $ asCon hsName +mkTypeConstructor (Special UnitCon) = return $ S.ConUnit +mkTypeConstructor (Special ListCon) = return $ S.ConList +mkTypeConstructor (Special (TupleCon Boxed n)) = return $ S.ConTuple n +mkTypeConstructor (Special (TupleCon Unboxed n)) = throwError $ pp "Unboxed tuples are not allowed." --- missing case '(Special HsFunCon)' cannot occur, +-- missing case '(Special FunCon)' cannot occur, -- see function 'mkTypeCOnstructorApp' --- missing case '(Special HsCons)' cannot occur, +-- missing case '(Special Cons)' cannot occur, -- this is not valid Haskell syntax @@ -477,20 +497,20 @@ -- | Transforms a name into a type constructor. This functions differentiates -- between primitive types and other types. -asCon :: HsName -> S.TypeConstructor +asCon :: Name -> S.TypeConstructor asCon name = case name of - HsIdent "Int" -> S.ConInt - HsIdent "Integer" -> S.ConInteger - HsIdent "Float" -> S.ConFloat - HsIdent "Double" -> S.ConDouble - HsIdent "Char" -> S.ConChar + Ident "Int" -> S.ConInt + Ident "Integer" -> S.ConInteger + Ident "Float" -> S.ConFloat + Ident "Double" -> S.ConDouble + Ident "Char" -> S.ConChar otherwise -> S.Con $ hsNameToIdentifier name -- | Transforms a Haskell name into a type variable. -mkTypeVariable :: HsName -> ErrorOr S.TypeVariable +mkTypeVariable :: Name -> ErrorOr S.TypeVariable mkTypeVariable = return . S.TV . hsNameToIdentifier @@ -501,15 +521,15 @@ -- special Haskell constructor, i.e. a unit, list, function or tuple -- constructor. -mkIdentifierQ :: HsQName -> ErrorOr S.Identifier +mkIdentifierQ :: QName -> ErrorOr S.Identifier mkIdentifierQ (UnQual hsName) = return (hsNameToIdentifier hsName) -mkIdentifierQ (Qual (Module _) hsName) = return (hsNameToIdentifier hsName) +mkIdentifierQ (Qual (ModuleName _) hsName) = return (hsNameToIdentifier hsName) -mkIdentifierQ (Special HsUnitCon) = throwErrorIdentifierQ "`()'" -mkIdentifierQ (Special HsListCon) = throwErrorIdentifierQ "`[]'" -mkIdentifierQ (Special HsFunCon) = throwErrorIdentifierQ "`->'" -mkIdentifierQ (Special HsCons) = throwErrorIdentifierQ "`:'" -mkIdentifierQ (Special (HsTupleCon _)) = throwErrorIdentifierQ "for tuples" +mkIdentifierQ (Special UnitCon) = throwErrorIdentifierQ "`()'" +mkIdentifierQ (Special ListCon) = throwErrorIdentifierQ "`[]'" +mkIdentifierQ (Special FunCon) = throwErrorIdentifierQ "`->'" +mkIdentifierQ (Special Cons) = throwErrorIdentifierQ "`:'" +mkIdentifierQ (Special (TupleCon _ _)) = throwErrorIdentifierQ "for tuples" throwErrorIdentifierQ s = throwError $ pp $ "The constructor " ++ s ++ " must not be used as an identifier." @@ -519,14 +539,14 @@ -- | Transforms a Haskell name into an identifier. -- This function encapsulates 'hsNameToIdentifier' into the 'ErrorOr' monad. -mkIdentifier :: HsName -> ErrorOr S.Identifier +mkIdentifier :: Name -> ErrorOr S.Identifier mkIdentifier = return . hsNameToIdentifier -- | Transforms a Haskell name into an identifier. -hsNameToIdentifier :: HsName -> S.Identifier +hsNameToIdentifier :: Name -> S.Identifier hsNameToIdentifier = S.Ident . hsNameToString @@ -534,9 +554,9 @@ -- | Transforms a Haskell name into a string. -- Haskell symbols are surrounded by parentheses. -hsNameToString :: HsName -> String -hsNameToString (HsIdent s) = s -hsNameToString (HsSymbol s) = "(" ++ s ++ ")" +hsNameToString :: Name -> String +hsNameToString (Ident s) = s +hsNameToString (Symbol s) = "(" ++ s ++ ")" diff --git a/src/Tests.hs b/src/Tests.hs --- a/src/Tests.hs +++ b/src/Tests.hs @@ -25,7 +25,7 @@ doTest name prop = do putStrLn (fixString 75 name ++ ":") putStr " " - check (defaultConfig {configMaxTest = 100}) prop -- quickCheck prop + quickCheckWith (stdArgs {maxSuccess = 100}) prop -- quickCheck prop where fixString :: Int -> String -> String fixString len s =