free-theorems 0.3.1.3 → 0.3.2.0
raw patch · 6 files changed
+161/−111 lines, 6 filesdep ~basedep ~haskell-src-exts
Dependency ranges changed: base, haskell-src-exts
Files
- free-theorems.cabal +4/−5
- src/Arbitraries.hs +31/−0
- src/FrontendCheckLocalTests.hs +1/−1
- src/FrontendOtherTests.hs +1/−1
- src/Language/Haskell/FreeTheorems/Parser/Hsx.hs +123/−103
- src/Tests.hs +1/−1
free-theorems.cabal view
@@ -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
src/Arbitraries.hs view
@@ -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
src/FrontendCheckLocalTests.hs view
@@ -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))
src/FrontendOtherTests.hs view
@@ -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
src/Language/Haskell/FreeTheorems/Parser/Hsx.hs view
@@ -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 ++ ")"
src/Tests.hs view
@@ -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 =