diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,5 +1,9 @@ Significant and compatibility-breaking changes. +Version 0.5: + - model.cabal: relaxed dependent packages upper bounds + - Data.Model.Util: removed properMutualGroups, mutualGroups, transitiveClosure (moved to http://hackage.haskell.org/package/zm) + Version 0.4.4: - minor cabal and documentation fixes diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -121,14 +121,14 @@ -> main.Main.Couple main.Main.Direction -> ghc-prim.GHC.Types.Bool -> Couple Direction Bool -> Environment: --> ghc-prim.GHC.Types.Bool -> Bool ≡ False --> | True --> main.Main.Couple -> Couple a b ≡ Couple a b --> main.Main.Direction -> Direction ≡ North --> | South --> | Center --> | East --> | West +-> ghc-prim.GHC.Types.Bool -> Bool ≡ False +-> | True +-> main.Main.Couple -> Couple a b ≡ Couple a b +-> main.Main.Direction -> Direction ≡ North +-> | South +-> | Center +-> | East +-> | West ``` @@ -143,10 +143,10 @@ -> Type: -> ghc-prim.GHC.Types.[] ghc-prim.GHC.Types.Bool -> [] Bool -> Environment: --> ghc-prim.GHC.Types.Bool -> Bool ≡ False --> | True --> ghc-prim.GHC.Types.[] -> [] a ≡ [] --> | : a (ghc-prim.GHC.Types.[] a) +-> ghc-prim.GHC.Types.Bool -> Bool ≡ False +-> | True +-> ghc-prim.GHC.Types.[] -> [] a ≡ [] +-> | : a (ghc-prim.GHC.Types.[] a) ``` @@ -156,7 +156,7 @@ ### Compatibility -Tested with [ghc](https://www.haskell.org/ghc/) 7.10.3, 8.0.1, 8.0.2 and 8.2.1. +Tested with [ghc](https://www.haskell.org/ghc/) 7.10.3, 8.0.2, 8.2.2, 8.4.4 and 8.6.5. ### Known Bugs and Infelicities diff --git a/model.cabal b/model.cabal --- a/model.cabal +++ b/model.cabal @@ -1,8 +1,8 @@ name: model -version: 0.4.4 +version: 0.5 synopsis: Derive a model of a data type using Generics -description: See the . -homepage: http://github.com/tittoassini/model +description: See the . +homepage: http://github.com/Quid2/model license: BSD3 license-file: LICENSE author: Pasqualino `Titto` Assini @@ -11,12 +11,12 @@ category: Data,Reflection,Generics build-type: Simple cabal-version: >=1.10 -Tested-With: GHC == 7.10.3 GHC == 8.0.1 GHC == 8.0.2 GHC == 8.2.2 +Tested-With: GHC == 7.10.3 GHC == 8.0.2 GHC == 8.2.2 GHC == 8.4.4 GHC == 8.6.5 extra-source-files: stack.yaml,README.md,CHANGELOG source-repository head type: git - location: https://github.com/tittoassini/model + location: https://github.com/Quid2/model library hs-source-dirs: src @@ -28,15 +28,17 @@ , Data.Model.Types , Data.Model.Util , Type.ANat,Type.Analyse + , Data.Convertible.Tiny + -- other-modules: Data.Convertible.Base,Data.Convertible.Instances.Text,Data.Convertible.Instances.Num,Data.Convertible.Utils build-depends: base >= 4.8 && < 5 - , containers == 0.5.* + , containers , either > 4.3.2 && <6 - , deepseq == 1.4.* + , deepseq , transformers >= 0.4.2.0 && < 0.6 - , pretty >= 1.1.2 && < 1.2 - , convertible == 1.1.* + , pretty >= 1.1.2 + --, text , bytestring + , convertible >= 1.1.1.0 && < 1.2 default-language: Haskell2010 - other-extensions: DataKinds, DefaultSignatures, DeriveAnyClass, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, FlexibleContexts, FlexibleInstances, NoMonomorphismRestriction, OverloadedStrings, PolyKinds, ScopedTypeVariables, TupleSections, TypeFamilies, TypeOperators, UndecidableInstances ghc-options: -Wall -fno-warn-orphans test-suite model-test @@ -49,9 +51,8 @@ , containers , model , ghc-prim - , tasty >= 0.11 && < 0.13 - , tasty-hunit >= 0.8 && < 0.11 - , tasty-quickcheck >=0.8.1 && < 0.9.2 + , tasty >= 0.11 + , tasty-hunit >= 0.8 default-language: Haskell2010 @@ -60,5 +61,5 @@ type: exitcode-stdio-1.0 ghc-options: -threaded main-is: DocSpec.hs - build-depends: base, doctest>=0.11.1 && <0.14,filemanip>=0.3.6.3 && < 0.3.7,model + build-depends: base, doctest>=0.11.2,filemanip>=0.3.6.3,model HS-Source-Dirs: test diff --git a/src/Data/Convertible/Tiny.hs b/src/Data/Convertible/Tiny.hs new file mode 100644 --- /dev/null +++ b/src/Data/Convertible/Tiny.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE MultiParamTypeClasses ,FlexibleInstances #-} +module Data.Convertible.Tiny ( -- * The conversion process +convert, +Convertible(..), +-- * Handling the results +ConvertResult, +ConvertError(..), +convError, +prettyConvertError +) where + +import Data.Convertible.Base +import Data.Convertible.Instances.Text() +import Data.Convertible.Instances.Num() + +{- | Any type can be converted to itself. -} +instance Convertible a a where safeConvert = return + diff --git a/src/Data/Model/Class.hs b/src/Data/Model/Class.hs --- a/src/Data/Model/Class.hs +++ b/src/Data/Model/Class.hs @@ -4,6 +4,7 @@ {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} module Data.Model.Class( typeModel @@ -83,7 +84,7 @@ inCtx <- enterCtx qname unless inCtx $ do ct <- mct - addDef qname $ ADT uname (fromIntegral $ length ts) $ ct + addDef qname $ ADT uname (fromIntegral $ length ts) ct closeCtx return . TypeCon . TypRef $ qname @@ -124,7 +125,7 @@ where toE (ls,[]) = Left ls toE ([],rs) = Right rs - toE p = error . unwords $ ["toE: unexpected parameter",show p] + toE p = error . unwords $ ["toE: unexpected parameter",show p] gtype = notThere gtypeN = notThere diff --git a/src/Data/Model/Pretty.hs b/src/Data/Model/Pretty.hs --- a/src/Data/Model/Pretty.hs +++ b/src/Data/Model/Pretty.hs @@ -2,7 +2,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} + -- |Pretty instances for the model types module Data.Model.Pretty( CompactPretty(..) @@ -10,6 +10,8 @@ ,dottedP,spacedP,vspacedP,varP,varC -- *Re-exports ,Pretty(..),prettyShow + + ,prettyADT ) where import Data.Char @@ -18,9 +20,10 @@ import Data.Model.Types import Data.Model.Util import Text.PrettyPrint.HughesPJClass +import qualified Text.PrettyPrint.HughesPJClass as P -- |Compact representation: a value enveloped in CompactPretty will have only its first lines displayed -data CompactPretty a = CompactPretty a +newtype CompactPretty a = CompactPretty a instance Pretty a => Pretty (CompactPretty a) where pPrint (CompactPretty a) = text . shorter . prettyShow $ a @@ -47,10 +50,10 @@ instance (Pretty n,Pretty cn,Pretty r) => Pretty (ADT n cn r) where pPrint = prettyADT "" '≡' prettyADT :: (Pretty name, Pretty consName, Pretty ref) => String -> Char -> ADT name consName ref -> Doc -prettyADT pre eq adt = text pre <+> pPrint (declName adt) <+> vars adt <+> maybe (text "") (\c -> char eq <+> pPrint c) (declCons adt) +prettyADT pre eq adt = text pre P.<> pPrint (declName adt) <+> vars adt <+> maybe (text "") (\c -> char eq <+> pPrint c) (declCons adt) vars :: ADT name consName ref -> Doc -vars adt = sep . map varP . map (\x -> x-1) $ [1 .. declNumParameters adt] +vars adt = sep . map (varP . (\x -> x-1)) $ [1 .. declNumParameters adt] -- |Convert a variable number (0,1,..) to a name ('a','b',..) varP :: Integral n => n -> Doc @@ -58,7 +61,7 @@ -- |Convert a variable number (0,1,..) to a name ('a','b',..) varC :: Integral a => a -> Char -varC n = chr ( (ord 'a') + (fromIntegral n)) +varC n = chr (ord 'a' + fromIntegral n) instance (Pretty name,Pretty ref) => Pretty (ConTree name ref) where pPrint conTree = let (h:t) = constructors conTree @@ -69,7 +72,7 @@ instance {-# OVERLAPS #-} (Pretty name,Pretty ref) => Pretty (Fields name ref) where pPrint (Left fs) = sep (map (printPrettyType True) fs) - pPrint (Right nfs) = "{" <> sep (punctuate "," (map (\(nm,t) -> pPrint nm <+> "::" <+> pPrint t) nfs)) <> "}" + pPrint (Right nfs) = "{" P.<> sep (punctuate "," (map (\(nm,t) -> pPrint nm <+> "::" <+> pPrint t) nfs)) P.<> "}" instance Pretty n => Pretty (TypeRef n) where pPrint (TypVar v) = varP v diff --git a/src/Data/Model/Types.hs b/src/Data/Model/Types.hs --- a/src/Data/Model/Types.hs +++ b/src/Data/Model/Types.hs @@ -182,9 +182,9 @@ instance Traversable (ConTree name) where traverse f (ConTree l r) = ConTree <$> traverse f l <*> traverse f r - traverse f (Con n (Left ts)) = Con n . Left <$> sequenceA (map (traverse f) ts) + traverse f (Con n (Left ts)) = Con n . Left <$> traverse (traverse f) ts -- TODO: simplify this - traverse f (Con n (Right nts)) = Con n . Right . zip (map fst nts) <$> sequenceA (map (traverse f . snd) nts) + traverse f (Con n (Right nts)) = Con n . Right . zip (map fst nts) <$> traverse (traverse f . snd) nts -- |Map on the constructor types (used for example when eliminating variables) conTreeTypeMap :: (Type t -> Type ref) -> ConTree name t -> ConTree name ref @@ -331,7 +331,7 @@ in QualName p m (reverse l) -- |Simple name -data Name = Name String deriving (Eq, Ord, Show, NFData, Generic) +newtype Name = Name String deriving (Eq, Ord, Show, NFData, Generic) -- Utilities -- |Solve all references in a data structure, using the given environment diff --git a/src/Data/Model/Util.hs b/src/Data/Model/Util.hs --- a/src/Data/Model/Util.hs +++ b/src/Data/Model/Util.hs @@ -5,11 +5,11 @@ {-# LANGUAGE TypeSynonymInstances #-} module Data.Model.Util ( -- * Dependencies - properMutualGroups - , mutualGroups - , transitiveClosure + -- properMutualGroups + -- , mutualGroups + -- , transitiveClosure -- * Error utilities - , Errors + Errors , toErrors , noErrors , errsInContext @@ -28,66 +28,12 @@ , dotted ) where -import Control.Monad -import Control.Monad.Trans.State import Data.Bifunctor import Data.Convertible -import Data.Foldable (toList) -import Data.List -import qualified Data.Map.Lazy as M -import Data.Maybe +import Data.Convertible.Tiny() import Data.Typeable -import Text.PrettyPrint.HughesPJClass (Pretty, prettyShow) - -{-| Return the groups of mutually dependent entities, with more than one component - ->>> properMutualGroups Just (M.fromList [("a",["b","c"]),("b",["a","c"]),("c",[])]) -Right [["b","a"]] - --} -properMutualGroups :: (Ord r, Pretty r, Foldable t) => (a -> Maybe r) -> M.Map r (t a) -> Either [String] [[r]] -properMutualGroups getRef env = filter ((> 1) . length) <$> mutualGroups getRef env - -{-| Return the groups of mutually dependent entities - ->>> mutualGroups Just (M.fromList [("a",["b","c"]),("b",["a","c"]),("c",[])]) -Right [["c"],["b","a"]] - --} -mutualGroups :: (Ord r, Pretty r, Foldable t) => (a -> Maybe r) -> M.Map r (t a) -> Either [String] [[r]] -mutualGroups getRef env = recs [] (M.keys env) - where - deps = transitiveClosure getRef env - recs gs [] = return gs - recs gs (n:ns) = do - ds <- deps n - mutual <- filterM (((n `elem`) <$>) . deps) ds - recs (mutual:gs) (ns \\ mutual) - -{-| Return the transitive closure of an element in a graph of dependencies specified as an adjacency list - ->>> transitiveClosure Just (M.fromList [("a",["b","c"]),("b",["b","d","d","c"]),("c",[]),("d",["a"])]) "b" -Right ["c","a","d","b"] - ->>> transitiveClosure Just (M.fromList [("a",["b","c"]),("b",["b","d","d","c"]),("c",[]),("d",["a"])]) "c" -Right ["c"] - --} -transitiveClosure :: (Foldable t, Pretty r, Ord r) => (a -> Maybe r) -> M.Map r (t a) -> r -> Either [String] [r] -transitiveClosure getRef env = execRec . deps - where - deps n = do - present <- (n `elem`) <$> gets seen - unless present $ do - modify (\st -> st {seen=n:seen st}) - case M.lookup n env of - Nothing -> modify (\st -> st {errors=unwords ["transitiveClosure:Unknown reference to",prettyShow n]:errors st}) - Just v -> mapM_ deps (mapMaybe getRef . toList $ v) - -execRec :: State (RecState r) a -> Either [String] [r] -execRec op = (\st -> if null (errors st) then Right (seen st) else Left (errors st)) $ execState op (RecState [] []) - -data RecState r = RecState {seen::[r],errors::Errors} deriving Show +import Data.List +-- import Text.PrettyPrint.HughesPJClass (Pretty, prettyShow) -- |A list of error messages type Errors = [Error] @@ -95,27 +41,37 @@ type Error = String toErrors :: Bifunctor p => p a c -> p [a] c -toErrors = first (:[]) +toErrors = first (: []) noErrors :: Errors -> Bool noErrors = null -errorToConvertResult :: (Typeable b, Typeable a, Show a) => (a -> Either Error b) -> a -> ConvertResult b -errorToConvertResult conv a = either (\err -> convError err a) Right $ conv a +errorToConvertResult + :: (Typeable b, Typeable a, Show a) + => (a -> Either Error b) + -> a + -> ConvertResult b +errorToConvertResult conv a = either (`convError` a) Right $ conv a {-| >>> errorsToConvertResult (const (Left ["Bad format","Invalid value"])) ".." :: ConvertResult Int Left (ConvertError {convSourceValue = "\"..\"", convSourceType = "[Char]", convDestType = "Int", convErrorMessage = "Bad format, Invalid value"}) -} -errorsToConvertResult :: (Typeable b, Typeable t, Show t) => (t -> Either Errors b) -> t -> ConvertResult b -errorsToConvertResult conv a = either (\errs -> convError (intercalate ", " errs) a) Right $ conv a +errorsToConvertResult + :: (Typeable b, Typeable t, Show t) + => (t -> Either Errors b) + -> t + -> ConvertResult b +errorsToConvertResult conv a = + either (\errs -> convError (intercalate ", " errs) a) Right $ conv a {-| +>>> import Data.Word >>> convertOrError 'a' :: Either Error Word Right 97 ->>> convertOrError (1E50::Double) :: Either Error Word -Left "Convertible: error converting source data 1.0e50 of type Double to type Word: Input value outside of bounds: (0,18446744073709551615)" +>>> convertOrError (1E50::Double) :: Either Error Word64 +Left "Convertible: error converting source data 1.0e50 of type Double to type Word64: Input value outside of bounds: (0,18446744073709551615)" -} convertOrError :: Convertible a c => a -> Either String c convertOrError = convertResultToError . safeConvert @@ -126,10 +82,15 @@ convertResultToErrors :: Bifunctor p => p ConvertError c -> p [String] c convertResultToErrors = toErrors . convertResultToError -instance Convertible String String where safeConvert = Right . id +--instance Convertible String String where safeConvert = Right +-- instance Convertible a a where safeConvert = Right -- |Prefix errors with a contextual note -errsInContext :: (Convertible ctx String, Bifunctor p) => ctx -> p [String] c -> p [String] c +errsInContext + :: (Convertible ctx String, Bifunctor p) + => ctx + -> p [String] c + -> p [String] c errsInContext ctx = first (inContext ctx) {-|Prefix a list of strings with a contextual note @@ -138,7 +99,7 @@ ["In 0/0: Zero denominator"] -} inContext :: Convertible ctx String => ctx -> [String] -> [String] -inContext ctx = map (\msg -> unwords ["In",convert ctx++":",msg]) +inContext ctx = map (\msg -> unwords ["In", convert ctx ++ ":", msg]) {-| Intercalate a dot between the non empty elements of a list of strings. @@ -153,9 +114,9 @@ -} dotted :: [String] -> String -- dotted = intercalate "." . filter (not . null) -dotted [] = "" -dotted [s] = s +dotted [] = "" +dotted [s ] = s dotted (h:t) = post h ++ dotted t - where post s | null s = "" - | otherwise = s ++ "." - + where + post s | null s = "" + | otherwise = s ++ "." diff --git a/src/Type/Analyse.hs b/src/Type/Analyse.hs --- a/src/Type/Analyse.hs +++ b/src/Type/Analyse.hs @@ -17,16 +17,23 @@ Examples: ->> undefined :: Ana (Maybe Char) -undefined :: Ana (Maybe Char) :: App (Typ (Maybe A0)) (Typ Char) +>>> :kind! Ana (Maybe Bool) +Ana (Maybe Bool) :: * += App (Typ (Maybe A0)) (Typ Bool) ->> undefined :: Ana (Either Int Char) -undefined :: Ana (Either Int Char) - :: App (App (Typ (Either A0 A1)) (Typ Int)) (Typ Char) +>>> :kind! Ana (Maybe Char) +Ana (Maybe Char) :: * += App (Typ (Maybe A0)) (Typ Char) ->> undefined :: Ana ([(Bool,())]) -undefined :: Ana ([(Bool,())]) - :: App (Typ [A0]) (App (App (Typ (A0, A1)) (Typ Bool)) (Typ ())) +>>> :kind! Ana (Either Int (Maybe Bool)) +Ana (Either Int (Maybe Bool)) :: * += App + (App (Typ (Either A0 A1)) (Typ Int)) + (App (Typ (Maybe A0)) (Typ Bool)) + +>>> :kind! Ana ([(Bool,())]) +Ana ([(Bool,())]) :: * += App (Typ [A0]) (App (App (Typ (A0, A1)) (Typ Bool)) (Typ ())) -} type family Ana t where Ana (f a0 a1 a2 a3 a4 a5 a6 a7 a8) = App (App (App (App (App (App (App (App (App (Typ (f A0 A1 A2 A3 A4 A5 A6 A7 A8 )) (Ana a0)) (Ana a1)) (Ana a2)) (Ana a3)) (Ana a4)) (Ana a5)) (Ana a6)) (Ana a7)) (Ana a8) @@ -39,8 +46,6 @@ Ana (f a0 a1) = App (App (Typ (f A0 A1 )) (Ana a0)) (Ana a1) Ana (f a0) = App (Typ (f A0 )) (Ana a0) Ana a = Typ a - --- Problem: in Ana (Either Char Int) -> Ana (f a) f==Either Char a=Int -- |Type application data App f a diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,8 @@ -resolver: lts-9.17 +#resolver: lts-6.35 +#resolver: lts-9.14 +#resolver: lts-11.22 +#resolver: lts-12.26 +resolver: lts-13.22 packages: - '.' diff --git a/test/DocSpec.hs b/test/DocSpec.hs --- a/test/DocSpec.hs +++ b/test/DocSpec.hs @@ -1,7 +1,21 @@ module Main where -import Test.DocTest + +import Data.List (isSuffixOf) import System.FilePath.Find +import Test.DocTest main :: IO () --- main = find always ((extension ==? ".hs") ||? (extension ==? ".lhs")) "src" >>= doctest -main = find always (extension ==? ".hs") "src" >>= doctest +-- main = find always ((extension ==? ".hs") &&? exceptFiles ["Data/Convertible/Base.hs","Data/Convertible/Utils.hs","Data/Convertible/Instances/Num.hs"]) "src" >>= doctest +main = + find + always + ((extension ==? ".hs") &&? exceptFiles ["Dataset.hs", "Test.hs", "Main.hs"]) + "src" >>= + doctest + +exceptFiles :: Foldable t => t String -> FindClause Bool +exceptFiles mdls + -- let excludes = liftOp (\fp mdls -> not $ any (\mdl -> isSuffixOf mdl (traceShowId fp)) mdls) + = + let excludes = liftOp (\fp modules -> not $ any (`isSuffixOf` fp) modules) + in filePath `excludes` mdls diff --git a/test/Info.hs b/test/Info.hs --- a/test/Info.hs +++ b/test/Info.hs @@ -5,30 +5,44 @@ {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE ScopedTypeVariables #-} -module Info(modelTests) where +module Info + ( modelTests + ) +where import Data.Model import Data.Word import qualified GHC.Base import Test.Data -import Test.Data.Model () +import Test.Data.Model ( ) import qualified Test.Data2 import qualified Test.Data3 import qualified Data.Either import Data.List -import qualified Data.Map as M +import qualified Data.Map as M import Test.Tasty import Test.Tasty.HUnit -testSimpleModel :: AsType (Ana a) => Proxy a -> (Type (TypeRef Name), [ADT String String (TypeRef Name)]) -> TestTree -testSimpleModel p e = let tm = typeModel p - s = prettyShow . simpleType $ typeName tm - in testCase (unwords ["simple typeModel of",s]) $ simpleHTypeEnv tm @?= e +testSimpleModel + :: AsType (Ana a) + => Proxy a + -> (Type (TypeRef Name), [ADT String String (TypeRef Name)]) + -> TestTree +testSimpleModel p e = + let tm = typeModel p + s = prettyShow . simpleType $ typeName tm + in testCase (unwords ["simple typeModel of", s]) $ simpleHTypeEnv tm @?= e -testModel :: AsType (Ana a) => Proxy a -> (Type QualName, [(QualName, ADT String String (TypeRef QualName))]) -> TestTree -testModel p (etn,ete) = +testModel + :: AsType (Ana a) + => Proxy a + -> (Type QualName, [(QualName, ADT String String (TypeRef QualName))]) + -> TestTree +testModel p (etn, ete) = let tm = typeModel p - s = prettyShow . simpleType $ typeName tm - in testCase (unwords ["typeModel of",s]) $ tm @?= TypeModel etn (M.fromList ete) + s = prettyShow . simpleType $ typeName tm + in testCase (unwords ["typeModel of", s]) $ tm @?= TypeModel + etn + (M.fromList ete) models :: [HTypeModel] models = @@ -54,11 +68,11 @@ , typeModel (Proxy :: Proxy (Test.Data2.List Bool)) , typeModel (Proxy :: Proxy (Test.Data3.List Bool)) , typeModel (Proxy :: Proxy (List (Test.Data2.List (Test.Data3.List Bool)))) - , typeModel (Proxy :: Proxy (Maybe Void)) + , typeModel (Proxy :: Proxy (Either Void Bool)) , typeModel (Proxy :: Proxy (Either Bool Unit)) , typeModel (Proxy :: Proxy (RR Un Unit N)) , typeModel (Proxy :: Proxy (Either Bool (List Unit))) - , typeModel (Proxy :: Proxy (Tr (Maybe Unit))) + , typeModel (Proxy :: Proxy (Tr (Either Unit N))) , typeModel (Proxy :: Proxy (Perfect Bool)) -- Unsupported: higher kind --,typeModel (Proxy :: Proxy (PerfectF Maybe Bool)) @@ -66,12 +80,14 @@ ] --------- Some (fake) instance declaration for primitive types, for testing only -instance Model Char where envType _ = envType (Proxy::Proxy CharSI) +instance Model Char where + envType _ = envType (Proxy :: Proxy CharSI) data CharSI deriving Generic instance Model CharSI -- Provide models for Word8 .. using stand-in classes -instance Model Word8 where envType _ = envType (Proxy::Proxy Word8SI) +instance Model Word8 where + envType _ = envType (Proxy :: Proxy Word8SI) data Word8SI deriving Generic instance Model Word8SI @@ -85,19 +101,26 @@ ----- Pretty printing -- Simplify types for test -simpleHTypeEnv :: Ord consName => TypeModel name consName HTypeRef QualName -> (Type (TypeRef Name), [ADT String consName (TypeRef Name)]) -simpleHTypeEnv tm = (simpleType $ typeName tm - ,sort . map simpleADT $ M.assocs $ typeEnv tm) +simpleHTypeEnv + :: Ord consName + => TypeModel name consName HTypeRef QualName + -> (Type (TypeRef Name), [ADT String consName (TypeRef Name)]) +simpleHTypeEnv tm = + (simpleType $ typeName tm, sort . map simpleADT $ M.assocs $ typeEnv tm) -hTypeEnv :: TypeModel adtName consName inRef k -> (Type k, [(k, ADT adtName consName inRef)]) -hTypeEnv tm = (typeName tm - ,M.toList $ typeEnv tm) +hTypeEnv + :: TypeModel adtName consName inRef k + -> (Type k, [(k, ADT adtName consName inRef)]) +hTypeEnv tm = (typeName tm, M.toList $ typeEnv tm) simpleType :: Functor f => f QualName -> f (TypeRef Name) simpleType = (TypRef . asName <$>) -simpleADT :: (QualName, ADT name consName HTypeRef) -> ADT String consName (TypeRef Name) -simpleADT (qname,adt) = ADT (qualName qname) (declNumParameters adt) ((mdlRef <$>) <$> declCons adt) +simpleADT + :: (QualName, ADT name consName HTypeRef) + -> ADT String consName (TypeRef Name) +simpleADT (qname, adt) = + ADT (qualName qname) (declNumParameters adt) ((mdlRef <$>) <$> declCons adt) mdlRef :: HTypeRef -> TypeRef Name mdlRef (TypVar v) = TypVar v @@ -105,7 +128,7 @@ asName :: QualName -> Name asName qn | mdlName qn == "GHC.Types" = Name $ locName qn -asName n = Name . qualName $ n +asName n = Name . qualName $ n pr :: Show a => a -> IO () pr = print @@ -121,20 +144,52 @@ -- makeTest ts = appendFile thisFile $ ("\n-- Appended by makeTest\nmodelTests = testGroup \"Unit tests\" [" ++ (intercalate "\n\n ," $ map (\tm -> unwords ["testModel (Proxy :: Proxy (",prettyShow . simpleType . typeName $ tm,")) (",show . simpleHTypeEnv $ tm,")"]) ts)) ++ " ]" -makeSimpleTest :: (Ord consName, Show consName) => [TypeModel name consName HTypeRef QualName] -> IO () -makeSimpleTest ts = appendFile thisFile $ ("\n-- Appended by makeTest\nmodelTests = testGroup \"Unit tests\" [" ++ (intercalate "\n\n ," $ map (\tm -> unwords ["testModel (Proxy :: Proxy (",prettyShow . simpleType . typeName $ tm,")) (",show . simpleHTypeEnv $ tm,")"]) ts)) ++ " ]" +makeSimpleTest + :: (Ord consName, Show consName) + => [TypeModel name consName HTypeRef QualName] + -> IO () +makeSimpleTest ts = + appendFile thisFile + $ ( "\n-- Appended by makeTest\nmodelTests = testGroup \"Unit tests\" [" + ++ (intercalate "\n\n ," $ map + (\tm -> unwords + [ "testModel (Proxy :: Proxy (" + , prettyShow . simpleType . typeName $ tm + , ")) (" + , show . simpleHTypeEnv $ tm + , ")" + ] + ) + ts + ) + ) + ++ " ]" -makeTest :: (Show adtName, Show inRef, Show consName) => [TypeModel adtName consName inRef QualName] -> IO () -makeTest ts = appendFile thisFile $ ("\n-- Appended by makeTest\nmodelTests = testGroup \"Unit tests\" [" ++ (intercalate "\n\n ," $ map (\tm -> unwords ["testModel (Proxy :: Proxy (",prettyShow . simpleType . typeName $ tm,")) (",show . hTypeEnv $ tm,")"]) ts)) ++ " ]" +makeTest + :: (Show adtName, Show inRef, Show consName) + => [TypeModel adtName consName inRef QualName] + -> IO () +makeTest ts = + appendFile thisFile + $ ( "\n-- Appended by makeTest\nmodelTests = testGroup \"Unit tests\" [" + ++ (intercalate "\n\n ," $ map + (\tm -> unwords + [ "testModel (Proxy :: Proxy (" + , prettyShow . simpleType . typeName $ tm + , ")) (" + , show . hTypeEnv $ tm + , ")" + ] + ) + ts + ) + ) + ++ " ]" -- modelTests = undefined - - - -- Appended by makeTest -modelTests :: TestTree modelTests = testGroup "Unit tests" [testModel (Proxy :: Proxy ( Test.Data.Void )) ( (TypeCon (QualName {pkgName = "main", mdlName = "Test.Data", locName = "Void"}),[(QualName {pkgName = "main", mdlName = "Test.Data", locName = "Void"},ADT {declName = "Void", declNumParameters = 0, declCons = Nothing})]) ) ,testModel (Proxy :: Proxy ( Test.Data.Unit )) ( (TypeCon (QualName {pkgName = "main", mdlName = "Test.Data", locName = "Unit"}),[(QualName {pkgName = "main", mdlName = "Test.Data", locName = "Unit"},ADT {declName = "Unit", declNumParameters = 0, declCons = Just (Con {constrName = "Unit", constrFields = Left []})})]) ) @@ -169,7 +224,7 @@ ,testModel (Proxy :: Proxy ( Test.Data.List (Test.Data2.List (Test.Data3.List Bool)) )) ( (TypeApp (TypeCon (QualName {pkgName = "main", mdlName = "Test.Data", locName = "List"})) (TypeApp (TypeCon (QualName {pkgName = "main", mdlName = "Test.Data2", locName = "List"})) (TypeApp (TypeCon (QualName {pkgName = "main", mdlName = "Test.Data3", locName = "List"})) (TypeCon (QualName {pkgName = "ghc-prim", mdlName = "GHC.Types", locName = "Bool"})))),[(QualName {pkgName = "ghc-prim", mdlName = "GHC.Types", locName = "Bool"},ADT {declName = "Bool", declNumParameters = 0, declCons = Just (ConTree (Con {constrName = "False", constrFields = Left []}) (Con {constrName = "True", constrFields = Left []}))}),(QualName {pkgName = "main", mdlName = "Test.Data", locName = "List"},ADT {declName = "List", declNumParameters = 1, declCons = Just (ConTree (Con {constrName = "C", constrFields = Left [TypeCon (TypVar 0),TypeApp (TypeCon (TypRef (QualName {pkgName = "main", mdlName = "Test.Data", locName = "List"}))) (TypeCon (TypVar 0))]}) (Con {constrName = "N", constrFields = Left []}))}),(QualName {pkgName = "main", mdlName = "Test.Data2", locName = "List"},ADT {declName = "List", declNumParameters = 1, declCons = Just (ConTree (Con {constrName = "Cons2", constrFields = Left [TypeCon (TypVar 0),TypeApp (TypeCon (TypRef (QualName {pkgName = "main", mdlName = "Test.Data2", locName = "List"}))) (TypeCon (TypVar 0))]}) (Con {constrName = "Nil2", constrFields = Left []}))}),(QualName {pkgName = "main", mdlName = "Test.Data3", locName = "List"},ADT {declName = "List", declNumParameters = 1, declCons = Just (ConTree (Con {constrName = "C", constrFields = Left [TypeCon (TypVar 0),TypeApp (TypeCon (TypRef (QualName {pkgName = "main", mdlName = "Test.Data3", locName = "List"}))) (TypeCon (TypVar 0))]}) (Con {constrName = "N", constrFields = Left []}))})]) ) - ,testModel (Proxy :: Proxy ( GHC.Base.Maybe Test.Data.Void )) ( (TypeApp (TypeCon (QualName {pkgName = "base", mdlName = "GHC.Base", locName = "Maybe"})) (TypeCon (QualName {pkgName = "main", mdlName = "Test.Data", locName = "Void"})),[(QualName {pkgName = "base", mdlName = "GHC.Base", locName = "Maybe"},ADT {declName = "Maybe", declNumParameters = 1, declCons = Just (ConTree (Con {constrName = "Nothing", constrFields = Left []}) (Con {constrName = "Just", constrFields = Left [TypeCon (TypVar 0)]}))}),(QualName {pkgName = "main", mdlName = "Test.Data", locName = "Void"},ADT {declName = "Void", declNumParameters = 0, declCons = Nothing})]) ) + ,testModel (Proxy :: Proxy ( Data.Either.Either Test.Data.Void Bool )) ( (TypeApp (TypeApp (TypeCon (QualName {pkgName = "base", mdlName = "Data.Either", locName = "Either"})) (TypeCon (QualName {pkgName = "main", mdlName = "Test.Data", locName = "Void"}))) (TypeCon (QualName {pkgName = "ghc-prim", mdlName = "GHC.Types", locName = "Bool"})),[(QualName {pkgName = "base", mdlName = "Data.Either", locName = "Either"},ADT {declName = "Either", declNumParameters = 2, declCons = Just (ConTree (Con {constrName = "Left", constrFields = Left [TypeCon (TypVar 0)]}) (Con {constrName = "Right", constrFields = Left [TypeCon (TypVar 1)]}))}),(QualName {pkgName = "ghc-prim", mdlName = "GHC.Types", locName = "Bool"},ADT {declName = "Bool", declNumParameters = 0, declCons = Just (ConTree (Con {constrName = "False", constrFields = Left []}) (Con {constrName = "True", constrFields = Left []}))}),(QualName {pkgName = "main", mdlName = "Test.Data", locName = "Void"},ADT {declName = "Void", declNumParameters = 0, declCons = Nothing})]) ) ,testModel (Proxy :: Proxy ( Data.Either.Either Bool Test.Data.Unit )) ( (TypeApp (TypeApp (TypeCon (QualName {pkgName = "base", mdlName = "Data.Either", locName = "Either"})) (TypeCon (QualName {pkgName = "ghc-prim", mdlName = "GHC.Types", locName = "Bool"}))) (TypeCon (QualName {pkgName = "main", mdlName = "Test.Data", locName = "Unit"})),[(QualName {pkgName = "base", mdlName = "Data.Either", locName = "Either"},ADT {declName = "Either", declNumParameters = 2, declCons = Just (ConTree (Con {constrName = "Left", constrFields = Left [TypeCon (TypVar 0)]}) (Con {constrName = "Right", constrFields = Left [TypeCon (TypVar 1)]}))}),(QualName {pkgName = "ghc-prim", mdlName = "GHC.Types", locName = "Bool"},ADT {declName = "Bool", declNumParameters = 0, declCons = Just (ConTree (Con {constrName = "False", constrFields = Left []}) (Con {constrName = "True", constrFields = Left []}))}),(QualName {pkgName = "main", mdlName = "Test.Data", locName = "Unit"},ADT {declName = "Unit", declNumParameters = 0, declCons = Just (Con {constrName = "Unit", constrFields = Left []})})]) ) @@ -177,6 +232,6 @@ ,testModel (Proxy :: Proxy ( Data.Either.Either Bool (Test.Data.List Test.Data.Unit) )) ( (TypeApp (TypeApp (TypeCon (QualName {pkgName = "base", mdlName = "Data.Either", locName = "Either"})) (TypeCon (QualName {pkgName = "ghc-prim", mdlName = "GHC.Types", locName = "Bool"}))) (TypeApp (TypeCon (QualName {pkgName = "main", mdlName = "Test.Data", locName = "List"})) (TypeCon (QualName {pkgName = "main", mdlName = "Test.Data", locName = "Unit"}))),[(QualName {pkgName = "base", mdlName = "Data.Either", locName = "Either"},ADT {declName = "Either", declNumParameters = 2, declCons = Just (ConTree (Con {constrName = "Left", constrFields = Left [TypeCon (TypVar 0)]}) (Con {constrName = "Right", constrFields = Left [TypeCon (TypVar 1)]}))}),(QualName {pkgName = "ghc-prim", mdlName = "GHC.Types", locName = "Bool"},ADT {declName = "Bool", declNumParameters = 0, declCons = Just (ConTree (Con {constrName = "False", constrFields = Left []}) (Con {constrName = "True", constrFields = Left []}))}),(QualName {pkgName = "main", mdlName = "Test.Data", locName = "List"},ADT {declName = "List", declNumParameters = 1, declCons = Just (ConTree (Con {constrName = "C", constrFields = Left [TypeCon (TypVar 0),TypeApp (TypeCon (TypRef (QualName {pkgName = "main", mdlName = "Test.Data", locName = "List"}))) (TypeCon (TypVar 0))]}) (Con {constrName = "N", constrFields = Left []}))}),(QualName {pkgName = "main", mdlName = "Test.Data", locName = "Unit"},ADT {declName = "Unit", declNumParameters = 0, declCons = Just (Con {constrName = "Unit", constrFields = Left []})})]) ) - ,testModel (Proxy :: Proxy ( Test.Data.Tr (GHC.Base.Maybe Test.Data.Unit) )) ( (TypeApp (TypeCon (QualName {pkgName = "main", mdlName = "Test.Data", locName = "Tr"})) (TypeApp (TypeCon (QualName {pkgName = "base", mdlName = "GHC.Base", locName = "Maybe"})) (TypeCon (QualName {pkgName = "main", mdlName = "Test.Data", locName = "Unit"}))),[(QualName {pkgName = "base", mdlName = "GHC.Base", locName = "Maybe"},ADT {declName = "Maybe", declNumParameters = 1, declCons = Just (ConTree (Con {constrName = "Nothing", constrFields = Left []}) (Con {constrName = "Just", constrFields = Left [TypeCon (TypVar 0)]}))}),(QualName {pkgName = "main", mdlName = "Test.Data", locName = "Forest"},ADT {declName = "Forest", declNumParameters = 1, declCons = Just (Con {constrName = "Forest", constrFields = Left [TypeApp (TypeCon (TypRef (QualName {pkgName = "main", mdlName = "Test.Data", locName = "List"}))) (TypeApp (TypeCon (TypRef (QualName {pkgName = "main", mdlName = "Test.Data", locName = "Tr"}))) (TypeCon (TypVar 0)))]})}),(QualName {pkgName = "main", mdlName = "Test.Data", locName = "List"},ADT {declName = "List", declNumParameters = 1, declCons = Just (ConTree (Con {constrName = "C", constrFields = Left [TypeCon (TypVar 0),TypeApp (TypeCon (TypRef (QualName {pkgName = "main", mdlName = "Test.Data", locName = "List"}))) (TypeCon (TypVar 0))]}) (Con {constrName = "N", constrFields = Left []}))}),(QualName {pkgName = "main", mdlName = "Test.Data", locName = "Tr"},ADT {declName = "Tr", declNumParameters = 1, declCons = Just (Con {constrName = "Tr", constrFields = Left [TypeCon (TypVar 0),TypeApp (TypeCon (TypRef (QualName {pkgName = "main", mdlName = "Test.Data", locName = "Forest"}))) (TypeCon (TypVar 0))]})}),(QualName {pkgName = "main", mdlName = "Test.Data", locName = "Unit"},ADT {declName = "Unit", declNumParameters = 0, declCons = Just (Con {constrName = "Unit", constrFields = Left []})})]) ) + ,testModel (Proxy :: Proxy ( Test.Data.Tr (Data.Either.Either Test.Data.Unit Test.Data.N) )) ( (TypeApp (TypeCon (QualName {pkgName = "main", mdlName = "Test.Data", locName = "Tr"})) (TypeApp (TypeApp (TypeCon (QualName {pkgName = "base", mdlName = "Data.Either", locName = "Either"})) (TypeCon (QualName {pkgName = "main", mdlName = "Test.Data", locName = "Unit"}))) (TypeCon (QualName {pkgName = "main", mdlName = "Test.Data", locName = "N"}))),[(QualName {pkgName = "base", mdlName = "Data.Either", locName = "Either"},ADT {declName = "Either", declNumParameters = 2, declCons = Just (ConTree (Con {constrName = "Left", constrFields = Left [TypeCon (TypVar 0)]}) (Con {constrName = "Right", constrFields = Left [TypeCon (TypVar 1)]}))}),(QualName {pkgName = "main", mdlName = "Test.Data", locName = "Forest"},ADT {declName = "Forest", declNumParameters = 1, declCons = Just (Con {constrName = "Forest", constrFields = Left [TypeApp (TypeCon (TypRef (QualName {pkgName = "main", mdlName = "Test.Data", locName = "List"}))) (TypeApp (TypeCon (TypRef (QualName {pkgName = "main", mdlName = "Test.Data", locName = "Tr"}))) (TypeCon (TypVar 0)))]})}),(QualName {pkgName = "main", mdlName = "Test.Data", locName = "List"},ADT {declName = "List", declNumParameters = 1, declCons = Just (ConTree (Con {constrName = "C", constrFields = Left [TypeCon (TypVar 0),TypeApp (TypeCon (TypRef (QualName {pkgName = "main", mdlName = "Test.Data", locName = "List"}))) (TypeCon (TypVar 0))]}) (Con {constrName = "N", constrFields = Left []}))}),(QualName {pkgName = "main", mdlName = "Test.Data", locName = "N"},ADT {declName = "N", declNumParameters = 0, declCons = Just (ConTree (ConTree (Con {constrName = "One", constrFields = Left []}) (Con {constrName = "Two", constrFields = Left []})) (ConTree (Con {constrName = "Three", constrFields = Left []}) (ConTree (Con {constrName = "Four", constrFields = Left []}) (Con {constrName = "Five", constrFields = Left []}))))}),(QualName {pkgName = "main", mdlName = "Test.Data", locName = "Tr"},ADT {declName = "Tr", declNumParameters = 1, declCons = Just (Con {constrName = "Tr", constrFields = Left [TypeCon (TypVar 0),TypeApp (TypeCon (TypRef (QualName {pkgName = "main", mdlName = "Test.Data", locName = "Forest"}))) (TypeCon (TypVar 0))]})}),(QualName {pkgName = "main", mdlName = "Test.Data", locName = "Unit"},ADT {declName = "Unit", declNumParameters = 0, declCons = Just (Con {constrName = "Unit", constrFields = Left []})})]) ) ,testModel (Proxy :: Proxy ( Test.Data.Perfect Bool )) ( (TypeApp (TypeCon (QualName {pkgName = "main", mdlName = "Test.Data", locName = "Perfect"})) (TypeCon (QualName {pkgName = "ghc-prim", mdlName = "GHC.Types", locName = "Bool"})),[(QualName {pkgName = "ghc-prim", mdlName = "GHC.Types", locName = "Bool"},ADT {declName = "Bool", declNumParameters = 0, declCons = Just (ConTree (Con {constrName = "False", constrFields = Left []}) (Con {constrName = "True", constrFields = Left []}))}),(QualName {pkgName = "main", mdlName = "Test.Data", locName = "Fork"},ADT {declName = "Fork", declNumParameters = 1, declCons = Just (Con {constrName = "Fork", constrFields = Left [TypeCon (TypVar 0),TypeCon (TypVar 0)]})}),(QualName {pkgName = "main", mdlName = "Test.Data", locName = "Perfect"},ADT {declName = "Perfect", declNumParameters = 1, declCons = Just (ConTree (Con {constrName = "ZeroP", constrFields = Left [TypeCon (TypVar 0)]}) (Con {constrName = "SuccP", constrFields = Left [TypeApp (TypeCon (TypRef (QualName {pkgName = "main", mdlName = "Test.Data", locName = "Perfect"}))) (TypeApp (TypeCon (TypRef (QualName {pkgName = "main", mdlName = "Test.Data", locName = "Fork"}))) (TypeCon (TypVar 0)))]}))})]) ) ] diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} + + {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NoMonomorphismRestriction #-} -- {-# LANGUAGE OverloadedStrings #-} @@ -7,11 +7,12 @@ module Main where -import qualified Data.Map as M +import qualified Data.Map as M import Data.Model import Info import Test.Data -import Test.Data.Model () +import Test.Data.Model ( ) +import Data.Model.Util ( ) import Test.Tasty import Test.Tasty.HUnit @@ -22,58 +23,68 @@ main = defaultMain tests tests :: TestTree -tests = - testGroup - "Tests" - [ - modelTests - , transformTests - , namesTests - , prettyTests - ] - -transformTests :: TestTree -transformTests = testGroup "Transform Tests" [ - testTrc [("a",["b","c"]),("b",["b","d","d","c"]),("c",[]),("d",["a"])] "b" ["c","a","d","b"] - ,testTrc [("a",["b","c"]),("b",["b","d","d","c"]),("c",[]),("d",["a"])] "c" ["c"] - ,testMutual ([("a",["b","c"]),("b",["a","c"]),("c",[])]) (Right [["c"],["b","a"]]) - ,testMutual ([("a",["b","c"]),("b",["a","c","b"]),("c",["d"]),("d",[])]) (Right [["d"],["c"],["b","a"]]) - ,testMutual ([("a",["z","c"]),("b",["a","c","b"]),("c",["d"])]) (Left ["transitiveClosure:Unknown reference to \"d\"","transitiveClosure:Unknown reference to \"z\""]) +tests = testGroup + "Tests" + [ modelTests + --, transformTests + , namesTests + , prettyTests ] - where - testTrc adjs start etrc = - let Right trc = transitiveClosure Just (M.fromList adjs) start - in testCase (unwords ["transitiveClosure",show adjs,start]) $ trc @?= etrc - testMutual adjs emut = - let mut = mutualGroups Just (M.fromList adjs) - in testCase (unwords ["mutualGroups",show adjs]) $ mut @?= emut +-- Move to ZM (done?) +-- transformTests :: TestTree +-- transformTests = testGroup "Transform Tests" [ +-- testTrc [("a",["b","c"]),("b",["b","d","d","c"]),("c",[]),("d",["a"])] "b" ["c","a","d","b"] +-- ,testTrc [("a",["b","c"]),("b",["b","d","d","c"]),("c",[]),("d",["a"])] "c" ["c"] +-- ,testMutual [("a",["b","c"]),("b",["a","c"]),("c",[])] (Right [["c"],["b","a"]]) +-- ,testMutual [("a",["b","c"]),("b",["a","c","b"]),("c",["d"]),("d",[])] (Right [["d"],["c"],["b","a"]]) +-- ,testMutual [("a",["z","c"]),("b",["a","c","b"]),("c",["d"])] (Left ["transitiveClosure:Unknown reference to \"d\"","transitiveClosure:Unknown reference to \"z\""]) +-- ] +-- where +-- testTrc adjs start etrc = +-- let Right trc = transitiveClosure Just (M.fromList adjs) start +-- in testCase (unwords ["transitiveClosure",show adjs,start]) $ trc @?= etrc +-- testMutual adjs emut = +-- let mut = mutualGroups Just (M.fromList adjs) +-- in testCase (unwords ["mutualGroups",show adjs]) $ mut @?= emut + namesTests :: TestTree -namesTests = testGroup "QualName Tests" [ - tstErr "" "Empty qualified name" - ,tst "ab" $ QualName "" "" "ab" +namesTests = testGroup + "QualName Tests" + [ tstErr "" "Empty qualified name" + , tst "ab" $ QualName "" "" "ab" --,tstErr "a.b.c.d" "Too many components in qualified name 'a.b.c.d'" - ,tst "ab.cd" $ QualName "" "ab" "cd" - ,tst "Data.List" $ QualName "" "Data" "List" - ,tst "ab.cd.ef" $ QualName "ab" "cd" "ef" - ,tst "list.Data.List" $ QualName "list" "Data" "List" - ,tst "ab.cd.ef.gh" $ QualName "ab" "cd.ef" "gh" + , tst "ab.cd" $ QualName "" "ab" "cd" + , tst "Data.List" $ QualName "" "Data" "List" + , tst "ab.cd.ef" $ QualName "ab" "cd" "ef" + , tst "list.Data.List" $ QualName "list" "Data" "List" + , tst "ab.cd.ef.gh" $ QualName "ab" "cd.ef" "gh" ] - where - tstErr s err = testCase (unwords ["Parse QualName Fail",s]) $ convertResultToError (safeConvert s::ConvertResult QualName) @?= Left ("Convertible: error converting source data \"\" of type [Char] to type QualName: "++ err) - tst s q = testGroup (unwords ["Parse QualName",s]) - [testCase "parse" $ safeConvert s @?= Right q - ,testCase "roundtrip" $ convert (convert s::QualName) @?= s - ] + where + tstErr s err = + testCase (unwords ["Parse QualName Fail", s]) + $ convertResultToError (safeConvert s :: ConvertResult QualName) + @?= Left + ("Convertible: error converting source data \"\" of type [Char] to type QualName: " + ++ err + ) + tst s q = testGroup + (unwords ["Parse QualName", s]) + [ testCase "parse" $ safeConvert s @?= Right q + , testCase "roundtrip" $ convert (convert s :: QualName) @?= s + ] prettyTests :: TestTree -prettyTests = testGroup "Pretty Tests" $ map tst $ zip models2 pretty2 - where - tst (model,pretty) = testCase (unwords ["Pretty"]) $ prettyShow model @?= pretty - -- let env = typeEnv model in prettyShow (env,model) @?= pretty +prettyTests = testGroup "Pretty Tests" $ zipWith (curry tst) models2 pretty2 + where + tst (model, pretty) = + testCase (unwords ["Pretty"]) $ prettyShow model @?= pretty + -- let env = typeEnv model in prettyShow (env,model) @?= pretty - models2 = [typeModel (Proxy :: Proxy (List Bool))] + models2 = [typeModel (Proxy :: Proxy (List Bool))] - pretty2 = ["Type:\nmain.Test.Data.List ghc-prim.GHC.Types.Bool -> List Bool\nEnvironment:\nghc-prim.GHC.Types.Bool -> Bool \8801 False\n | True\nmain.Test.Data.List -> List a \8801 C a (main.Test.Data.List a)\n | N"] + pretty2 = + [ "Type:\nmain.Test.Data.List ghc-prim.GHC.Types.Bool -> List Bool\nEnvironment:\nghc-prim.GHC.Types.Bool -> Bool \8801 False\n | True\nmain.Test.Data.List -> List a \8801 C a (main.Test.Data.List a)\n | N" + ] diff --git a/test/Test/Data.hs b/test/Test/Data.hs --- a/test/Test/Data.hs +++ b/test/Test/Data.hs @@ -1,5 +1,4 @@ {-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} @@ -10,7 +9,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {- A collection of data types used for testing. @@ -22,8 +20,8 @@ import Data.Int import Data.Word import GHC.Generics -import qualified Test.Data2 as D2 -import Test.Tasty.QuickCheck +import qualified Test.Data2 as D2 +-- import Test.Tasty.QuickCheck data Void deriving Generic @@ -209,76 +207,3 @@ ,fuel::String -- constant Petrol } deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) --- To generate Arbitrary instances while avoiding a direct dependency on 'derive' (that is not supported by Eta), run in the project directory: derive -a test/Test/Data.hs -{-! -deriving instance Arbitrary N -deriving instance Arbitrary Tree -deriving instance Arbitrary List -deriving instance Arbitrary Unit -deriving instance Arbitrary Un -deriving instance Arbitrary A -deriving instance Arbitrary B -!-} - --- GENERATED START - -instance () => Arbitrary N where - arbitrary - = do x <- choose (0 :: Int, 4) - case x of - 0 -> return One - 1 -> return Two - 2 -> return Three - 3 -> return Four - 4 -> return Five - _ -> error "FATAL ERROR: Arbitrary instance, logic bug" - -instance (Arbitrary a) => Arbitrary (Tree a) where - arbitrary - = do x <- choose (0 :: Int, 1) - case x of - 0 -> do x1 <- arbitrary - x2 <- arbitrary - return (Node x1 x2) - 1 -> do x1 <- arbitrary - return (Leaf x1) - _ -> error "FATAL ERROR: Arbitrary instance, logic bug" - -instance (Arbitrary a) => Arbitrary (List a) where - arbitrary - = do x <- choose (0 :: Int, 1) - case x of - 0 -> do x1 <- arbitrary - x2 <- arbitrary - return (C x1 x2) - 1 -> return N - _ -> error "FATAL ERROR: Arbitrary instance, logic bug" - -instance () => Arbitrary Unit where - arbitrary = return Unit - -instance () => Arbitrary Un where - arbitrary - = do x1 <- arbitrary - return (Un x1) - -instance () => Arbitrary A where - arbitrary - = do x <- choose (0 :: Int, 1) - case x of - 0 -> do x1 <- arbitrary - return (A x1) - 1 -> do x1 <- arbitrary - return (AA x1) - _ -> error "FATAL ERROR: Arbitrary instance, logic bug" - -instance () => Arbitrary B where - arbitrary - = do x <- choose (0 :: Int, 1) - case x of - 0 -> do x1 <- arbitrary - return (B x1) - 1 -> do x1 <- arbitrary - return (BB x1) - _ -> error "FATAL ERROR: Arbitrary instance, logic bug" --- GENERATED STOP diff --git a/test/Test/Data/Model.hs b/test/Test/Data/Model.hs --- a/test/Test/Data/Model.hs +++ b/test/Test/Data/Model.hs @@ -1,14 +1,14 @@ -{-# LANGUAGE StandaloneDeriving ,DeriveGeneric ,ScopedTypeVariables ,FlexibleContexts ,DeriveAnyClass #-} +{-# LANGUAGE ScopedTypeVariables, FlexibleContexts #-} module Test.Data.Model where import Data.Model import Test.Data import qualified Test.Data2 as Data2 import qualified Test.Data3 as Data3 -import Data.Word -import GHC.Generics -import Data.Proxy -import Data.Typeable +--import Data.Word() +--import GHC.Generics() +--import Data.Proxy +--import Data.Typeable -- instance Model Word8 -- instance Model Words