model 0.2.1 → 0.2.4

raw patch · 12 files changed

+215/−97 lines, 12 filesdep ~basedep ~containersdep ~ghc-primPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base, containers, ghc-prim, model, pretty, tasty-hunit, tasty-quickcheck

API changes (from Hackage documentation)

Files

• LICENSE +2/−2
• model.cabal +59/−36
• src/Data/Model.hs +3/−2
• src/Data/Model/Class.hs +6/−4
• src/Data/Model/Instances.hs +1/−1
• src/Data/Model/Pretty.hs +21/−14
• src/Data/Model/Types.hs +53/−32
• src/Data/Model/Util.hs +51/−0
• stack.yaml +7/−0
• test/Spec.hs +3/−3
• test/Test/Data.hs +8/−2
• test/Test/Data/Model.hs +1/−1

@@ -1,4 +1,4 @@-Copyright Pasqualino `Titto` Assini (c) 2016+Copyright (c) 2016, Pasqualino `Titto` Assini   All rights reserved. @@ -13,7 +13,7 @@       disclaimer in the documentation and/or other materials provided       with the distribution. -    * Neither the name of Pasqualino `Titto` Assini nor the names of other+    * Neither the name of the copyright holder nor the names of other       contributors may be used to endorse or promote products derived       from this software without specific prior written permission. 

@@ -1,40 +1,63 @@-name:                model-version:             0.2.1-synopsis:            Derive a model of a data type using Generics-description:         See the github homepage for a 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+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 +source-repository head+    type: git+    location: https://github.com/tittoassini/model+ library-  hs-source-dirs:      src-  exposed-modules:     Data.Model,Data.Model.Class,Data.Model.Env,Data.Model.Instances,Data.Model.Pretty,Data.Model.Types,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+    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  test-suite model-test-  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-                     , ghc-prim >= 0.4.0.0-                     , tasty >= 0.11.0.2-                     , tasty-hunit-                     , tasty-hunit >= 0.9.2-                     , tasty-quickcheck-                     , tasty-quickcheck >= 0.8.4-                     , pretty-                     , containers-                     , model-  default-language:    Haskell2010--source-repository head-  type:     git-  location: https://github.com/tittoassini/model+    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

