model 0.2.4 → 0.3
raw patch · 10 files changed
+312/−95 lines, 10 filesdep −tasty-quickcheckdep ~basedep ~model
Dependencies removed: tasty-quickcheck
Dependency ranges changed: base, model
Files
- CHANGELOG +6/−0
- README.md +177/−0
- model.cabal +48/−57
- src/Data/Model/Class.hs +2/−1
- src/Data/Model/Pretty.hs +32/−7
- src/Data/Model/Types.hs +2/−2
- src/Data/Model/Util.hs +19/−14
- stack.yaml +3/−4
- test/Spec.hs +22/−10
- test/Test/Data/Model.hs +1/−0
+ CHANGELOG view
@@ -0,0 +1,6 @@+Significant and compatibility-breaking changes.++Version 0.3:+- Data.Model.Util:+ - Removed 'dependencies'+ - Added the (similar but not identical) function 'transitiveClosure'
+ README.md view
@@ -0,0 +1,177 @@++[](https://travis-ci.org/tittoassini/model) [](http://hackage.haskell.org/package/model)++With `model` you can easily derive models of Haskell data types.++Let's see some code.++We need a couple of GHC extensions:++```haskell+{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}+```++Import the library:++```haskell+import Data.Model+```++To derive a model of a data type we need to make it an instance of the `Generic` and `Model` classes.++For data types without parameters, we can do it directly in the `deriving` clause of the definition:++```haskell+data Direction = North | South | Center | East | West deriving (Show,Generic,Model)+```++For data types with parameters we currently need a separate instance declaration for `Model`:++```haskell+data Couple a b = Couple a b deriving (Show,Generic)+```++```haskell+instance (Model a,Model b) => Model (Couple a b)+```++Instances for a few common types (Bool,Maybe,Either..) are already predefined.++We use `typeModel` to get the model for the given type plus its full environment, that's to say the models of all the data types referred to, directly or indirectly by the data type.++We pass the type using a Proxy.++```haskell+typeModel (Proxy:: Proxy (Couple Direction Bool))+-> TypeModel+-> { typeName =+-> TypeApp+-> (TypeApp+-> (TypeCon+-> QualName+-> { pkgName = "main" , mdlName = "Main" , locName = "Couple" })+-> (TypeCon+-> QualName+-> { pkgName = "main" , mdlName = "Main" , locName = "Direction" }))+-> (TypeCon+-> QualName+-> { pkgName = "ghc-prim"+-> , mdlName = "GHC.Types"+-> , locName = "Bool"+-> })+-> , typeEnv =+-> fromList+-> [ ( 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 = "Main" , locName = "Couple" }+-> , ADT+-> { declName = "Couple"+-> , declNumParameters = 2+-> , declCons =+-> Just+-> Con+-> { constrName = "Couple"+-> , constrFields = Left [ TypeCon (TypVar 0) , TypeCon (TypVar 1) ]+-> }+-> }+-> )+-> , ( QualName+-> { pkgName = "main" , mdlName = "Main" , locName = "Direction" }+-> , ADT+-> { declName = "Direction"+-> , declNumParameters = 0+-> , declCons =+-> Just+-> (ConTree+-> (ConTree+-> Con { constrName = "North" , constrFields = Left [] }+-> Con { constrName = "South" , constrFields = Left [] })+-> (ConTree+-> Con { constrName = "Center" , constrFields = Left [] }+-> (ConTree+-> Con { constrName = "East" , constrFields = Left [] }+-> Con { constrName = "West" , constrFields = Left [] })))+-> }+-> )+-> ]+-> }+```+++That's a lot of information, let's show it in a prettier and more compact way:++```haskell+pPrint $ typeModel (Proxy:: Proxy (Couple Direction Bool))+-> Type:+-> main.Main.Couple main.Main.Direction+-> ghc-prim.GHC.Types.Bool -> Couple Direction Bool+-> Environment:+-> ghc-prim.GHC.Types.Bool -> Bool ≡ False+-> | True+-> main.Main.Couple -> Couple a b ≡ Couple a b+-> main.Main.Direction -> Direction ≡ North+-> | South+-> | Center+-> | East+-> | West+```+++Data types with symbolic names are also supported:++```haskell+instance (Model a) => Model [a]+```++```haskell+pPrint $ typeModel (Proxy:: Proxy [Bool])+-> Type:+-> ghc-prim.GHC.Types.[] ghc-prim.GHC.Types.Bool -> [] Bool+-> Environment:+-> ghc-prim.GHC.Types.Bool -> Bool ≡ False+-> | True+-> ghc-prim.GHC.Types.[] -> [] a ≡ []+-> | : a (ghc-prim.GHC.Types.[] a)+```+++### Installation++Get the latest stable version from [hackage](https://hackage.haskell.org/package/model).++### Compatibility++Tested with [ghc](https://www.haskell.org/ghc/) 7.10.3 and 8.0.2.++### Known Bugs and Infelicities++* No support for variables of higher kind.++ For example, we cannot define a `Model` instance for `Higher`:++ `data Higher f a = Higher (f a) deriving Generic`++ as `f` has kind `*->*`:++* Parametric data types cannot derive `Model` in the `deriving` clause and need to define an instance separately++ For example:++ `data Couple a b = Couple a b Bool deriving (Generic,Model)`++ won't work, we need a separate instance:++ `instance (Model a,Model b) => Model (Couple a b)`++* Works incorrectly with data types with more than 9 type variables.
model.cabal view
@@ -1,63 +1,54 @@-name: model-version: 0.2.4-cabal-version: >=1.10-build-type: Simple-license: BSD3-license-file: LICENSE-copyright: Copyright: (c) 2016 Pasqualino `Titto` Assini-maintainer: tittoassini@gmail.com-homepage: http://github.com/tittoassini/model-synopsis: Derive a model of a data type using Generics-description:- See the <http://github.com/tittoassini/model online tutorial>-category: Data,Reflection,Generics-author: Pasqualino `Titto` Assini-tested-with: GHC ==7.10.3 GHC ==8.0.2-extra-source-files:- stack.yaml+name: model+version: 0.3+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+license: BSD3+license-file: LICENSE+author: Pasqualino `Titto` Assini+maintainer: tittoassini@gmail.com+copyright: Copyright: (c) 2016 Pasqualino `Titto` Assini+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+extra-source-files: stack.yaml,README.md,CHANGELOG source-repository head- type: git- location: https://github.com/tittoassini/model+ type: git+ location: https://github.com/tittoassini/model library- exposed-modules:- Data.Model- Data.Model.Class- Data.Model.Env- Data.Model.Instances- Data.Model.Pretty- Data.Model.Types- Data.Model.Util- Type.ANat- Type.Analyse- build-depends:- base >=4.7 && <5,- containers >=0.5.6.2,- deepseq >=1.4,- pretty >=1.1.2.0,- transformers >=0.4,- ListLike >=4.2.1- default-language: Haskell2010- hs-source-dirs: src- ghc-options: -Wall -fno-warn-orphans+ hs-source-dirs: src+ exposed-modules: Data.Model+ , Data.Model.Class+ , Data.Model.Env+ , Data.Model.Instances+ , Data.Model.Pretty+ , Data.Model.Types+ , Data.Model.Util+ , Type.ANat,Type.Analyse+ build-depends: base >= 4.8 && < 5+ , containers >= 0.5.6.2+ , deepseq >= 1.4+ , pretty >= 1.1.2.0+ , transformers >= 0.4+ , ListLike >= 4.2.1+ default-language: Haskell2010+ other-extensions: DataKinds, DefaultSignatures, DeriveAnyClass, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, FlexibleContexts, FlexibleInstances, NoMonomorphismRestriction, OverloadedStrings, PolyKinds, ScopedTypeVariables, TupleSections, TypeFamilies, TypeOperators, UndecidableInstances+ ghc-options: -Wall -fno-warn-orphans test-suite model-test- type: exitcode-stdio-1.0- main-is: Spec.hs- build-depends:- base >=4.7 && <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 >=0.2.4- default-language: Haskell2010- hs-source-dirs: test- other-modules:- Test.Data- Test.Data2- Test.Data3- Test.Data.Model+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ other-modules: Test.Data,Test.Data2,Test.Data3,Test.Data.Model+ build-depends: base >= 4.8 && < 5+ , ghc-prim >= 0.3.1.0+ , tasty >= 0.11.0.2+ , tasty-hunit >= 0.9.2+ , pretty >= 1.1.2.0+ , containers >= 0.5.6.2+ , model+ default-language: Haskell2010+
src/Data/Model/Class.hs view
@@ -102,7 +102,8 @@ gtypeN = notThere -- |Datatypes with single constructor only-instance (GModel a, Datatype d, Constructor c) => GModel (M1 D d (M1 C c a)) where+--instance (GModel a, Datatype d, Constructor c) => GModel (M1 D d (M1 C c a)) where+instance (GModel a, Constructor c) => GModel (M1 D d (M1 C c a)) where gcons x = Just <$> gcontree (unM1 x) gcontree = notThere gtype = notThere
src/Data/Model/Pretty.hs view
@@ -1,11 +1,13 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} -- |Pretty instances for the model types module Data.Model.Pretty(+ CompactPretty(..) -- *Utilities- dotted,spacedP,vspacedP,varP+ ,dotted,spacedP,vspacedP,varP -- *Re-exports ,Pretty(..),prettyShow ) where@@ -17,13 +19,36 @@ import Data.Model.Types import Text.PrettyPrint.HughesPJClass -instance( Pretty exRef,Ord exRef,Show exRef,S.StringLike adtName,S.StringLike consName,S.StringLike ref) => Pretty (TypeModel adtName consName (TypeRef ref) exRef) where+-- |Compact representation: a value enveloped in CompactPretty will have only its first lines displayed+data CompactPretty a = CompactPretty a++instance Pretty a => Pretty (CompactPretty a) where pPrint (CompactPretty a) = text . shorter . prettyShow $ a++shorter :: String -> String+shorter s =+ let ln = lines s+ l = length ln+ in if l > 11+ 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 pPrint (TypeModel t e) = vcat $ [ text "Type:" ,pPrint t <+> text "->" <+> pPrint (localName . declName <$> solveAll e t)- -- ,text "" -- Results in a split display ,text "Environment:"]- ++ map (\(ref,adt) -> pPrint ref <+> text "->" <+> pPrint (stringADT adt)) (M.assocs e)+ ++ map (\(ref,adt) -> pPrint ref <+> text "->" <+> (pPrint . CompactPretty . stringADT $ adt)) (M.assocs e) where stringADT adt = ADT (localName . declName $ adt) (declNumParameters adt) (((localName <$>) <$>) . conTreeNameMap localName <$> declCons adt) @@ -47,11 +72,11 @@ 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)+ in vcat (char ' ' <+> pPrint h : map (\c -> char '|' <+> pPrint c) t) instance Pretty n => Pretty (TypeRef n) where- pPrint (TypVar v) = varP v- pPrint (TypRef s) = pPrint s+ pPrint (TypVar v) = varP v+ pPrint (TypRef s) = pPrint s instance Pretty r => Pretty (Type r) where pPrint = printPrettyType False
src/Data/Model/Types.hs view
@@ -272,9 +272,9 @@ -- |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+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 ["Unknown reference to",show k]) (M.lookup k e)+solve k e = fromMaybe (error $ unwords ["solve:Unknown reference to",show k]) (M.lookup k e)
src/Data/Model/Util.hs view
@@ -1,4 +1,4 @@-module Data.Model.Util(mutualGroups,dependencies,Errors) where+module Data.Model.Util (mutualGroups, transitiveClosure, Errors) where import Control.Monad import Control.Monad.Trans.State@@ -14,38 +14,43 @@ mutualGroups :: (Ord r, Show r, Foldable t) => (a -> Maybe r) -> M.Map r (t a) -> [[r]] mutualGroups getRef env = recs [] (M.keys env) where- deps n = unsafely (dependencies getRef env n)+ 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 ((n:mutual):gs) (ns \\ mutual)+ in recs (mutual:gs) (ns \\ mutual) --- |Return a list of the unique recursive dependencies of n in env--- excluding n, even if self-recursive------ >>> dependencies Just (M.fromList [("a",["b","c"]),("b",["b","d","d","c"]),("c",[]),("d",["a"])]) "a"--- Right ["b","d","c"]+-- >>>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 ----- >>> dependencies Just (M.fromList [("a",["b","c"]),("b",["b","d","d","c"]),("c",[]),("d",["a"])]) "b"--- Right ["d","a","c"]-dependencies :: (Ord r, Show r, Foldable t) => (a -> Maybe r) -> M.Map r (t a) -> r -> Either Errors [r]-dependencies getRef env = execRec . deps+-- >>> 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 getRef env = execRec . deps where deps n = do present <- (n `elem`) <$> gets seen unless present $ do modify (\st -> st {seen=n:seen st}) case M.lookup n env of- Nothing -> modify (\st -> st {errors=(unwords ["Unknown reference to",show n]):errors st})+ Nothing -> modify (\st -> st {errors=unwords ["transitiveClosure:Unknown reference to",show 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 (tail . reverse . seen $ st) else Left (errors st)) $ execState op (RecState [] [])+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]
stack.yaml view
@@ -1,7 +1,6 @@-pvp-bounds: lower--resolver: lts-6.30-# resolver: lts-8.5+resolver: lts-6.31+# resolver: lts-7.21+# resolver: lts-8.13 packages: - '.'
test/Spec.hs view
@@ -4,24 +4,22 @@ {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}---import Data.Bifunctor++module Main where+ import qualified Data.Either import Data.List-import qualified Data.Map as M+import qualified Data.Map as M import Data.Model---import Data.Traversable---import Data.Typeable import Data.Word import qualified GHC.Base import qualified GHC.Types import Test.Data-import Test.Data.Model+import Test.Data.Model () import qualified Test.Data2 import qualified Test.Data3 import Test.Tasty import Test.Tasty.HUnit-import Test.Tasty.QuickCheck as QC -- main = makeTests main = mainTest@@ -29,7 +27,7 @@ mainTest = defaultMain tests tests :: TestTree-tests = testGroup "Tests" [properties, unitTests]+tests = testGroup "Tests" [properties, transformTests, unitTests] properties = testGroup "Properties" [] @@ -71,6 +69,20 @@ s = prettyShow . simpleType $ typeName tm in testCase (unwords ["typeModel of",s]) $ simpleHTypeEnv tm @?= e +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"]]+ ]+ where+ testTrc adjs start etrc =+ let Right trc = transitiveClosure Just (M.fromList adjs) start+ in testCase (unwords ["transitiveClosure",show adjs,start]) $ trc @?= etrc++ testMutual adjs emut =+ let mut = mutualGroups Just (M.fromList adjs)+ in testCase (unwords ["mutualGroups",show adjs]) $ mut @?= emut+ ----- Pretty printing -- Simplify type for test simpleHTypeEnv tm = (simpleType $ typeName tm@@ -80,8 +92,8 @@ 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)+mdlRef (TypVar v) = TypVar v+mdlRef (TypRef n) = TypRef (asName n) asName = Name . qualName
test/Test/Data/Model.hs view
@@ -42,6 +42,7 @@ instance Model a => Model (Data2.List a) instance Model a => Model (Data3.List a) instance Model a => Model (List a)+instance Model a => Model (ListS a) instance Model a => Model (Tree a) instance (Model a, Model b, Model c) => Model (RR a b c) instance Model Expr