packages feed

model 0.3 → 0.4

raw patch · 12 files changed

+567/−267 lines, 12 filesdep +convertibledep +doctestdep +filemanipdep −ListLikedep ~base

Dependencies added: convertible, doctest, filemanip, tasty-quickcheck

Dependencies removed: ListLike

Dependency ranges changed: base

Files

CHANGELOG view
@@ -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'++
README.md view
@@ -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
model.cabal view
@@ -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 <http://github.com/tittoassini/model online tutorial>. 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
src/Data/Model/Pretty.hs view
@@ -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
src/Data/Model/Types.hs view
@@ -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)
src/Data/Model/Util.hs view
@@ -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 ++ "."
src/Type/Analyse.hs view
@@ -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 ())) -}
stack.yaml view
@@ -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: - '.'
+ test/DocSpec.hs view
@@ -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
+ test/Info.hs view
@@ -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)))]}))})]) ) ]
test/Spec.hs view
@@ -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)))]}))}]) ) ]
test/Test/Data.hs view
@@ -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