@@ -1,9 +1,10 @@ module Data.Model (-  -- |Check the <https://github.com/tittoassini/model tutorial and github repo>+  -- |Check the <https://github.com/tittoassini/model tutorial and github repo>.   module X   ) where  import Data.Model.Class as X import Data.Model.Types as X-import Data.Model.Instances as X+import Data.Model.Instances() import Data.Model.Pretty as X+import Data.Model.Util as X

@@ -28,11 +28,11 @@ import qualified GHC.Generics                   as G import           Type.Analyse --- | Return the model for the given type+-- |Return the model for the given type typeModel :: AsType (Ana a) => Proxy a -> HTypeModel typeModel p = withEnv (asTypeP p) --- We feed to the analyser the abstract version of the type+-- We feed to the analyser the abstracted version of the type -- in order to distinguish between variable and non variable positions asTypeP :: forall a. AsType (Ana a) => Proxy a -> State Env HType asTypeP _ = asType (undefined :: Ana a)@@ -67,11 +67,11 @@   envType p = addCT_ False p $ gcons (from (undefined :: a))  -- |Use the given constructors tree as model for the given type, returns the build type--- -- Exported so that it can be used to overwrite default definitions useCT :: Typeable a => Maybe (ConTree String HTypeRef) -> proxy a -> State Env (Type (TypeRef QualName)) useCT ct p = addCT_ True p (return ct) +addCT_ :: Typeable a => Bool -> proxy a -> State Env (Maybe (ConTree String HTypeRef)) -> State Env (Type (TypeRef QualName)) addCT_ useLocalString p mct =   let tr = typeRep p       (tc,ts) = splitTyConApp tr@@ -123,6 +123,7 @@     where       toE (ls,[]) = Left ls       toE ([],rs) = Right rs+      toE p = error . unwords $ ["toE: unexpected parameter",show p]    gtype = notThere   gtypeN = notThere@@ -168,4 +169,5 @@ unR :: (l :+: r) a -> r a unR = error "unR should be used only for type recovery operations" -notThere = error "never called"+notThere :: t+notThere = error "this should be never called"

@@ -1,4 +1,4 @@--- |Instances of `Model` for common types (Bool,Maybe,Either)+-- |Instances of `Model` for common types (Bool,Maybe,Either). module Data.Model.Instances where  import           Data.Model.Class

@@ -23,26 +23,31 @@     ,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 e adt)) (M.assocs e)--stringADT env adt = ADT (localName . declName $ adt) (declNumParameters adt) (((localName <$>) <$>) . conTreeNameMap localName <$> declCons adt)+     ++ map (\(ref,adt) -> pPrint ref <+> text "->" <+> pPrint (stringADT adt)) (M.assocs e)+    where+      stringADT adt = ADT (localName . declName $ adt) (declNumParameters adt) (((localName <$>) <$>) . conTreeNameMap localName <$> declCons adt) +localName :: S.StringLike s => s -> Name localName = Name . S.toString  instance (Pretty n,Pretty cn,Pretty r) => Pretty (ADT n cn r) where pPrint = prettyADT "" '≡' +prettyADT :: (Pretty name, Pretty consName, Pretty ref) => String -> Char -> ADT name consName ref -> Doc prettyADT pre eq adt = text pre <+> pPrint (declName adt) <+> vars adt <+> maybe (text "") (\c -> char eq <+> pPrint c) (declCons adt) +vars :: ADT name consName ref -> Doc vars adt = sep . map varP . map (\x -> x-1) $ [1 .. declNumParameters adt] +-- |Convert a variable number (0,1,..) to a name ('a','b',..)+varP :: Integral n => n -> Doc varP n = char $ 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 (\(n,t) -> pPrint n <+> "::" <+> pPrint t) nfs)) <> "}"+  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 tr@(ConTree l r) = let (h:t) = constructors tr-                            in vcat (char ' ' <+> pPrint h : map (\c -> (char '|') <+> pPrint c) t)+  pPrint conTree = let (h:t) = constructors conTree+                   in vcat (char ' ' <+> pPrint h : map (\c -> (char '|') <+> pPrint c) t)  instance Pretty n => Pretty (TypeRef n) where    pPrint (TypVar v)   = varP v@@ -50,13 +55,6 @@  instance Pretty r => Pretty (Type r) where pPrint = printPrettyType False -data PrettyType r = PrettyType Bool (TypeN r)-printPrettyType n = pPrint . PrettyType n . typeN--instance Pretty r => Pretty (PrettyType r) where-  pPrint (PrettyType _ (TypeN f [])) = pPrint f-  pPrint (PrettyType n (TypeN f as)) = maybeParens n (pPrint f <+> spacedP (map (PrettyType True) as))- instance Pretty r => Pretty (TypeN r) where   pPrint (TypeN f []) = pPrint f   pPrint (TypeN f as) = parens (pPrint f <+> spacedP as)@@ -67,6 +65,15 @@  instance Pretty Doc where pPrint d = d +data PrettyType r = PrettyType Bool (TypeN r)++printPrettyType :: Pretty r => Bool -> Type r -> Doc+printPrettyType n = pPrint . PrettyType n . typeN++instance Pretty r => Pretty (PrettyType r) where+  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 spacedP :: Pretty a => [a] -> Doc spacedP = sep . map pPrint@@ -75,6 +82,6 @@ vspacedP :: Pretty a => [a] -> Doc vspacedP = sep . intersperse (text "") . map pPrint --- |Intercalate with '.'+-- |Intercalate with a dot dotted :: [String] -> Doc dotted = text . intercalate "."

