diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,6 +1,16 @@ Significant and compatibility-breaking changes. +Version 0.4: + - Data.Model.Types: + - Modified type of 'constructors' and 'constructorInfo' + - Removed instances of StringLike (replaced with Convertible) + - Modified behaviour of conversion from String to QualName + - Data.Model.Util: + - modified type of 'mutualGroups' and 'transitiveClosure' + Version 0.3: -- Data.Model.Util: + - Data.Model.Util: - Removed 'dependencies' - Added the (similar but not identical) function 'transitiveClosure' + + diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,5 +1,9 @@ -[![Build Status](https://travis-ci.org/tittoassini/model.svg?branch=master)](https://travis-ci.org/tittoassini/model) [![Hackage version](https://img.shields.io/hackage/v/model.svg)](http://hackage.haskell.org/package/model) +[![Join the chat at https://gitter.im/Quid2/Lobby](https://badges.gitter.im/Quid2.svg)](https://gitter.im/Quid2/Lobby?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge) +[![Build Status](https://travis-ci.org/Quid2/model.svg?branch=master)](https://travis-ci.org/Quid2/model) +[![Hackage version](https://img.shields.io/hackage/v/model.svg)](http://hackage.haskell.org/package/model) +[![Stackage Nightly](http://stackage.org/package/model/badge/nightly)](http://stackage.org/nightly/package/model) +[![Stackage LTS](http://stackage.org/package/model/badge/lts)](http://stackage.org/lts/package/model) With `model` you can easily derive models of Haskell data types. @@ -119,7 +123,7 @@ -> Environment: -> ghc-prim.GHC.Types.Bool -> Bool ≡ False -> | True --> main.Main.Couple -> Couple a b ≡ Couple a b +-> main.Main.Couple -> Couple a b ≡ Couple a b -> main.Main.Direction -> Direction ≡ North -> | South -> | Center @@ -152,7 +156,7 @@ ### Compatibility -Tested with [ghc](https://www.haskell.org/ghc/) 7.10.3 and 8.0.2. +Tested with [ghc](https://www.haskell.org/ghc/) 7.10.3, 8.0.1, 8.0.2 and 8.2.1. ### Known Bugs and Infelicities diff --git a/model.cabal b/model.cabal --- a/model.cabal +++ b/model.cabal @@ -1,5 +1,5 @@ name: model -version: 0.3 +version: 0.4 synopsis: Derive a model of a data type using Generics description: See the . homepage: http://github.com/tittoassini/model @@ -11,7 +11,7 @@ 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 +Tested-With: GHC == 7.10.3 GHC == 8.0.1 GHC == 8.0.2 GHC == 8.2.1 extra-source-files: stack.yaml,README.md,CHANGELOG source-repository head @@ -33,7 +33,7 @@ , deepseq >= 1.4 , pretty >= 1.1.2.0 , transformers >= 0.4 - , ListLike >= 4.2.1 + , convertible >= 1.1.1.0 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 @@ -42,13 +42,22 @@ type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Spec.hs - other-modules: Test.Data,Test.Data2,Test.Data3,Test.Data.Model + other-modules: Test.Data,Test.Data2,Test.Data3,Test.Data.Model,Info build-depends: base >= 4.8 && < 5 , ghc-prim >= 0.3.1.0 , tasty >= 0.11.0.2 , tasty-hunit >= 0.9.2 + , tasty-quickcheck >=0.8.4 , pretty >= 1.1.2.0 , containers >= 0.5.6.2 , model + default-language: Haskell2010 +test-suite model-doctest + default-language: Haskell2010 + type: exitcode-stdio-1.0 + ghc-options: -threaded + main-is: DocSpec.hs + build-depends: base >4 && <5, doctest>=0.11.1, filemanip>=0.3.6.3 + HS-Source-Dirs: test 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 @@ -7,16 +7,16 @@ module Data.Model.Pretty( CompactPretty(..) -- *Utilities - ,dotted,spacedP,vspacedP,varP + ,dottedP,spacedP,vspacedP,varP,varC -- *Re-exports ,Pretty(..),prettyShow ) where import Data.Char import Data.List -import qualified Data.ListLike.String as S import qualified Data.Map as M import Data.Model.Types +import Data.Model.Util import Text.PrettyPrint.HughesPJClass -- |Compact representation: a value enveloped in CompactPretty will have only its first lines displayed @@ -32,18 +32,7 @@ then unlines $ take 5 ln ++ ["..."] ++ drop (l-5) ln else s --- TODO: check that it works for examples --- instance(Pretty adtName,Pretty consName,Pretty ref,Pretty exRef,Ord exRef,Show exRef) => Pretty (TypeModel adtName consName ref exRef) where --- pPrint (TypeModel t e) = vcat $ [ --- text "Type:" --- ,pPrint t <+> text "->" <+> pPrint (declName <$> solveAll e t) --- -- ,text "" -- Results in a split display --- ,text "Environment:"] --- ++ map (\(ref,adt) -> pPrint ref <+> text "->" <+> (pPrint . CompactPretty $ adt)) (M.assocs e) - --- instance( Pretty exRef,Ord exRef,Show exRef,S.StringLike adtName,S.StringLike consName,S.StringLike ref) => Pretty (TypeModel adtName consName (TypeRef ref) exRef) where - -instance {-# OVERLAPPABLE #-} (Functor t, Pretty (t Name),Pretty exRef,Ord exRef,Show exRef,S.StringLike adtName,S.StringLike consName,S.StringLike iref) => Pretty (TypeModel adtName consName (t iref) exRef) where +instance {-# OVERLAPPABLE #-} (Functor t, Pretty (t Name),Pretty exRef,Ord exRef,Show exRef,Convertible adtName String,Convertible consName String,Convertible iref String) => Pretty (TypeModel adtName consName (t iref) exRef) where pPrint (TypeModel t e) = vcat $ [ text "Type:" ,pPrint t <+> text "->" <+> pPrint (localName . declName <$> solveAll e t) @@ -52,8 +41,8 @@ where stringADT adt = ADT (localName . declName $ adt) (declNumParameters adt) (((localName <$>) <$>) . conTreeNameMap localName <$> declCons adt) -localName :: S.StringLike s => s -> Name -localName = Name . S.toString +localName :: Convertible s String => s -> Name +localName = Name . convert instance (Pretty n,Pretty cn,Pretty r) => Pretty (ADT n cn r) where pPrint = prettyADT "" '≡' @@ -65,15 +54,23 @@ -- |Convert a variable number (0,1,..) to a name ('a','b',..) varP :: Integral n => n -> Doc -varP n = char $ chr ( (ord 'a') + (fromIntegral n)) +varP = char . varC +-- |Convert a variable number (0,1,..) to a name ('a','b',..) +varC :: Integral a => a -> Char +varC n = chr ( (ord 'a') + (fromIntegral n)) + instance (Pretty name,Pretty ref) => Pretty (ConTree name ref) where - pPrint (Con n (Left fs)) = pPrint n <+> sep (map (printPrettyType True) fs) - pPrint (Con n (Right nfs)) = pPrint n <+> "{" <> sep (punctuate "," (map (\(nm,t) -> pPrint nm <+> "::" <+> pPrint t) nfs)) <> "}" - -- pPrint (ConTree l r) = pPrint l <+> char '|' <+> pPrint r pPrint conTree = let (h:t) = constructors conTree in vcat (char ' ' <+> pPrint h : map (\c -> char '|' <+> pPrint c) t) +instance {-# OVERLAPS #-} (Pretty name,Pretty ref) => Pretty (name,Fields name ref) where + pPrint (name,fields) = pPrint name <+> pPrint fields + +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)) <> "}" + instance Pretty n => Pretty (TypeRef n) where pPrint (TypVar v) = varP v pPrint (TypRef s) = pPrint s @@ -84,7 +81,7 @@ pPrint (TypeN f []) = pPrint f pPrint (TypeN f as) = parens (pPrint f <+> spacedP as) -instance Pretty QualName where pPrint (QualName p m l) = dotted [p,m,l] +instance Pretty QualName where pPrint (QualName p m l) = dottedP [p,m,l] instance Pretty Name where pPrint (Name n) = text n @@ -99,14 +96,14 @@ pPrint (PrettyType _ (TypeN f [])) = pPrint f pPrint (PrettyType n (TypeN f as)) = maybeParens n (pPrint f <+> spacedP (map (PrettyType True) as)) --- |Separate with a space +-- |Intercalate with a space spacedP :: Pretty a => [a] -> Doc spacedP = sep . map pPrint --- |Separate with a new line +-- |Intercalate with a new line vspacedP :: Pretty a => [a] -> Doc vspacedP = sep . intersperse (text "") . map pPrint --- |Intercalate with a dot -dotted :: [String] -> Doc -dotted = text . intercalate "." +-- |Intercalate a dot between the non empty elements of a list of strings +dottedP :: [String] -> Doc +dottedP = text . dotted 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 @@ -1,25 +1,25 @@ -- |A model for simple algebraic data types. -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} module Data.Model.Types( -- *Model TypeModel(..),TypeEnv,typeADTs ,ADT(..) - ,ConTree(..) - ,Type(..),TypeN(..),TypeRef(..) + ,ConTree(..),Fields + ,Type(..),TypeN(..),nestedTypeNs,TypeRef(..) -- *Names ,Name(..),QualName(..),qualName -- *Model Utilities ,adtNamesMap - --,typeADTs ,typeN,typeA - ,constructors,constructorInfo,conTreeNameMap,conTreeTypeMap,conTreeTypeList,conTreeTypeFoldMap,fieldsTypes,fieldsNames + ,contree,constructors,constructorInfo,conTreeNameMap,conTreeNameFold,conTreeTypeMap,conTreeTypeList,conTreeTypeFoldMap,fieldsTypes,fieldsNames -- *Handy aliases ,HTypeEnv,HTypeModel,HADT,HType,HTypeRef @@ -34,13 +34,12 @@ import Control.Applicative import Control.DeepSeq -import Data.Bifunctor (first, second) -import Data.List -import qualified Data.ListLike.String as S -import qualified Data.Map as M +import Data.Bifunctor (first, second) +import qualified Data.Map as M import Data.Maybe +import Data.Model.Util import Data.Proxy -import Data.Word (Word8) +import Data.Word (Word8) import GHC.Generics -- |Haskell Environment @@ -105,9 +104,7 @@ -- | Constructor fields, they can be either unnamed (Left case) or named (Right case) -- If they are named, they must all be named - ,constrFields :: Either - [Type ref] - [(name,Type ref)] + ,constrFields :: Fields name ref } {- | @@ -132,11 +129,23 @@ deriving (Eq, Ord, Show, NFData, Generic) +type Fields name ref = Either + [Type ref] + [(name,Type ref)] + -- |Return the list of constructors in definition order -constructors :: ConTree t t1 -> [ConTree t t1] -constructors c@(Con _ _) = [c] +constructors :: ConTree name ref -> [(name, Fields name ref)] +constructors (Con n f) = [(n,f)] constructors (ConTree l r) = constructors l ++ constructors r +-- |Convert a (possibly empty) list of constructors in (maybe) a ConTree +contree :: [(name, Fields name ref)] -> Maybe (ConTree name ref) +contree [] = Nothing +contree ccs = Just . ct $ ccs + where + ct [(name,fields)] = Con name fields + ct cs = let (ls,rs) = splitAt (length cs `div` 2) cs in ConTree (ct ls) (ct rs) + -- |Return just the field types fieldsTypes :: Either [b] [(a, b)] -> [b] fieldsTypes (Left ts) = ts @@ -148,10 +157,9 @@ fieldsNames (Right nts) = map snd nts -- |Return the binary encoding and parameter types of a constructor +-- -- The binary encoding is the sequence of Left (False) and Right (True) turns --- needed to reach the constructor from the constructor tree root. ---constructorInfo :: Eq consName => consName -> ADT name consName ref -> Maybe ([Bool], [Type ref]) ---constructorInfo consName dt = declCons dt >>= ((first reverse <$>) . loc []) +-- needed to reach the constructor from the constructor tree root constructorInfo :: Eq consName => consName -> ConTree consName t -> Maybe ([Bool], [Type t]) constructorInfo consName = (first reverse <$>) . loc [] where @@ -177,7 +185,6 @@ -- TODO: simplify this traverse f (Con n (Right nts)) = Con n . Right . zip (map fst nts) <$> sequenceA (map (traverse f . snd) nts) --- CHECK: easier to use lens? -- |Map on the constructor types (used for example when eliminating variables) conTreeTypeMap :: (Type t -> Type ref) -> ConTree name t -> ConTree name ref conTreeTypeMap f (ConTree l r) = ConTree (conTreeTypeMap f l) (conTreeTypeMap f r) @@ -190,6 +197,11 @@ conTreeNameMap f (Con n (Left ts)) = Con (f n) (Left ts) conTreeNameMap f (Con n (Right nts)) = Con (f n) (Right $ map (first f) nts) +-- |Fold over a constructor tree names +conTreeNameFold :: Monoid a => (name -> a) -> ConTree name t -> a +conTreeNameFold f (ConTree l r) = conTreeNameFold f l `mappend` conTreeNameFold f r +conTreeNameFold f (Con n _) = f n + -- |Extract list of types in a constructor tree conTreeTypeList :: ConTree name t -> [Type t] conTreeTypeList = conTreeTypeFoldMap (:[]) @@ -215,7 +227,7 @@ -- |Another representation of a type, sometime easier to work with data TypeN r = TypeN r [TypeN r] - deriving (Eq,Ord,Read,Show,NFData ,Generic,Functor,Foldable,Traversable) + deriving (Eq,Ord,Read,Show,NFData ,Generic,Functor,Foldable,Traversable) -- |Convert from Type to TypeN typeN :: Type r -> TypeN r @@ -227,6 +239,18 @@ typeA :: TypeN ref -> Type ref typeA (TypeN tf ts) = foldl TypeApp (TypeCon tf) (map typeA ts) +-- |Returns the list of nested TypeNs +-- +-- >>> nestedTypeNs $ TypeN "F" [TypeN "G" [],TypeN "Z" []] +-- [TypeN "F" [TypeN "G" [],TypeN "Z" []],TypeN "G" [],TypeN "Z" []] +-- +-- >>> nestedTypeNs $ TypeN "F" [TypeN "G" [TypeN "H" [TypeN "L" []]],TypeN "Z" []] +-- [TypeN "F" [TypeN "G" [TypeN "H" [TypeN "L" []]],TypeN "Z" []],TypeN "G" [TypeN "H" [TypeN "L" []]],TypeN "H" [TypeN "L" []],TypeN "L" [],TypeN "Z" []] +-- +nestedTypeNs :: TypeN t -> [TypeN t] +nestedTypeNs t@(TypeN _ []) = [t] +nestedTypeNs t@(TypeN _ ps) = t : concatMap nestedTypeNs ps + -- |A reference to a type data TypeRef name = TypVar Word8 -- ^Type variable | TypRef name -- ^Type reference @@ -248,33 +272,36 @@ -- |Return the qualified name, minus the package name. qualName :: QualName -> String -qualName n = concat [mdlName n,".",locName n] +qualName n = convert $ n {pkgName=""} -instance S.StringLike QualName where - toString n = intercalate "." [pkgName n,mdlName n,locName n] - fromString n = let (p,r) = span (/= '.') n - (m,r2) = span (/= '.') $ tail r - l = tail r2 - in QualName p m l +instance Convertible String QualName where safeConvert = errorToConvertResult parseQualName +instance Convertible QualName String where safeConvert n = Right $ dotted [pkgName n,mdlName n,locName n] -instance S.StringLike String where - toString = id - fromString = id +-- |Parse the string as a QualName, if possible +-- +-- >>> parseQualName "ab.cd.ef.gh" +-- Right (QualName {pkgName = "ab", mdlName = "cd.ef", locName = "gh"}) +parseQualName :: String -> Either String QualName +parseQualName "" = Left "Empty string" +parseQualName n = Right $ + let (p,r) = span (/= '.') n + in if null r + then QualName "" "" p + else let (l,r2) = span (/= '.') $ reverse $ tail r + in if null r2 + then QualName "" p (reverse l) + else let m = reverse $ tail r2 + in QualName p m (reverse l) -- |Simple name data Name = Name String deriving (Eq, Ord, Show, NFData, Generic) -instance S.StringLike Name where - toString (Name n)= n - fromString = Name - -- Utilities - -- |Solve all references in a data structure, using the given environment solveAll :: (Functor f, Show k, Ord k) => M.Map k b -> f k -> f b solveAll env t = (`solve` env) <$> t -- |Solve a key in an environment, returns an error if the key is missing solve :: (Ord k, Show k) => k -> M.Map k a -> a -solve k e = fromMaybe (error $ unwords ["solve:Unknown reference to",show k]) (M.lookup k e) +solve k e = fromMaybe (error $ unwords ["solve:Unknown reference to",show k,"in",show $ M.keys e]) (M.lookup k e) 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 @@ -1,35 +1,75 @@ -module Data.Model.Util (mutualGroups, transitiveClosure, Errors) where +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE TypeSynonymInstances #-} +module Data.Model.Util + -- * Dependencies + ( properMutualGroups + , mutualGroups + , transitiveClosure + -- * Error utilities + , Errors + , toErrors + , noErrors + -- * Convertible utilities + , Convertible(..) + , convert + , ConvertResult + , ConvertError(..) + , errorToConvertResult + , errorsToConvertResult + , convertResultToError + , convertResultToErrors + -- * Formatting utilities + , dotted + ) where import Control.Monad import Control.Monad.Trans.State -import Data.Foldable (toList) +import Data.Bifunctor +import Data.Convertible +import Data.Foldable (toList) import Data.List -import qualified Data.Map as M +import qualified Data.Map.Lazy as M import Data.Maybe +import Data.Typeable +import Text.PrettyPrint.HughesPJClass (Pretty, prettyShow) --- |Return the groups of entities that are mutually dependent --- --- >>> mutualGroups Just (M.fromList [("a",["b","c"]),("b",["a","c"]),("c",[])]) --- [["c"],["a","b"]] -mutualGroups :: (Ord r, Show r, Foldable t) => (a -> Maybe r) -> M.Map r (t a) -> [[r]] +{-| 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 n = unsafely (transitiveClosure getRef env n) - recs gs [] = gs - recs gs (n:ns) = - let mutual = filter (\o -> n `elem` deps o) (deps n) - in recs (mutual:gs) (ns \\ mutual) + 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) --- >>>mutualDeps (M.fromList [("a",["b","c"]),("b",["a","c"]),("c",[])]) --- fromList [("a",["b"]),("b",["a"]),("c",[])] --- mutualDeps :: (Ord a, Show a) => M.Map a [a] -> M.Map a [a] --- mutualDeps deps = M.mapWithKey (\n ds -> filter (\o -> n `elem` (solve o deps)) ds) deps +{-| Return the transitive closure of an element in a graph of dependencies specified as an adjacency list --- |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 :: (Ord r, Show r, Foldable t) => (a -> Maybe r) -> M.Map r (t a) -> r -> Either Errors [r] +>>> 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 @@ -37,20 +77,64 @@ 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",show n]:errors st}) + Nothing -> modify (\st -> st {errors=unwords ["transitiveClosure:Unknown reference to",prettyShow n]:errors st}) Just v -> mapM_ deps (mapMaybe getRef . toList $ v) --- |Extract a Right value from an Either, throw an error if it is Left -unsafely :: Either Errors c -> c -unsafely = either (error.unlines) id - --- execRec :: State (RecState r) a -> Either [String] [r] --- execRec op = (\st -> if null (errors st) then Right (tail . reverse . seen $ st) else Left (errors st)) $ execState op (RecState [] []) - 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 -- |A list of error messages -type Errors = [String] +type Errors = [Error] + +type Error = String + +-- |Either an error or a valid value +-- type EitherError a = Either String a + +-- |Either errors or a valid value +-- type EitherErrors a = Either [String] a + +toErrors :: Either Error a -> Either Errors a +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 + +errorsToConvertResult + :: (Typeable b, Typeable a, Show a) + => (a -> Either Errors b) -> a -> ConvertResult b +errorsToConvertResult conv a = either (\errs -> convError (unwords errs) a) Right $ conv a + +convertResultToError :: ConvertResult a -> Either Error a +convertResultToError = first prettyConvertError + +convertResultToErrors :: ConvertResult a -> Either Errors a +convertResultToErrors = toErrors . convertResultToError + +instance Convertible String String where safeConvert = Right . id + +{-| Intercalate a dot between the non empty elements of a list of strings. + +>>> dotted [] +"" + +>>> dotted ["","bc","de"] +"bc.de" + +>>> dotted ["bc","","de"] +"bc.de" +-} +dotted :: [String] -> String +-- dotted = intercalate "." . filter (not . null) +dotted [] = "" +dotted [s] = s +dotted (h:t) = post h ++ dotted t + 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,14 +17,14 @@ Examples: ->>> undefined :: Ana (Maybe Char) +>> undefined :: Ana (Maybe Char) undefined :: Ana (Maybe Char) :: App (Typ (Maybe A0)) (Typ Char) ->>> undefined :: Ana (Either Int Char) +>> undefined :: Ana (Either Int Char) undefined :: Ana (Either Int Char) :: App (App (Typ (Either A0 A1)) (Typ Int)) (Typ Char) ->>> undefined :: Ana ([(Bool,())]) +>> undefined :: Ana ([(Bool,())]) undefined :: Ana ([(Bool,())]) :: App (Typ [A0]) (App (App (Typ (A0, A1)) (Typ Bool)) (Typ ())) -} diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -1,6 +1,6 @@ -resolver: lts-6.31 -# resolver: lts-7.21 -# resolver: lts-8.13 - +# resolver: lts-6.35 +#resolver: lts-7.24 +resolver: lts-9.11 +#resolver: nightly-2017-10-30 packages: - '.' diff --git a/test/DocSpec.hs b/test/DocSpec.hs new file mode 100644 --- /dev/null +++ b/test/DocSpec.hs @@ -0,0 +1,7 @@ +module Main where +import Test.DocTest +import System.FilePath.Find + +main :: IO () +-- main = find always ((extension ==? ".hs") ||? (extension ==? ".lhs")) "src" >>= doctest +main = find always (extension ==? ".hs") "src" >>= doctest diff --git a/test/Info.hs b/test/Info.hs new file mode 100644 --- /dev/null +++ b/test/Info.hs @@ -0,0 +1,182 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Info(modelTests) where +import Data.Model +import Data.Word +import qualified GHC.Base +import Test.Data +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 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 + +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) + +models :: [HTypeModel] +models = + [ typeModel (Proxy :: Proxy Void) + , typeModel (Proxy :: Proxy Unit) + , typeModel (Proxy :: Proxy Bool) + , typeModel (Proxy :: Proxy Char) + , typeModel (Proxy :: Proxy String) + , typeModel (Proxy :: Proxy [Bool]) + , typeModel (Proxy :: Proxy N) + , typeModel (Proxy :: Proxy Un) + , typeModel (Proxy :: Proxy D2) + , typeModel (Proxy :: Proxy D4) + , typeModel (Proxy :: Proxy A0) + , typeModel (Proxy :: Proxy B0) + -- ,typeModel (Proxy :: Proxy Various) + -- ghc chokes on these heavily mutually dependent types + -- ,typeModel (Proxy :: Proxy MM1) + -- ,typeModel (Proxy :: Proxy MM2) + -- ,typeModel (Proxy :: Proxy MM3) + , typeModel (Proxy :: Proxy (Phantom Unit)) + , typeModel (Proxy :: Proxy (List Bool)) + , 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 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 (Perfect Bool)) + -- Unsupported: higher kind + --,typeModel (Proxy :: Proxy (PerfectF Maybe Bool)) + --,typeModel (Proxy :: Proxy (Free Maybe Bool)) + ] + +--------- Some (fake) instance declaration for primitive types, for testing only +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) +data Word8SI deriving Generic +instance Model Word8SI + +-- instance Model a => Model [a] where envType _ = envType (Proxy::Proxy (ListSI a)) +-- data ListSI a deriving Generic +-- instance Model a => Model (ListSI a) + +instance Model a => Model [a] + +instance Model () + +----- 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) + +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) + +mdlRef :: HTypeRef -> TypeRef Name +mdlRef (TypVar v) = TypVar v +mdlRef (TypRef n) = TypRef (asName n) + +asName :: QualName -> Name +asName qn | mdlName qn == "GHC.Types" = Name $ locName qn +asName n = Name . qualName $ n + +pr :: Show a => a -> IO () +pr = print +pp :: Pretty a => a -> IO () +pp = putStrLn . prettyShow + +----- Create tests +makeTests :: IO () +makeTests = makeTest models + +thisFile :: [Char] +thisFile = "test/Info.hs" + +-- 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)) ++ " ]" + +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 []})})]) ) + + ,testModel (Proxy :: Proxy ( Bool )) ( (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 []}))})]) ) + + ,testModel (Proxy :: Proxy ( Info.CharSI )) ( (TypeCon (QualName {pkgName = "main", mdlName = "Info", locName = "CharSI"}),[(QualName {pkgName = "main", mdlName = "Info", locName = "CharSI"},ADT {declName = "CharSI", declNumParameters = 0, declCons = Nothing})]) ) + + ,testModel (Proxy :: Proxy ( [] Info.CharSI )) ( (TypeApp (TypeCon (QualName {pkgName = "ghc-prim", mdlName = "GHC.Types", locName = "[]"})) (TypeCon (QualName {pkgName = "main", mdlName = "Info", locName = "CharSI"})),[(QualName {pkgName = "ghc-prim", mdlName = "GHC.Types", locName = "[]"},ADT {declName = "[]", declNumParameters = 1, declCons = Just (ConTree (Con {constrName = "[]", constrFields = Left []}) (Con {constrName = ":", constrFields = Left [TypeCon (TypVar 0),TypeApp (TypeCon (TypRef (QualName {pkgName = "ghc-prim", mdlName = "GHC.Types", locName = "[]"}))) (TypeCon (TypVar 0))]}))}),(QualName {pkgName = "main", mdlName = "Info", locName = "CharSI"},ADT {declName = "CharSI", declNumParameters = 0, declCons = Nothing})]) ) + + ,testModel (Proxy :: Proxy ( [] Bool )) ( (TypeApp (TypeCon (QualName {pkgName = "ghc-prim", mdlName = "GHC.Types", locName = "[]"})) (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 = "ghc-prim", mdlName = "GHC.Types", locName = "[]"},ADT {declName = "[]", declNumParameters = 1, declCons = Just (ConTree (Con {constrName = "[]", constrFields = Left []}) (Con {constrName = ":", constrFields = Left [TypeCon (TypVar 0),TypeApp (TypeCon (TypRef (QualName {pkgName = "ghc-prim", mdlName = "GHC.Types", locName = "[]"}))) (TypeCon (TypVar 0))]}))})]) ) + + ,testModel (Proxy :: Proxy ( Test.Data.N )) ( (TypeCon (QualName {pkgName = "main", mdlName = "Test.Data", locName = "N"}),[(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 []}))))})]) ) + + ,testModel (Proxy :: Proxy ( Test.Data.Un )) ( (TypeCon (QualName {pkgName = "main", mdlName = "Test.Data", locName = "Un"}),[(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 = "Un"},ADT {declName = "Un", declNumParameters = 0, declCons = Just (Con {constrName = "Un", constrFields = Right [("un",TypeCon (TypRef (QualName {pkgName = "ghc-prim", mdlName = "GHC.Types", locName = "Bool"})))]})})]) ) + + ,testModel (Proxy :: Proxy ( Test.Data.D2 )) ( (TypeCon (QualName {pkgName = "main", mdlName = "Test.Data", locName = "D2"}),[(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 = "D2"},ADT {declName = "D2", declNumParameters = 0, declCons = Just (Con {constrName = "D2", constrFields = Left [TypeCon (TypRef (QualName {pkgName = "ghc-prim", mdlName = "GHC.Types", locName = "Bool"})),TypeCon (TypRef (QualName {pkgName = "main", mdlName = "Test.Data", locName = "N"}))]})}),(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 []}))))})]) ) + + ,testModel (Proxy :: Proxy ( Test.Data.D4 )) ( (TypeCon (QualName {pkgName = "main", mdlName = "Test.Data", locName = "D4"}),[(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 = "D4"},ADT {declName = "D4", declNumParameters = 0, declCons = Just (Con {constrName = "D4", constrFields = Left [TypeCon (TypRef (QualName {pkgName = "ghc-prim", mdlName = "GHC.Types", locName = "Bool"})),TypeCon (TypRef (QualName {pkgName = "main", mdlName = "Test.Data", locName = "N"})),TypeCon (TypRef (QualName {pkgName = "main", mdlName = "Test.Data", locName = "Unit"})),TypeCon (TypRef (QualName {pkgName = "main", mdlName = "Test.Data", locName = "N3"}))]})}),(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 = "N3"},ADT {declName = "N3", declNumParameters = 0, declCons = Just (ConTree (Con {constrName = "N1", constrFields = Left []}) (ConTree (Con {constrName = "N2", constrFields = Left []}) (Con {constrName = "N3", 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.A0 )) ( (TypeCon (QualName {pkgName = "main", mdlName = "Test.Data", locName = "A0"}),[(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 = "A0"},ADT {declName = "A0", declNumParameters = 0, declCons = Just (ConTree (Con {constrName = "A0", constrFields = Left [TypeCon (TypRef (QualName {pkgName = "main", mdlName = "Test.Data", locName = "B0"})),TypeCon (TypRef (QualName {pkgName = "main", mdlName = "Test.Data", locName = "B0"})),TypeCon (TypRef (QualName {pkgName = "main", mdlName = "Test.Data", locName = "D0"})),TypeCon (TypRef (QualName {pkgName = "ghc-prim", mdlName = "GHC.Types", locName = "Bool"}))]}) (Con {constrName = "A1", constrFields = Left [TypeApp (TypeCon (TypRef (QualName {pkgName = "main", mdlName = "Test.Data", locName = "List"}))) (TypeCon (TypRef (QualName {pkgName = "ghc-prim", mdlName = "GHC.Types", locName = "Bool"}))),TypeApp (TypeCon (TypRef (QualName {pkgName = "main", mdlName = "Test.Data", locName = "List"}))) (TypeCon (TypRef (QualName {pkgName = "main", mdlName = "Test.Data", locName = "Unit"}))),TypeApp (TypeCon (TypRef (QualName {pkgName = "main", mdlName = "Test.Data2", locName = "List"}))) (TypeCon (TypRef (QualName {pkgName = "ghc-prim", mdlName = "GHC.Types", locName = "Bool"}))),TypeApp (TypeCon (TypRef (QualName {pkgName = "main", mdlName = "Test.Data2", locName = "List"}))) (TypeCon (TypRef (QualName {pkgName = "ghc-prim", mdlName = "GHC.Types", locName = "Bool"})))]}))}),(QualName {pkgName = "main", mdlName = "Test.Data", locName = "B0"},ADT {declName = "B0", declNumParameters = 0, declCons = Just (ConTree (Con {constrName = "B0", constrFields = Left [TypeCon (TypRef (QualName {pkgName = "main", mdlName = "Test.Data", locName = "C0"}))]}) (Con {constrName = "B1", constrFields = Left []}))}),(QualName {pkgName = "main", mdlName = "Test.Data", locName = "C0"},ADT {declName = "C0", declNumParameters = 0, declCons = Just (ConTree (Con {constrName = "C0", constrFields = Left [TypeCon (TypRef (QualName {pkgName = "main", mdlName = "Test.Data", locName = "A0"}))]}) (Con {constrName = "C1", constrFields = Left []}))}),(QualName {pkgName = "main", mdlName = "Test.Data", locName = "D0"},ADT {declName = "D0", declNumParameters = 0, declCons = Just (ConTree (Con {constrName = "D0", constrFields = Left [TypeCon (TypRef (QualName {pkgName = "main", mdlName = "Test.Data", locName = "E0"}))]}) (Con {constrName = "D1", constrFields = Left []}))}),(QualName {pkgName = "main", mdlName = "Test.Data", locName = "E0"},ADT {declName = "E0", declNumParameters = 0, declCons = Just (ConTree (Con {constrName = "E0", constrFields = Left [TypeCon (TypRef (QualName {pkgName = "main", mdlName = "Test.Data", locName = "D0"}))]}) (Con {constrName = "E1", 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 []})}),(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 []}))})]) ) + + ,testModel (Proxy :: Proxy ( Test.Data.B0 )) ( (TypeCon (QualName {pkgName = "main", mdlName = "Test.Data", locName = "B0"}),[(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 = "A0"},ADT {declName = "A0", declNumParameters = 0, declCons = Just (ConTree (Con {constrName = "A0", constrFields = Left [TypeCon (TypRef (QualName {pkgName = "main", mdlName = "Test.Data", locName = "B0"})),TypeCon (TypRef (QualName {pkgName = "main", mdlName = "Test.Data", locName = "B0"})),TypeCon (TypRef (QualName {pkgName = "main", mdlName = "Test.Data", locName = "D0"})),TypeCon (TypRef (QualName {pkgName = "ghc-prim", mdlName = "GHC.Types", locName = "Bool"}))]}) (Con {constrName = "A1", constrFields = Left [TypeApp (TypeCon (TypRef (QualName {pkgName = "main", mdlName = "Test.Data", locName = "List"}))) (TypeCon (TypRef (QualName {pkgName = "ghc-prim", mdlName = "GHC.Types", locName = "Bool"}))),TypeApp (TypeCon (TypRef (QualName {pkgName = "main", mdlName = "Test.Data", locName = "List"}))) (TypeCon (TypRef (QualName {pkgName = "main", mdlName = "Test.Data", locName = "Unit"}))),TypeApp (TypeCon (TypRef (QualName {pkgName = "main", mdlName = "Test.Data2", locName = "List"}))) (TypeCon (TypRef (QualName {pkgName = "ghc-prim", mdlName = "GHC.Types", locName = "Bool"}))),TypeApp (TypeCon (TypRef (QualName {pkgName = "main", mdlName = "Test.Data2", locName = "List"}))) (TypeCon (TypRef (QualName {pkgName = "ghc-prim", mdlName = "GHC.Types", locName = "Bool"})))]}))}),(QualName {pkgName = "main", mdlName = "Test.Data", locName = "B0"},ADT {declName = "B0", declNumParameters = 0, declCons = Just (ConTree (Con {constrName = "B0", constrFields = Left [TypeCon (TypRef (QualName {pkgName = "main", mdlName = "Test.Data", locName = "C0"}))]}) (Con {constrName = "B1", constrFields = Left []}))}),(QualName {pkgName = "main", mdlName = "Test.Data", locName = "C0"},ADT {declName = "C0", declNumParameters = 0, declCons = Just (ConTree (Con {constrName = "C0", constrFields = Left [TypeCon (TypRef (QualName {pkgName = "main", mdlName = "Test.Data", locName = "A0"}))]}) (Con {constrName = "C1", constrFields = Left []}))}),(QualName {pkgName = "main", mdlName = "Test.Data", locName = "D0"},ADT {declName = "D0", declNumParameters = 0, declCons = Just (ConTree (Con {constrName = "D0", constrFields = Left [TypeCon (TypRef (QualName {pkgName = "main", mdlName = "Test.Data", locName = "E0"}))]}) (Con {constrName = "D1", constrFields = Left []}))}),(QualName {pkgName = "main", mdlName = "Test.Data", locName = "E0"},ADT {declName = "E0", declNumParameters = 0, declCons = Just (ConTree (Con {constrName = "E0", constrFields = Left [TypeCon (TypRef (QualName {pkgName = "main", mdlName = "Test.Data", locName = "D0"}))]}) (Con {constrName = "E1", 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 []})}),(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 []}))})]) ) + + ,testModel (Proxy :: Proxy ( Test.Data.Phantom Test.Data.Unit )) ( (TypeApp (TypeCon (QualName {pkgName = "main", mdlName = "Test.Data", locName = "Phantom"})) (TypeCon (QualName {pkgName = "main", mdlName = "Test.Data", locName = "Unit"})),[(QualName {pkgName = "main", mdlName = "Test.Data", locName = "Phantom"},ADT {declName = "Phantom", declNumParameters = 1, declCons = Just (Con {constrName = "Phantom", 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.List Bool )) ( (TypeApp (TypeCon (QualName {pkgName = "main", mdlName = "Test.Data", 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 []}))})]) ) + + ,testModel (Proxy :: Proxy ( Test.Data2.List Bool )) ( (TypeApp (TypeCon (QualName {pkgName = "main", mdlName = "Test.Data2", 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.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 []}))})]) ) + + ,testModel (Proxy :: Proxy ( Test.Data3.List Bool )) ( (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.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 ( 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 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 []})})]) ) + + ,testModel (Proxy :: Proxy ( Test.Data.RR Test.Data.Un Test.Data.Unit Test.Data.N )) ( (TypeApp (TypeApp (TypeApp (TypeCon (QualName {pkgName = "main", mdlName = "Test.Data", locName = "RR"})) (TypeCon (QualName {pkgName = "main", mdlName = "Test.Data", locName = "Un"}))) (TypeCon (QualName {pkgName = "main", mdlName = "Test.Data", locName = "Unit"}))) (TypeCon (QualName {pkgName = "main", mdlName = "Test.Data", locName = "N"})),[(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 = "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 = "RR"},ADT {declName = "RR", declNumParameters = 3, declCons = Just (ConTree (Con {constrName = "RN", constrFields = Right [("rna",TypeCon (TypVar 0)),("rnb",TypeCon (TypVar 1)),("rnc",TypeCon (TypVar 2))]}) (ConTree (Con {constrName = "RA", constrFields = Left [TypeCon (TypVar 0),TypeApp (TypeApp (TypeApp (TypeCon (TypRef (QualName {pkgName = "main", mdlName = "Test.Data", locName = "RR"}))) (TypeCon (TypVar 0))) (TypeCon (TypVar 0))) (TypeCon (TypVar 2)),TypeCon (TypVar 1)]}) (Con {constrName = "RAB", constrFields = Left [TypeCon (TypVar 0),TypeApp (TypeApp (TypeApp (TypeCon (TypRef (QualName {pkgName = "main", mdlName = "Test.Data", locName = "RR"}))) (TypeCon (TypVar 2))) (TypeCon (TypVar 1))) (TypeCon (TypVar 0)),TypeCon (TypVar 1)]})))}),(QualName {pkgName = "main", mdlName = "Test.Data", locName = "Un"},ADT {declName = "Un", declNumParameters = 0, declCons = Just (Con {constrName = "Un", constrFields = Right [("un",TypeCon (TypRef (QualName {pkgName = "ghc-prim", mdlName = "GHC.Types", locName = "Bool"})))]})}),(QualName {pkgName = "main", mdlName = "Test.Data", locName = "Unit"},ADT {declName = "Unit", declNumParameters = 0, declCons = Just (Con {constrName = "Unit", constrFields = Left []})})]) ) + + ,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.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 @@ -2,77 +2,43 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE OverloadedStrings #-} +-- {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Main where -import qualified Data.Either -import Data.List import qualified Data.Map as M import Data.Model -import Data.Word -import qualified GHC.Base -import qualified GHC.Types +import Info import Test.Data import Test.Data.Model () -import qualified Test.Data2 -import qualified Test.Data3 import Test.Tasty import Test.Tasty.HUnit --- main = makeTests -main = mainTest +t :: IO () +t = main -mainTest = defaultMain tests +main :: IO () +main = defaultMain tests tests :: TestTree -tests = testGroup "Tests" [properties, transformTests, unitTests] - -properties = testGroup "Properties" [] - -models = [typeModel (Proxy :: Proxy Void) - ,typeModel (Proxy :: Proxy Unit) - ,typeModel (Proxy :: Proxy Bool) - ,typeModel (Proxy :: Proxy Char) - ,typeModel (Proxy :: Proxy String) - ,typeModel (Proxy :: Proxy [Bool]) - ,typeModel (Proxy :: Proxy N) - ,typeModel (Proxy :: Proxy Un) - ,typeModel (Proxy :: Proxy D2) - ,typeModel (Proxy :: Proxy D4) - ,typeModel (Proxy :: Proxy A0) - ,typeModel (Proxy :: Proxy B0) - -- ,typeModel (Proxy :: Proxy Various) - -- ghc chokes on these heavily mutually dependent types - -- ,typeModel (Proxy :: Proxy MM1) - -- ,typeModel (Proxy :: Proxy MM2) - -- ,typeModel (Proxy :: Proxy MM3) - ,typeModel (Proxy :: Proxy (Phantom Unit)) - ,typeModel (Proxy :: Proxy (List Bool)) - ,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 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 (Perfect Bool)) - - -- Unsupported: higher kind - --,typeModel (Proxy :: Proxy (PerfectF Maybe Bool)) - --,typeModel (Proxy :: Proxy (Free Maybe Bool)) - ] - -tst p e = let tm = typeModel p - s = prettyShow . simpleType $ typeName tm - in testCase (unwords ["typeModel of",s]) $ simpleHTypeEnv tm @?= e +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",[])]) [["c"],["b","a"]] + ,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 = @@ -83,96 +49,31 @@ let mut = mutualGroups Just (M.fromList adjs) in testCase (unwords ["mutualGroups",show adjs]) $ mut @?= emut ------ Pretty printing --- Simplify type for test -simpleHTypeEnv tm = (simpleType $ typeName tm - ,sort . map simpleADT $ M.assocs $ typeEnv tm) - -simpleType = (TypRef . asName <$>) -simpleADT (qname,adt) = ADT (qualName qname) (declNumParameters adt) ((mdlRef <$>) <$> declCons adt) - -mdlRef :: HTypeRef -> TypeRef Name -mdlRef (TypVar v) = TypVar v -mdlRef (TypRef n) = TypRef (asName n) - -asName = Name . qualName - -pr = print -pp = putStrLn . prettyShow - --- THIS STOPPED WORKING (ghc 8.01?), Char not instance of Generic --- instance Model Char - --- Some fake instance declaration for primitive types -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) -data Word8SI deriving Generic -instance Model Word8SI - --- TODO: Fix problems with types using symbolic constructors -instance Model a => Model [a] where envType _ = envType (Proxy::Proxy (ListSI a)) - -data ListSI a deriving Generic -instance Model a => Model (ListSI a) - -instance Model () - ------ Create tests -makeTests = makeTest models --- unitTests = undefined - -thisFile = "test/Spec.hs" - -makeTest ts = appendFile thisFile $ ("\n-- Appended by makeTest\nunitTests = testGroup \"Unit tests\" [" ++ (intercalate "\n\n ," $ map (\tm -> unwords ["tst (Proxy :: Proxy (",prettyShow . simpleType . typeName $ tm,")) (",show . simpleHTypeEnv $ tm,")"]) ts)) ++ " ]" - - --- Appended by makeTest -unitTests = testGroup "Unit tests" [tst (Proxy :: Proxy ( Test.Data.Void )) ( (TypeCon (TypRef (Name "Test.Data.Void")),[ADT {declName = "Test.Data.Void", declNumParameters = 0, declCons = Nothing}]) ) - - ,tst (Proxy :: Proxy ( Test.Data.Unit )) ( (TypeCon (TypRef (Name "Test.Data.Unit")),[ADT {declName = "Test.Data.Unit", declNumParameters = 0, declCons = Just (Con {constrName = "Unit", constrFields = Left []})}]) ) - - ,tst (Proxy :: Proxy ( GHC.Types.Bool )) ( (TypeCon (TypRef (Name "GHC.Types.Bool")),[ADT {declName = "GHC.Types.Bool", declNumParameters = 0, declCons = Just (ConTree (Con {constrName = "False", constrFields = Left []}) (Con {constrName = "True", constrFields = Left []}))}]) ) - - ,tst (Proxy :: Proxy ( Main.CharSI )) ( (TypeCon (TypRef (Name "Main.CharSI")),[ADT {declName = "Main.CharSI", declNumParameters = 0, declCons = Nothing}]) ) - - ,tst (Proxy :: Proxy ( Main.ListSI Main.CharSI )) ( (TypeApp (TypeCon (TypRef (Name "Main.ListSI"))) (TypeCon (TypRef (Name "Main.CharSI"))),[ADT {declName = "Main.CharSI", declNumParameters = 0, declCons = Nothing},ADT {declName = "Main.ListSI", declNumParameters = 1, declCons = Nothing}]) ) - - ,tst (Proxy :: Proxy ( Main.ListSI GHC.Types.Bool )) ( (TypeApp (TypeCon (TypRef (Name "Main.ListSI"))) (TypeCon (TypRef (Name "GHC.Types.Bool"))),[ADT {declName = "GHC.Types.Bool", declNumParameters = 0, declCons = Just (ConTree (Con {constrName = "False", constrFields = Left []}) (Con {constrName = "True", constrFields = Left []}))},ADT {declName = "Main.ListSI", declNumParameters = 1, declCons = Nothing}]) ) - - ,tst (Proxy :: Proxy ( Test.Data.N )) ( (TypeCon (TypRef (Name "Test.Data.N")),[ADT {declName = "Test.Data.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 []}))))}]) ) - - ,tst (Proxy :: Proxy ( Test.Data.Un )) ( (TypeCon (TypRef (Name "Test.Data.Un")),[ADT {declName = "GHC.Types.Bool", declNumParameters = 0, declCons = Just (ConTree (Con {constrName = "False", constrFields = Left []}) (Con {constrName = "True", constrFields = Left []}))},ADT {declName = "Test.Data.Un", declNumParameters = 0, declCons = Just (Con {constrName = "Un", constrFields = Right [("un",TypeCon (TypRef (Name "GHC.Types.Bool")))]})}]) ) - - ,tst (Proxy :: Proxy ( Test.Data.D2 )) ( (TypeCon (TypRef (Name "Test.Data.D2")),[ADT {declName = "GHC.Types.Bool", declNumParameters = 0, declCons = Just (ConTree (Con {constrName = "False", constrFields = Left []}) (Con {constrName = "True", constrFields = Left []}))},ADT {declName = "Test.Data.D2", declNumParameters = 0, declCons = Just (Con {constrName = "D2", constrFields = Left [TypeCon (TypRef (Name "GHC.Types.Bool")),TypeCon (TypRef (Name "Test.Data.N"))]})},ADT {declName = "Test.Data.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 []}))))}]) ) - - ,tst (Proxy :: Proxy ( Test.Data.D4 )) ( (TypeCon (TypRef (Name "Test.Data.D4")),[ADT {declName = "GHC.Types.Bool", declNumParameters = 0, declCons = Just (ConTree (Con {constrName = "False", constrFields = Left []}) (Con {constrName = "True", constrFields = Left []}))},ADT {declName = "Test.Data.D4", declNumParameters = 0, declCons = Just (Con {constrName = "D4", constrFields = Left [TypeCon (TypRef (Name "GHC.Types.Bool")),TypeCon (TypRef (Name "Test.Data.N")),TypeCon (TypRef (Name "Test.Data.Unit")),TypeCon (TypRef (Name "Test.Data.N3"))]})},ADT {declName = "Test.Data.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 []}))))},ADT {declName = "Test.Data.N3", declNumParameters = 0, declCons = Just (ConTree (Con {constrName = "N1", constrFields = Left []}) (ConTree (Con {constrName = "N2", constrFields = Left []}) (Con {constrName = "N3", constrFields = Left []})))},ADT {declName = "Test.Data.Unit", declNumParameters = 0, declCons = Just (Con {constrName = "Unit", constrFields = Left []})}]) ) - - ,tst (Proxy :: Proxy ( Test.Data.A0 )) ( (TypeCon (TypRef (Name "Test.Data.A0")),[ADT {declName = "GHC.Types.Bool", declNumParameters = 0, declCons = Just (ConTree (Con {constrName = "False", constrFields = Left []}) (Con {constrName = "True", constrFields = Left []}))},ADT {declName = "Test.Data.A0", declNumParameters = 0, declCons = Just (ConTree (Con {constrName = "A0", constrFields = Left [TypeCon (TypRef (Name "Test.Data.B0")),TypeCon (TypRef (Name "Test.Data.B0")),TypeCon (TypRef (Name "Test.Data.D0")),TypeCon (TypRef (Name "GHC.Types.Bool"))]}) (Con {constrName = "A1", constrFields = Left [TypeApp (TypeCon (TypRef (Name "Test.Data.List"))) (TypeCon (TypRef (Name "GHC.Types.Bool"))),TypeApp (TypeCon (TypRef (Name "Test.Data.List"))) (TypeCon (TypRef (Name "Test.Data.Unit"))),TypeApp (TypeCon (TypRef (Name "Test.Data2.List"))) (TypeCon (TypRef (Name "GHC.Types.Bool"))),TypeApp (TypeCon (TypRef (Name "Test.Data2.List"))) (TypeCon (TypRef (Name "GHC.Types.Bool")))]}))},ADT {declName = "Test.Data.B0", declNumParameters = 0, declCons = Just (ConTree (Con {constrName = "B0", constrFields = Left [TypeCon (TypRef (Name "Test.Data.C0"))]}) (Con {constrName = "B1", constrFields = Left []}))},ADT {declName = "Test.Data.C0", declNumParameters = 0, declCons = Just (ConTree (Con {constrName = "C0", constrFields = Left [TypeCon (TypRef (Name "Test.Data.A0"))]}) (Con {constrName = "C1", constrFields = Left []}))},ADT {declName = "Test.Data.D0", declNumParameters = 0, declCons = Just (ConTree (Con {constrName = "D0", constrFields = Left [TypeCon (TypRef (Name "Test.Data.E0"))]}) (Con {constrName = "D1", constrFields = Left []}))},ADT {declName = "Test.Data.E0", declNumParameters = 0, declCons = Just (ConTree (Con {constrName = "E0", constrFields = Left [TypeCon (TypRef (Name "Test.Data.D0"))]}) (Con {constrName = "E1", constrFields = Left []}))},ADT {declName = "Test.Data.List", declNumParameters = 1, declCons = Just (ConTree (Con {constrName = "C", constrFields = Left [TypeCon (TypVar 0),TypeApp (TypeCon (TypRef (Name "Test.Data.List"))) (TypeCon (TypVar 0))]}) (Con {constrName = "N", constrFields = Left []}))},ADT {declName = "Test.Data.Unit", declNumParameters = 0, declCons = Just (Con {constrName = "Unit", constrFields = Left []})},ADT {declName = "Test.Data2.List", declNumParameters = 1, declCons = Just (ConTree (Con {constrName = "Cons2", constrFields = Left [TypeCon (TypVar 0),TypeApp (TypeCon (TypRef (Name "Test.Data2.List"))) (TypeCon (TypVar 0))]}) (Con {constrName = "Nil2", constrFields = Left []}))}]) ) - - ,tst (Proxy :: Proxy ( Test.Data.B0 )) ( (TypeCon (TypRef (Name "Test.Data.B0")),[ADT {declName = "GHC.Types.Bool", declNumParameters = 0, declCons = Just (ConTree (Con {constrName = "False", constrFields = Left []}) (Con {constrName = "True", constrFields = Left []}))},ADT {declName = "Test.Data.A0", declNumParameters = 0, declCons = Just (ConTree (Con {constrName = "A0", constrFields = Left [TypeCon (TypRef (Name "Test.Data.B0")),TypeCon (TypRef (Name "Test.Data.B0")),TypeCon (TypRef (Name "Test.Data.D0")),TypeCon (TypRef (Name "GHC.Types.Bool"))]}) (Con {constrName = "A1", constrFields = Left [TypeApp (TypeCon (TypRef (Name "Test.Data.List"))) (TypeCon (TypRef (Name "GHC.Types.Bool"))),TypeApp (TypeCon (TypRef (Name "Test.Data.List"))) (TypeCon (TypRef (Name "Test.Data.Unit"))),TypeApp (TypeCon (TypRef (Name "Test.Data2.List"))) (TypeCon (TypRef (Name "GHC.Types.Bool"))),TypeApp (TypeCon (TypRef (Name "Test.Data2.List"))) (TypeCon (TypRef (Name "GHC.Types.Bool")))]}))},ADT {declName = "Test.Data.B0", declNumParameters = 0, declCons = Just (ConTree (Con {constrName = "B0", constrFields = Left [TypeCon (TypRef (Name "Test.Data.C0"))]}) (Con {constrName = "B1", constrFields = Left []}))},ADT {declName = "Test.Data.C0", declNumParameters = 0, declCons = Just (ConTree (Con {constrName = "C0", constrFields = Left [TypeCon (TypRef (Name "Test.Data.A0"))]}) (Con {constrName = "C1", constrFields = Left []}))},ADT {declName = "Test.Data.D0", declNumParameters = 0, declCons = Just (ConTree (Con {constrName = "D0", constrFields = Left [TypeCon (TypRef (Name "Test.Data.E0"))]}) (Con {constrName = "D1", constrFields = Left []}))},ADT {declName = "Test.Data.E0", declNumParameters = 0, declCons = Just (ConTree (Con {constrName = "E0", constrFields = Left [TypeCon (TypRef (Name "Test.Data.D0"))]}) (Con {constrName = "E1", constrFields = Left []}))},ADT {declName = "Test.Data.List", declNumParameters = 1, declCons = Just (ConTree (Con {constrName = "C", constrFields = Left [TypeCon (TypVar 0),TypeApp (TypeCon (TypRef (Name "Test.Data.List"))) (TypeCon (TypVar 0))]}) (Con {constrName = "N", constrFields = Left []}))},ADT {declName = "Test.Data.Unit", declNumParameters = 0, declCons = Just (Con {constrName = "Unit", constrFields = Left []})},ADT {declName = "Test.Data2.List", declNumParameters = 1, declCons = Just (ConTree (Con {constrName = "Cons2", constrFields = Left [TypeCon (TypVar 0),TypeApp (TypeCon (TypRef (Name "Test.Data2.List"))) (TypeCon (TypVar 0))]}) (Con {constrName = "Nil2", constrFields = Left []}))}]) ) - - ,tst (Proxy :: Proxy ( Test.Data.Phantom Test.Data.Unit )) ( (TypeApp (TypeCon (TypRef (Name "Test.Data.Phantom"))) (TypeCon (TypRef (Name "Test.Data.Unit"))),[ADT {declName = "Test.Data.Phantom", declNumParameters = 1, declCons = Just (Con {constrName = "Phantom", constrFields = Left []})},ADT {declName = "Test.Data.Unit", declNumParameters = 0, declCons = Just (Con {constrName = "Unit", constrFields = Left []})}]) ) - - ,tst (Proxy :: Proxy ( Test.Data.List GHC.Types.Bool )) ( (TypeApp (TypeCon (TypRef (Name "Test.Data.List"))) (TypeCon (TypRef (Name "GHC.Types.Bool"))),[ADT {declName = "GHC.Types.Bool", declNumParameters = 0, declCons = Just (ConTree (Con {constrName = "False", constrFields = Left []}) (Con {constrName = "True", constrFields = Left []}))},ADT {declName = "Test.Data.List", declNumParameters = 1, declCons = Just (ConTree (Con {constrName = "C", constrFields = Left [TypeCon (TypVar 0),TypeApp (TypeCon (TypRef (Name "Test.Data.List"))) (TypeCon (TypVar 0))]}) (Con {constrName = "N", constrFields = Left []}))}]) ) - - ,tst (Proxy :: Proxy ( Test.Data2.List GHC.Types.Bool )) ( (TypeApp (TypeCon (TypRef (Name "Test.Data2.List"))) (TypeCon (TypRef (Name "GHC.Types.Bool"))),[ADT {declName = "GHC.Types.Bool", declNumParameters = 0, declCons = Just (ConTree (Con {constrName = "False", constrFields = Left []}) (Con {constrName = "True", constrFields = Left []}))},ADT {declName = "Test.Data2.List", declNumParameters = 1, declCons = Just (ConTree (Con {constrName = "Cons2", constrFields = Left [TypeCon (TypVar 0),TypeApp (TypeCon (TypRef (Name "Test.Data2.List"))) (TypeCon (TypVar 0))]}) (Con {constrName = "Nil2", constrFields = Left []}))}]) ) - - ,tst (Proxy :: Proxy ( Test.Data3.List GHC.Types.Bool )) ( (TypeApp (TypeCon (TypRef (Name "Test.Data3.List"))) (TypeCon (TypRef (Name "GHC.Types.Bool"))),[ADT {declName = "GHC.Types.Bool", declNumParameters = 0, declCons = Just (ConTree (Con {constrName = "False", constrFields = Left []}) (Con {constrName = "True", constrFields = Left []}))},ADT {declName = "Test.Data3.List", declNumParameters = 1, declCons = Just (ConTree (Con {constrName = "C", constrFields = Left [TypeCon (TypVar 0),TypeApp (TypeCon (TypRef (Name "Test.Data3.List"))) (TypeCon (TypVar 0))]}) (Con {constrName = "N", constrFields = Left []}))}]) ) - - ,tst (Proxy :: Proxy ( Test.Data.List (Test.Data2.List (Test.Data3.List GHC.Types.Bool)) )) ( (TypeApp (TypeCon (TypRef (Name "Test.Data.List"))) (TypeApp (TypeCon (TypRef (Name "Test.Data2.List"))) (TypeApp (TypeCon (TypRef (Name "Test.Data3.List"))) (TypeCon (TypRef (Name "GHC.Types.Bool"))))),[ADT {declName = "GHC.Types.Bool", declNumParameters = 0, declCons = Just (ConTree (Con {constrName = "False", constrFields = Left []}) (Con {constrName = "True", constrFields = Left []}))},ADT {declName = "Test.Data.List", declNumParameters = 1, declCons = Just (ConTree (Con {constrName = "C", constrFields = Left [TypeCon (TypVar 0),TypeApp (TypeCon (TypRef (Name "Test.Data.List"))) (TypeCon (TypVar 0))]}) (Con {constrName = "N", constrFields = Left []}))},ADT {declName = "Test.Data2.List", declNumParameters = 1, declCons = Just (ConTree (Con {constrName = "Cons2", constrFields = Left [TypeCon (TypVar 0),TypeApp (TypeCon (TypRef (Name "Test.Data2.List"))) (TypeCon (TypVar 0))]}) (Con {constrName = "Nil2", constrFields = Left []}))},ADT {declName = "Test.Data3.List", declNumParameters = 1, declCons = Just (ConTree (Con {constrName = "C", constrFields = Left [TypeCon (TypVar 0),TypeApp (TypeCon (TypRef (Name "Test.Data3.List"))) (TypeCon (TypVar 0))]}) (Con {constrName = "N", constrFields = Left []}))}]) ) - - ,tst (Proxy :: Proxy ( GHC.Base.Maybe Test.Data.Void )) ( (TypeApp (TypeCon (TypRef (Name "GHC.Base.Maybe"))) (TypeCon (TypRef (Name "Test.Data.Void"))),[ADT {declName = "GHC.Base.Maybe", declNumParameters = 1, declCons = Just (ConTree (Con {constrName = "Nothing", constrFields = Left []}) (Con {constrName = "Just", constrFields = Left [TypeCon (TypVar 0)]}))},ADT {declName = "Test.Data.Void", declNumParameters = 0, declCons = Nothing}]) ) - - ,tst (Proxy :: Proxy ( Data.Either.Either GHC.Types.Bool Test.Data.Unit )) ( (TypeApp (TypeApp (TypeCon (TypRef (Name "Data.Either.Either"))) (TypeCon (TypRef (Name "GHC.Types.Bool")))) (TypeCon (TypRef (Name "Test.Data.Unit"))),[ADT {declName = "Data.Either.Either", declNumParameters = 2, declCons = Just (ConTree (Con {constrName = "Left", constrFields = Left [TypeCon (TypVar 0)]}) (Con {constrName = "Right", constrFields = Left [TypeCon (TypVar 1)]}))},ADT {declName = "GHC.Types.Bool", declNumParameters = 0, declCons = Just (ConTree (Con {constrName = "False", constrFields = Left []}) (Con {constrName = "True", constrFields = Left []}))},ADT {declName = "Test.Data.Unit", declNumParameters = 0, declCons = Just (Con {constrName = "Unit", constrFields = Left []})}]) ) +namesTests :: TestTree +namesTests = testGroup "QualName Tests" [ + tstErr "" "Empty string" + ,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" + ] + 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 + ] - ,tst (Proxy :: Proxy ( Test.Data.RR Test.Data.Un Test.Data.Unit Test.Data.N )) ( (TypeApp (TypeApp (TypeApp (TypeCon (TypRef (Name "Test.Data.RR"))) (TypeCon (TypRef (Name "Test.Data.Un")))) (TypeCon (TypRef (Name "Test.Data.Unit")))) (TypeCon (TypRef (Name "Test.Data.N"))),[ADT {declName = "GHC.Types.Bool", declNumParameters = 0, declCons = Just (ConTree (Con {constrName = "False", constrFields = Left []}) (Con {constrName = "True", constrFields = Left []}))},ADT {declName = "Test.Data.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 []}))))},ADT {declName = "Test.Data.RR", declNumParameters = 3, declCons = Just (ConTree (Con {constrName = "RN", constrFields = Right [("rna",TypeCon (TypVar 0)),("rnb",TypeCon (TypVar 1)),("rnc",TypeCon (TypVar 2))]}) (ConTree (Con {constrName = "RA", constrFields = Left [TypeCon (TypVar 0),TypeApp (TypeApp (TypeApp (TypeCon (TypRef (Name "Test.Data.RR"))) (TypeCon (TypVar 0))) (TypeCon (TypVar 0))) (TypeCon (TypVar 2)),TypeCon (TypVar 1)]}) (Con {constrName = "RAB", constrFields = Left [TypeCon (TypVar 0),TypeApp (TypeApp (TypeApp (TypeCon (TypRef (Name "Test.Data.RR"))) (TypeCon (TypVar 2))) (TypeCon (TypVar 1))) (TypeCon (TypVar 0)),TypeCon (TypVar 1)]})))},ADT {declName = "Test.Data.Un", declNumParameters = 0, declCons = Just (Con {constrName = "Un", constrFields = Right [("un",TypeCon (TypRef (Name "GHC.Types.Bool")))]})},ADT {declName = "Test.Data.Unit", declNumParameters = 0, declCons = Just (Con {constrName = "Unit", constrFields = Left []})}]) ) +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 - ,tst (Proxy :: Proxy ( Data.Either.Either GHC.Types.Bool (Test.Data.List Test.Data.Unit) )) ( (TypeApp (TypeApp (TypeCon (TypRef (Name "Data.Either.Either"))) (TypeCon (TypRef (Name "GHC.Types.Bool")))) (TypeApp (TypeCon (TypRef (Name "Test.Data.List"))) (TypeCon (TypRef (Name "Test.Data.Unit")))),[ADT {declName = "Data.Either.Either", declNumParameters = 2, declCons = Just (ConTree (Con {constrName = "Left", constrFields = Left [TypeCon (TypVar 0)]}) (Con {constrName = "Right", constrFields = Left [TypeCon (TypVar 1)]}))},ADT {declName = "GHC.Types.Bool", declNumParameters = 0, declCons = Just (ConTree (Con {constrName = "False", constrFields = Left []}) (Con {constrName = "True", constrFields = Left []}))},ADT {declName = "Test.Data.List", declNumParameters = 1, declCons = Just (ConTree (Con {constrName = "C", constrFields = Left [TypeCon (TypVar 0),TypeApp (TypeCon (TypRef (Name "Test.Data.List"))) (TypeCon (TypVar 0))]}) (Con {constrName = "N", constrFields = Left []}))},ADT {declName = "Test.Data.Unit", declNumParameters = 0, declCons = Just (Con {constrName = "Unit", constrFields = Left []})}]) ) + models2 = [typeModel (Proxy :: Proxy (List Bool))] - ,tst (Proxy :: Proxy ( Test.Data.Tr (GHC.Base.Maybe Test.Data.Unit) )) ( (TypeApp (TypeCon (TypRef (Name "Test.Data.Tr"))) (TypeApp (TypeCon (TypRef (Name "GHC.Base.Maybe"))) (TypeCon (TypRef (Name "Test.Data.Unit")))),[ADT {declName = "GHC.Base.Maybe", declNumParameters = 1, declCons = Just (ConTree (Con {constrName = "Nothing", constrFields = Left []}) (Con {constrName = "Just", constrFields = Left [TypeCon (TypVar 0)]}))},ADT {declName = "Test.Data.Forest", declNumParameters = 1, declCons = Just (Con {constrName = "Forest", constrFields = Left [TypeApp (TypeCon (TypRef (Name "Test.Data.List"))) (TypeApp (TypeCon (TypRef (Name "Test.Data.Tr"))) (TypeCon (TypVar 0)))]})},ADT {declName = "Test.Data.List", declNumParameters = 1, declCons = Just (ConTree (Con {constrName = "C", constrFields = Left [TypeCon (TypVar 0),TypeApp (TypeCon (TypRef (Name "Test.Data.List"))) (TypeCon (TypVar 0))]}) (Con {constrName = "N", constrFields = Left []}))},ADT {declName = "Test.Data.Tr", declNumParameters = 1, declCons = Just (Con {constrName = "Tr", constrFields = Left [TypeCon (TypVar 0),TypeApp (TypeCon (TypRef (Name "Test.Data.Forest"))) (TypeCon (TypVar 0))]})},ADT {declName = "Test.Data.Unit", declNumParameters = 0, declCons = Just (Con {constrName = "Unit", constrFields = Left []})}]) ) + 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"] - ,tst (Proxy :: Proxy ( Test.Data.Perfect GHC.Types.Bool )) ( (TypeApp (TypeCon (TypRef (Name "Test.Data.Perfect"))) (TypeCon (TypRef (Name "GHC.Types.Bool"))),[ADT {declName = "GHC.Types.Bool", declNumParameters = 0, declCons = Just (ConTree (Con {constrName = "False", constrFields = Left []}) (Con {constrName = "True", constrFields = Left []}))},ADT {declName = "Test.Data.Fork", declNumParameters = 1, declCons = Just (Con {constrName = "Fork", constrFields = Left [TypeCon (TypVar 0),TypeCon (TypVar 0)]})},ADT {declName = "Test.Data.Perfect", declNumParameters = 1, declCons = Just (ConTree (Con {constrName = "ZeroP", constrFields = Left [TypeCon (TypVar 0)]}) (Con {constrName = "SuccP", constrFields = Left [TypeApp (TypeCon (TypRef (Name "Test.Data.Perfect"))) (TypeApp (TypeCon (TypRef (Name "Test.Data.Fork"))) (TypeCon (TypVar 0)))]}))}]) ) ] diff --git a/test/Test/Data.hs b/test/Test/Data.hs --- a/test/Test/Data.hs +++ b/test/Test/Data.hs @@ -1,23 +1,29 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE MultiParamTypeClasses ,DeriveGeneric ,DeriveDataTypeable ,ScopedTypeVariables ,GADTs ,NoMonomorphismRestriction ,DeriveGeneric ,DefaultSignatures ,TemplateHaskell ,TypeFamilies ,FlexibleContexts ,FlexibleInstances ,EmptyDataDecls #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} {- A collection of data types used for testing. -} + module Test.Data where -import Control.Exception -import Data.Char +import Data.Data import Data.Int import Data.Word - -import Data.Typeable -import Data.Data import GHC.Generics -import Data.Data -import qualified Test.Data2 as D2 -import Data.Foldable -import GHC.Exts hiding (toList) +import qualified Test.Data2 as D2 +import Test.Tasty.QuickCheck data Void deriving Generic @@ -203,3 +209,76 @@ ,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