@@ -1,13 +1,13 @@-{- |A model for simple algebraic data types.--}+-- |A model for simple algebraic data types. {-# LANGUAGE DeriveAnyClass    #-} {-# LANGUAGE DeriveFoldable    #-} {-# LANGUAGE DeriveFunctor     #-} {-# LANGUAGE DeriveGeneric     #-}-{-# LANGUAGE DeriveTraversable ,FlexibleInstances #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE FlexibleInstances #-} module Data.Model.Types(   -- *Model-  TypeModel(..),TypeEnv+  TypeModel(..),TypeEnv,typeADTs   ,ADT(..)   ,ConTree(..)   ,Type(..),TypeN(..),TypeRef(..)@@ -19,28 +19,29 @@   ,adtNamesMap   --,typeADTs   ,typeN,typeA-  ,constructors,conTreeNameMap,conTreeTypeMap,conTreeTypeList,conTreeTypeFoldMap,fieldsTypes,fieldsNames+  ,constructors,constructorInfo,conTreeNameMap,conTreeTypeMap,conTreeTypeList,conTreeTypeFoldMap,fieldsTypes,fieldsNames    -- *Handy aliases   ,HTypeEnv,HTypeModel,HADT,HType,HTypeRef-  -- ,HEnv    -- *Utilities-  ,solve,solveAll,unVar+  ,solve,solveAll,unVar,getHRef    -- *Re-exports   ,module GHC.Generics,Proxy(..)-  -- ,S.StringLike(),S.toString,S.fromString+   ) where +import           Control.Applicative import           Control.DeepSeq-import           Data.Bifunctor  (first,second)+import           Data.Bifunctor       (first, second)+import           Data.List+import qualified Data.ListLike.String as S+import qualified Data.Map             as M+import           Data.Maybe import           Data.Proxy-import           Data.Word       (Word8)+import           Data.Word            (Word8) import           GHC.Generics-import qualified Data.Map as M-import qualified Data.ListLike.String           as S-import Data.List  -- |Haskell Environment type HTypeEnv = TypeEnv String String (TypeRef QualName) QualName@@ -74,7 +75,9 @@   }   deriving (Eq, Ord, Show, NFData, Generic) ---typeADTs = M.elems . typeEnv+-- |The ADTs defined in the TypeModel+typeADTs :: TypeModel adtName consName inRef k -> [ADT adtName consName inRef]+typeADTs = M.elems . typeEnv  -- |A map of all the ADTs that are directly or indirectly referred by a type, indexed by a type reference type TypeEnv adtName consName inRef exRef = M.Map exRef (ADT adtName consName inRef)@@ -130,7 +133,8 @@   deriving (Eq, Ord, Show, NFData, Generic)  -- |Return the list of constructors in definition order-constructors c@(Con _ _) = [c]+constructors :: ConTree t t1 -> [ConTree t t1]+constructors c@(Con _ _)   = [c] constructors (ConTree l r) = constructors l ++ constructors r  -- |Return just the field types@@ -139,18 +143,32 @@ fieldsTypes (Right nts) = map snd nts  -- |Return just the field names (or an empty list if unspecified)-fieldsNames (Left _)   = []+fieldsNames :: Either t [(a, t1)] -> [t1]+fieldsNames (Left _)    = [] 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 [])+constructorInfo :: Eq consName => consName -> ConTree consName t -> Maybe ([Bool], [Type t])+constructorInfo consName = (first reverse <$>) . loc []+  where+    -- |Locate constructor in tree+    loc bs (Con n ps) | n == consName = Just (bs,fieldsTypes ps)+                      | otherwise = Nothing+    loc bs (ConTree l r) = loc (False:bs) l <|> loc (True:bs) r+ -- GHC won't derive these instances automatically instance Functor (ConTree name) where-  fmap f (ConTree l r) = ConTree (fmap f l) (fmap f r)-  fmap f (Con n (Left ts)) = Con n (Left $ (fmap . fmap) f ts)+  fmap f (ConTree l r)      = ConTree (fmap f l) (fmap f r)+  fmap f (Con n (Left ts))  = Con n (Left $ (fmap . fmap) f ts)   fmap f (Con n (Right ts)) = Con n (Right $ (fmap . fmap . fmap) f ts)  instance Foldable (ConTree name) where-   foldMap f (ConTree l r) = foldMap f l `mappend` foldMap f r-   foldMap f (Con _ (Left ts)) = mconcat . map (foldMap f) $ ts+   foldMap f (ConTree l r)       = foldMap f l `mappend` foldMap f r+   foldMap f (Con _ (Left ts))   = mconcat . map (foldMap f) $ ts    foldMap f (Con _ (Right nts)) = mconcat . map (foldMap f . snd) $ nts  instance Traversable (ConTree name) where@@ -207,15 +225,23 @@  -- |Convert from TypeN to Type typeA :: TypeN ref -> Type ref-typeA (TypeN t ts) = app (TypeCon t) (map typeA ts)-  where app t [] = t-        app t (x:xs) = app (TypeApp t x) xs+typeA (TypeN tf ts) = foldl TypeApp (TypeCon tf) (map typeA ts)  -- |A reference to a type data TypeRef name = TypVar Word8  -- ^Type variable                   | TypRef name   -- ^Type reference   deriving (Eq, Ord, Show, NFData, Generic, Functor, Foldable, Traversable) +-- |Remove variable references (for example if we know that a type is fully saturated and cannot contain variables)+unVar :: TypeRef t -> t+unVar (TypVar _) = error "Unexpected variable"+unVar (TypRef n) = n++-- |Extract reference+getHRef :: TypeRef a -> Maybe a+getHRef (TypRef r) = Just r+getHRef (TypVar _) = Nothing+ -- |A fully qualified Haskell name data QualName = QualName {pkgName,mdlName,locName :: String}               deriving (Eq, Ord, Show, NFData, Generic)@@ -240,20 +266,15 @@  instance S.StringLike Name where   toString (Name n)= n-  fromString n = Name n+  fromString = Name  -- Utilities --- |Remove variable references (for example if we know that a type is fully saturated and cannot contain variables)-unVar (TypVar _) = error "Unexpected variable"-unVar (TypRef n) = n- -- |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 = (\r -> solve r 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 = case M.lookup k e of-     Nothing -> error $ unwords ["Unknown reference to",show k]-     Just v -> v+solve k e = fromMaybe (error $ unwords ["Unknown reference to",show k]) (M.lookup k e)+

@@ -0,0 +1,51 @@+module Data.Model.Util(mutualGroups,dependencies,Errors) where++import           Control.Monad+import           Control.Monad.Trans.State+import           Data.Foldable             (toList)+import           Data.List+import qualified Data.Map                  as M+import           Data.Maybe++-- |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]]+mutualGroups getRef env = recs [] (M.keys env)+  where+    deps n = unsafely (dependencies 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)++-- |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"]+--+-- >>> 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+    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})+             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 [] [])++data RecState r = RecState {seen::[r],errors::Errors} deriving Show++type Errors = [String]

@@ -0,0 +1,7 @@+pvp-bounds: lower++resolver: lts-6.30+# resolver: lts-8.5++packages:+- '.'

@@ -5,13 +5,13 @@ {-# LANGUAGE OverloadedStrings         #-} {-# LANGUAGE ScopedTypeVariables       #-} {-# LANGUAGE StandaloneDeriving        #-}-import           Data.Bifunctor+--import           Data.Bifunctor import qualified Data.Either import           Data.List import qualified Data.Map              as M import           Data.Model-import           Data.Traversable-import           Data.Typeable+--import           Data.Traversable+--import           Data.Typeable import           Data.Word import qualified GHC.Base import qualified GHC.Types

@@ -75,7 +75,13 @@             deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)  -- non-recursive data type-data Various = V1 (Maybe Bool) | V2 Bool (Either Bool (Maybe Bool))+data Various = V1 (Maybe Bool)+             -- | V2 Bool (Either Bool (Maybe Bool)) (N,N,N)+             | V2 Bool (Either Bool (Maybe Bool))+             | VF Float Double Double+             | VW Word Word8 Word16 Word32 Word64+             | VI Int Int8 Int16 Int32 Int64+             | VII Integer Integer Integer               deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)  -- Phantom type@@ -161,7 +167,7 @@             deriving (Eq, Ord, Read, Show, Typeable, Data, Generic,Functor,Foldable,Traversable)  data Tree a = Node (Tree a) (Tree a) | Leaf a-            deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)+            deriving (Eq, Ord, Read, Show, Typeable, Data, Generic, Foldable)  -- Example schema from: http://mechanical-sympathy.blogspot.co.uk/2014/05/simple-binary-encoding.html data Car = Car {

@@ -37,7 +37,7 @@ instance Model D0 instance Model E0 -instance Model Various+--instance Model Various instance Model a => Model (Phantom a) instance Model a => Model (Data2.List a) instance Model a => Model (Data3.List a)