zm 0.2.4 → 0.3
raw patch · 17 files changed
+294/−181 lines, 17 filesdep +convertibledep +doctestdep +eitherdep −ListLikedep ~basedep ~bytestringdep ~containers
Dependencies added: convertible, doctest, either, filemanip
Dependencies removed: ListLike
Dependency ranges changed: base, bytestring, containers, cryptonite, deepseq, flat, memory, model, mtl, pretty, tasty, tasty-hunit, tasty-quickcheck, text, timeit, transformers, zm
Files
- README.md +4/−2
- src/ZM.hs +3/−6
- src/ZM/Abs.hs +79/−21
- src/ZM/Dynamic.hs +3/−3
- src/ZM/Pretty.hs +35/−15
- src/ZM/Transform.hs +1/−11
- src/ZM/Types.hs +67/−43
- src/ZM/Util.hs +4/−5
- stack.yaml +4/−7
- stack710.yaml +4/−3
- stack801.yaml +2/−3
- stack802.yaml +2/−5
- stack821.yaml +4/−0
- test/DocSpec.hs +15/−0
- test/Info.hs +12/−6
- test/Spec.hs +12/−17
- zm.cabal +43/−34
README.md view
@@ -1,5 +1,7 @@ -[](https://travis-ci.org/tittoassini/zm) [](http://hackage.haskell.org/package/zm)+[](https://travis-ci.org/Quid2/zm) [](http://hackage.haskell.org/package/zm)+[](http://stackage.org/nightly/package/zm)+[](http://stackage.org/lts/package/zm) Haskell implementation of 正名 (read as: [Zhèng Míng](https://translate.google.com/#auto/en/%E6%AD%A3%E5%90%8D)) a minimalistic, expressive and language independent data modelling language ([specs](http://quid2.org/docs/ZhengMing.pdf)). @@ -315,7 +317,7 @@ ### Data Exchange -For an example of using canonical data types as a data exchange mechanism see [top](https://github.com/tittoassini/top), the Type Oriented Protocol.+For an example of using canonical data types as a data exchange mechanism see [top](https://github.com/Quid2/top), the Type Oriented Protocol. ### Haskell Compatibility
src/ZM.hs view
@@ -1,15 +1,12 @@ module ZM(- -- |Check the <https://github.com/tittoassini/typed tutorial and github repo>.+ -- |Check the <https://github.com/tittoassini/zm tutorial and github repo>. module X- --,module Data.Model- --,module ZM.BLOB ) where -import Data.Flat as X-import Data.Model as X hiding (Name)+import Data.Flat as X+import Data.Model as X hiding (Name) import ZM.Abs as X import ZM.BLOB as X hiding (content)---import ZM.Class as X import ZM.Dynamic as X import ZM.Model () import ZM.Pretty as X
src/ZM/Abs.hs view
@@ -4,13 +4,25 @@ {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-} -- |Derive absolute/canonical data type models-module ZM.Abs (absType,absTypeModel,absTypeModelMaybe) where+module ZM.Abs+ ( absType+ , absTypeModel+ , absTypeModelMaybe+ , absEnv+ , refErrors+ , kindErrors+ ) where import "mtl" Control.Monad.Reader-import qualified Data.ListLike.String as L-import qualified Data.Map as M+import Data.Bifunctor+import Data.Convertible+import Data.Foldable (toList)+import Data.List+import qualified Data.Map as M+import Data.Maybe import Data.Model import ZM.Types @@ -20,7 +32,7 @@ -- |Derive an absolute type model for a type, or throw an error if derivation is impossible absTypeModel :: Model a => Proxy a -> AbsTypeModel-absTypeModel = either error id . absTypeModelMaybe+absTypeModel = either (error . unlines) id . absTypeModelMaybe {- | Derive an absolute type model for a type, provided that:@@ -31,34 +43,36 @@ * has higher kind variables * is mutually recursive with other data types -}-absTypeModelMaybe :: Model a => Proxy a -> Either String AbsTypeModel+absTypeModelMaybe :: Model a => Proxy a -> Either Errors AbsTypeModel absTypeModelMaybe a = let (TypeModel t henv) = typeModel a- names = M.keys henv+ in (\(refEnv,adtEnv) -> TypeModel (solveAll refEnv t) adtEnv) <$> absEnvs henv - -- TODO: Check for higher kind variables (currently not required as they cannot be present due to limitations in the 'model' library)+absEnv :: M.Map QualName (ADT String String (TypeRef QualName)) -> Either Errors AbsEnv+absEnv = (snd <$>) . absEnvs - -- Check for forbidden mutual references- errs = filter ((> 1) . length) $ mutualGroups getHRef henv- in if null errs- then- -- convert environment and type to absolute form- let adtEnv :: [(AbsRef, AbsADT)]- adtEnv = runReader (mapM absADT names) henv+absEnvs :: M.Map QualName (ADT String String (TypeRef QualName)) -> Either [String] (M.Map QualName AbsRef, M.Map AbsRef AbsADT)+absEnvs henv =+ let envs = second M.fromList . first M.fromList . unzip $ runReader (mapM (\n -> (\m -> ((n,fst m),m)) <$> absADT n) (M.keys henv)) henv - qnEnv :: M.Map QualName AbsRef- qnEnv = M.fromList $ zip names (map fst adtEnv)- in Right (TypeModel (solveAll qnEnv t) (M.fromList adtEnv))- else Left .- unlines- . map (\ms -> unwords ["Found mutually recursive types", unwords . map prettyShow $ ms]) $ errs+ -- It is not necessary to check for:+ -- higher kind variables as they cannot be present due to limitations in the 'model' library+ -- and for missing refs, as the compiler would not allow them + -- Still need to check for forbidden mutual references+ in const envs <$> (properMutualGroups getHRef henv >>= checkMutualErrors)+ where+ checkMutualErrors mgroups =+ if null mgroups+ then Right ()+ else Left $ map (\g-> unwords ["Found mutually recursive types",prettyShow g]) mgroups+ absADT :: QualName -> Reader HTypeEnv (AbsRef, AbsADT) absADT qn = do hadt <- solve qn <$> ask cs' <- mapM (mapM (adtRef qn)) $ declCons hadt - let adt :: AbsADT = adtNamesMap L.fromString L.fromString $ ADT (declName hadt) (declNumParameters hadt) cs'+ let adt :: AbsADT = adtNamesMap convert convert $ ADT (declName hadt) (declNumParameters hadt) cs' return (absRef adt,adt) adtRef :: QualName -> HTypeRef -> Reader HTypeEnv (ADTRef AbsRef)@@ -68,3 +82,47 @@ if me == qn then return Rec else Ext . fst <$> absADT qn++-- Invariants of ZM models++-- |Check that all internal references in the ADT definitions are to ADTs defined in the environment+refErrors :: AbsEnv -> Errors+refErrors env =+ let refs = nub . catMaybes . concatMap (map extRef. toList) . M.elems $ env+ definedInEnv = M.keys env+ in map (("Reference to unknown adt: " ++) . show) $ refs \\ definedInEnv+ where+ extRef (Ext ref) = Just ref+ extRef _ = Nothing++{-|+Check that all type expressions have kind *:+ * Type constructors are fully applied+ * Type variables have * kind+-}+kindErrors :: AbsEnv -> Errors+kindErrors absEnv = (M.foldMapWithKey (\_ adt -> inContext (declName adt) $ adtTypeFold (hasHigherKind absEnv adt) adt)) absEnv+ where+ adtTypeFold :: Monoid c => (TypeN r -> c) -> ADT name1 name2 r -> c+ adtTypeFold f = maybe mempty (conTreeTypeFoldMap (foldMap f . nestedTypeNs . typeN)) . declCons++hasHigherKind :: AbsEnv -> AbsADT -> TypeN (ADTRef AbsRef) -> Errors+hasHigherKind env _ (TypeN (Ext r) rs) =+ case M.lookup r env of+ Nothing -> ["Unknown type: " ++ show r]+ Just radt -> arityCheck (convert $ declName radt) (fromIntegral (declNumParameters radt)) (length rs)++-- hasHigherKind env adt (TypeN (Var v) rs) = arityCheck adt ("parameter " ++ [varC v]) 0 (length rs)++hasHigherKind _ _ (TypeN (Var v) rs) = arityCheck ("parameter number " ++ show v) 0 (length rs)++hasHigherKind _ adt (TypeN Rec rs) =+ arityCheck+ (convert $ declName adt)+ (fromIntegral $ declNumParameters adt)+ (length rs)+arityCheck :: (Show a, Eq a) => [Char] -> a -> a -> [String]+arityCheck r expPars actPars =+ if expPars == actPars+ then []+ else [unwords ["Incorrect application of",r++",","should have",show expPars,"parameters but has",show actPars]]
src/ZM/Dynamic.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} -- |Dynamical decoding of serialised typed values@@ -10,7 +11,6 @@ import qualified Data.ByteString as B import Data.Flat-import qualified Data.ListLike.String as S import qualified Data.Map as M import Data.Model import ZM.Transform@@ -33,11 +33,11 @@ let denv = M.mapWithKey (\t ct -> conDecoder denv t [] ct) (typeTree tm) in denv -conDecoder :: (S.StringLike name) => MapTypeDecoder -> AbsType -> [Bool] -> ConTree name AbsRef -> Get Value+conDecoder :: (Convertible name String) => MapTypeDecoder -> AbsType -> [Bool] -> ConTree name AbsRef -> Get Value conDecoder env t bs (ConTree l r) = do tag :: Bool <- decode conDecoder env t (tag:bs) (if tag then r else l) -conDecoder env t bs (Con cn cs) = Value t (S.toString cn) (reverse bs) <$> mapM (`solve` env) (fieldsTypes cs)+conDecoder env t bs (Con cn cs) = Value t (convert cn) (reverse bs) <$> mapM (`solve` env) (fieldsTypes cs)
src/ZM/Pretty.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -19,22 +20,21 @@ import Data.Foldable (toList) import Data.Int import Data.List-import qualified Data.ListLike.String as L import qualified Data.Map as M import Data.Model.Pretty+import Data.Model.Util import Data.Ord import qualified Data.Sequence as S import qualified Data.Text as T import qualified Data.Text.Encoding as T-import ZM.BLOB-import ZM.Model ()-import ZM.Transform-import ZM.Types import Data.Word import Numeric (readHex) import Text.ParserCombinators.ReadP hiding (char) import Text.PrettyPrint.HughesPJClass import Text.Printf+import ZM.BLOB+import ZM.Model ()+import ZM.Types -- |Convert the textual representation of a hash code to its equivalent value unPrettyRef :: String -> SHAKE128_48 a@@ -48,14 +48,14 @@ hex = printf "%02x" -- |Display a list of Docs, as a tuple with spaced elements--- +-- -- >>> prettyTuple (map pPrint [11,22,33::Word8]) -- (11, 22, 33) prettyTuple :: [Doc] -> Doc prettyTuple = parens . fsep . punctuate comma -- |Display a list of Docs, with spaced elements--- +-- -- >>> prettyList (map pPrint [11,22,33::Word8]) -- [11, 22, 33] prettyList :: [Doc] -> Doc@@ -82,18 +82,40 @@ ] instance {-# OVERLAPS #-} Pretty AbsEnv where- -- pPrint e = vcat . map (\(h,adt) -> pPrint h <+> text "->" <+> pPrint (e,adt)) $ M.assocs e- pPrint e = vspacedP . map (\(ref,adt) -> vcat [pPrint ref <> text ":",pPrint . CompactPretty $ (e,adt)]) . sortBy (comparing snd) $ M.assocs e- --pPrint e = vspacedP . sortBy (comparing snd) . map (\(h,adt) -> (e,adt)) $ M.assocs e+ -- Previous+ -- pPrint e = vspacedP . map (\(ref,adt) -> vcat [pPrint ref <> text ":",pPrint . CompactPretty $ (e,adt)]) . sortedEnv $ e + pPrint e = vspacedP . map (\(ref,adt) -> pPrint (refADT e ref adt) <> char ';') . sortedEnv $ e++sortedEnv :: M.Map a (ADT Identifier Identifier (ADTRef AbsRef)) -> [(a, ADT Identifier Identifier (ADTRef AbsRef))]+sortedEnv = sortBy (comparing snd) . M.assocs++refADT :: (Pretty p, Convertible name String, Show k, Ord k, Pretty k, Convertible a String) => M.Map k (ADT a consName1 ref) -> p -> ADT name consName2 (ADTRef k) -> ADT QualName consName2 (TypeRef QualName)+refADT env ref adt =+ let name = fullName ref adt+ in ADT name (declNumParameters adt) ((solveS name <$>) <$> declCons adt)+ where solveS _ (Var n) = TypVar n+ solveS _ (Ext k) = TypRef . fullName k . solve k $ env+ solveS name Rec = TypRef name+ fullName ref adt = QualName "" (prettyShow ref) (convert $ declName adt)+ instance {-# OVERLAPS #-} Pretty (AbsEnv,AbsType) where pPrint (env,t) = pPrint (declName <$> solveAll env t) instance {-# OVERLAPS #-} Pretty (AbsEnv,AbsADT) where pPrint (env,adt) = pPrint . stringADT env $ adt -instance Pretty Identifier where pPrint = text . L.toString+-- |Convert references in an absolute definition to their textual form (useful for display)+stringADT :: AbsEnv -> AbsADT -> ADT Identifier Identifier (TypeRef Identifier)+stringADT env adt =+ let name = declName adt+ in ADT name (declNumParameters adt) ((solveS name <$>) <$> declCons adt)+ where solveS _ (Var n) = TypVar n+ solveS _ (Ext k) = TypRef . declName . solve k $ env+ solveS name Rec = TypRef name +instance Pretty Identifier where pPrint = text . convert+ instance {-# OVERLAPS #-} Pretty a => Pretty (String,ADTRef a) where pPrint (_,Var v) = varP v pPrint (n,Rec) = text n@@ -106,11 +128,9 @@ instance Pretty AbsRef where pPrint (AbsRef sha3) = pPrint sha3 -instance Pretty a => Pretty (SHA3_256_6 a) where pPrint (SHA3_256_6 k1 k2 k3 k4 k5 k6) = char 'S' <> prettyWords [k1,k2,k3,k4,k5,k6]--instance Pretty a => Pretty (SHAKE128_48 a) where pPrint (SHAKE128_48 k1 k2 k3 k4 k5 k6) = char 'K' <> prettyWords [k1,k2,k3,k4,k5,k6]+instance Pretty (SHA3_256_6 a) where pPrint (SHA3_256_6 k1 k2 k3 k4 k5 k6) = char 'S' <> prettyWords [k1,k2,k3,k4,k5,k6] ---instance Pretty a => Pretty (SHAKE_256_6 a) where pPrint (SHA3_256_6 k1 k2 k3 k4 k5 k6) = char 'S' <> prettyWords [k1,k2,k3,k4,k5,k6]+instance Pretty (SHAKE128_48 a) where pPrint (SHAKE128_48 k1 k2 k3 k4 k5 k6) = char 'K' <> prettyWords [k1,k2,k3,k4,k5,k6] prettyWords :: [Word8] -> Doc prettyWords = text . concatMap hex
src/ZM/Transform.hs view
@@ -5,8 +5,6 @@ MapTypeTree, typeTree, solvedADT,- -- * Presentation- stringADT, -- * Dependencies typeDefinition, adtDefinition,@@ -21,6 +19,7 @@ import qualified Data.Map as M import Data.Maybe import Data.Model.Util (transitiveClosure)+import ZM.Pretty () import ZM.Types import ZM.Util @@ -80,15 +79,6 @@ -- where solveS _ (Var n) = TypVar n -- solveS _ (Ext k) = TypRef . LocalName . declName . solve k $ env -- solveS name Rec = TypRef $ LocalName name---- |Convert references in an absolute definition to their textual form (useful for display)-stringADT :: AbsEnv -> AbsADT -> ADT Identifier Identifier (TypeRef Identifier)-stringADT env adt =- let name = declName adt- in ADT name (declNumParameters adt) ((solveS name <$>) <$> declCons adt)- where solveS _ (Var n) = TypVar n- solveS _ (Ext k) = TypRef . declName . solve k $ env- solveS name Rec = TypRef name -- |Convert a type to an equivalent concrete ADT whose variables have been substituted by the type parameters (e.g. Maybe Bool -> Maybe = Nothing | Just Bool) solvedADT :: (Ord ref, Show ref) => M.Map ref (ADT name consName (ADTRef ref)) -> Type ref -> ADT name consName ref
src/ZM/Types.hs view
@@ -1,10 +1,11 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-} module ZM.Types ( -- * Model module Data.Model.Types,@@ -15,6 +16,7 @@ AbsADT, AbsEnv, ADTRef(..),+ asIdentifier, Identifier(..), UnicodeLetter(..), UnicodeLetterOrNumberOrLine(..),@@ -42,22 +44,22 @@ import Control.DeepSeq import Control.Exception-import qualified Data.ByteString as B+import qualified Data.ByteString as B import Data.Char import Data.Digest.Keccak+import Data.Either.Validation import Data.Flat-import Data.Foldable (toList)-import qualified Data.ListLike.String as L-import qualified Data.Map as M-import Data.Model hiding (Name)-import Data.Model.Types hiding (Name)-import ZM.Model()+import Data.Foldable+import qualified Data.Map as M+import Data.Model hiding (Name)+import Data.Model.Types hiding (Name)+import Data.Word+import ZM.Model () import ZM.Type.BLOB import ZM.Type.NonEmptyList-import ZM.Type.Words (LeastSignificantFirst (..),- MostSignificantFirst (..), Word7,- ZigZag (..))-import Data.Word+import ZM.Type.Words (LeastSignificantFirst (..),+ MostSignificantFirst (..), Word7,+ ZigZag (..)) -- |An absolute type, a type identifier that depends only on the definition of the type type AbsType = Type AbsRef@@ -108,11 +110,37 @@ instance Flat [UnicodeLetterOrNumberOrLine] -instance L.StringLike Identifier where- fromString = identifier- toString (Name (UnicodeLetter h) t) = h : map (\(UnicodeLetterOrNumberOrLine s) -> s) t- toString (Symbol l) = map (\(UnicodeSymbol s) -> s) . toList $ l+instance Convertible String Identifier where+ -- safeConvert = errorsToConvertResult asIdentifier+ safeConvert = errorsToConvertResult (validationToEither . asIdentifier) +instance Convertible Identifier String where+ safeConvert (Name (UnicodeLetter h) t) = Right $ h : map (\(UnicodeLetterOrNumberOrLine s) -> s) t+ safeConvert (Symbol l) = Right $ map (\(UnicodeSymbol s) -> s) . toList $ l++{-|Validate a string as an Identifier++>>> asIdentifier ""+Failure ["identifier cannot be empty"]++>>> asIdentifier "Id_1"+Success (Name (UnicodeLetter 'I') [UnicodeLetterOrNumberOrLine 'd',UnicodeLetterOrNumberOrLine '_',UnicodeLetterOrNumberOrLine '1'])++>>> asIdentifier "a*^"+Failure ["In a*^: '*' is not an Unicode Letter or Number or a _","In a*^: '^' is not an Unicode Letter or Number or a _"]++>>> asIdentifier "<>"+Success (Symbol (Cons (UnicodeSymbol '<') (Elem (UnicodeSymbol '>'))))++-}+asIdentifier :: String -> Validation Errors Identifier+asIdentifier [] = err ["identifier cannot be empty"]++asIdentifier i@(h:t) = errsInContext i $+ if isLetter h+ then Name <$> asLetter h <*> sequenceA (map asLetterOrNumber t)+ else Symbol . nonEmptyList <$> sequenceA (map asSymbol i)+ -- |A character that is either a `UnicodeLetter`, a `UnicodeNumber` or the special character '_' data UnicodeLetterOrNumberOrLine = UnicodeLetterOrNumberOrLine Char deriving (Eq, Ord, Show, NFData, Generic, Flat) @@ -143,26 +171,23 @@ -} data UnicodeSymbol = UnicodeSymbol Char deriving (Eq, Ord, Show, NFData, Generic, Flat) --- |Convert a string to corresponding Identifier or throw an error-identifier :: String -> Identifier-identifier [] = error "identifier cannot be empty"-identifier s@(h:t) = if isLetter h- then Name (asLetter h) (map asLetterOrNumber t)--- else Symbol (NE.map asSymbol s)- else Symbol (nonEmptyList $ map asSymbol s)+asSymbol :: Char -> Validation Errors UnicodeSymbol+asSymbol c | isSymbol c = ok $ UnicodeSymbol c+ | otherwise = err [show c,"is not an Unicode Symbol"] -asSymbol :: Char -> UnicodeSymbol-asSymbol c | isSymbol c = UnicodeSymbol c- | otherwise = error . unwords $ [show c,"is not an Unicode Symbol"]+asLetter :: Char -> Validation Errors UnicodeLetter+asLetter c | isLetter c = ok $ UnicodeLetter c+ | otherwise = err [show c,"is not an Unicode Letter"] -asLetter :: Char -> UnicodeLetter-asLetter c | isLetter c = UnicodeLetter c- | otherwise = error . unwords $ [show c,"is not an Unicode Letter"]+asLetterOrNumber :: Char -> Validation Errors UnicodeLetterOrNumberOrLine+asLetterOrNumber c | isLetter c || isNumber c || isAlsoOK c = ok $ UnicodeLetterOrNumberOrLine c+ | otherwise = err $ [show c,"is not an Unicode Letter or Number or a _"] -asLetterOrNumber :: Char -> UnicodeLetterOrNumberOrLine-asLetterOrNumber c | isLetter c || isNumber c || isAlsoOK c = UnicodeLetterOrNumberOrLine c- | otherwise = error . unwords $ [show c,"is not an Unicode Letter or Number"]+ok :: a -> Validation e a+ok = Success +err :: [String] -> Validation Errors a+err = Failure . (:[]) . unwords -- CHECK: IS '_' REALLY NEEDED? isAlsoOK :: Char -> Bool@@ -170,11 +195,11 @@ isAlsoOK _ = False -- |A generic value (used for dynamic decoding)-data Value = Value {valType::AbsType -- Type- ,valName::String -- Constructor name (duplicate info if we have abstype)- ,valBits::[Bool] -- Bit encoding/constructor id+data Value = Value {valType::AbsType -- ^Type+ ,valName::String -- ^Constructor name (duplicate info if we have abstype)+ ,valBits::[Bool] -- ^Bit encoding/constructor id -- TODO: add field names (same info present in abstype)- ,valFields::[Value] -- Values to which the constructor is applied, if any+ ,valFields::[Value] -- ^Values to which the constructor is applied, if any } deriving (Eq,Ord,Show,NFData, Generic, Flat) -- |An optionally labeled value@@ -218,4 +243,3 @@ instance Model a => Model (SHAKE128_48 a) instance Model AbsRef instance Model a => Model (PostAligned a)-
src/ZM/Util.hs view
@@ -1,8 +1,8 @@-module ZM.Util(- proxyOf+module ZM.Util+ ( proxyOf -- *State Monad utilities- ,runEnv- ,execEnv+ , runEnv+ , execEnv ) where import Control.Monad.Trans.State@@ -21,4 +21,3 @@ -- |Exec a State monad with an empty map as environment execEnv :: State (M.Map k a1) a -> M.Map k a1 execEnv op = execState op M.empty-
stack.yaml view
@@ -1,10 +1,7 @@-resolver: lts-6.31+resolver: lts-6.35+ extra-deps:-- model-0.3+- model-0.4.2 - flat-0.3-- mono-traversable-1.0.2+- mono-traversable-1.0.4.0 - cryptonite-0.22--#- cryptonite-0.23-#- foundation-0.0.9-#- memory-0.14.5
stack710.yaml view
@@ -1,6 +1,7 @@-resolver: lts-6.31+resolver: lts-6.35+ extra-deps:-- model-0.3+- model-0.4.2 - flat-0.3-- mono-traversable-1.0.2+- mono-traversable-1.0.4.0 - cryptonite-0.22
stack801.yaml view
@@ -1,7 +1,6 @@-resolver: lts-7.21+resolver: lts-7.24 extra-deps:-- model-0.3+- model-0.4.2 - flat-0.3-- mono-traversable-1.0.2 - cryptonite-0.22
stack802.yaml view
@@ -1,7 +1,4 @@-resolver: lts-8.11+resolver: lts-9.12 extra-deps:-- model-0.3-- flat-0.3-- mono-traversable-1.0.2-- cryptonite-0.22+- model-0.4.2
+ stack821.yaml view
@@ -0,0 +1,4 @@+resolver: nightly-2017-11-09++extra-deps:+- model-0.4.2
+ test/DocSpec.hs view
@@ -0,0 +1,15 @@+module Main where+import Data.List (isSuffixOf)+import Debug.Trace+import System.FilePath.Find+import Test.DocTest++main :: IO ()+main =+ find always ((extension ==? ".hs") &&? (exceptFiles ["Test.hs","ZM/Parser.hs","Data/Timeless.hs"])) "src" >>= doctest++exceptFiles :: Foldable t => t [Char] -> FindClause Bool+exceptFiles mdls =+ -- let excludes = liftOp (\fp mdls -> not $ any (\mdl -> isSuffixOf mdl (traceShowId fp)) mdls)+ let excludes = liftOp (\fp mdls -> not $ any (\mdl -> isSuffixOf mdl fp) mdls)+ in filePath `excludes` mdls
test/Info.hs view
@@ -1,16 +1,21 @@ {-# LANGUAGE NoMonomorphismRestriction #-}-module Info where-+module Info(codes,models) where import Data.Int-import ZM+import qualified Data.Sequence as S import Data.Word import Test.Data hiding (Unit)--- import Test.Data.Flat hiding (Unit)-import Test.Data.Model()+import Test.Data.Model () import qualified Test.Data2 as Data2 import qualified Test.Data3 as Data3-import qualified Data.Sequence as S+import ZM +m :: HTypeModel+m = typeModel (Proxy :: Proxy (List (Data2.List (Data3.List Bool))))++a :: AbsTypeModel+a = absTypeModel (Proxy :: Proxy (List (Data2.List (Data3.List Bool))))++models :: [AbsTypeModel] models = [ typ (Proxy :: Proxy AbsADT) ,typ (Proxy :: Proxy Bool)@@ -45,6 +50,7 @@ ] where typ = absTypeModel +codes :: [Type AbsRef] codes = [TypeApp (TypeApp (TypeApp (TypeCon (AbsRef (SHAKE128_48 62 130 87 37 92 191))) (TypeCon (AbsRef (SHAKE128_48 220 38 233 217 0 71)))) (TypeCon (AbsRef (SHAKE128_48 220 38 233 217 0 71)))) (TypeApp (TypeCon (AbsRef (SHAKE128_48 7 177 176 69 172 60))) (TypeCon (AbsRef (SHAKE128_48 75 189 56 88 123 158)))) ,TypeCon (AbsRef (SHAKE128_48 48 111 25 129 180 28)) ,TypeApp (TypeCon (AbsRef (SHAKE128_48 212 160 181 74 243 52))) (TypeCon (AbsRef (SHAKE128_48 48 111 25 129 180 28)))
test/Spec.hs view
@@ -15,13 +15,11 @@ import Data.Foldable import Data.Int import Data.List-import qualified Data.ListLike.String as L import qualified Data.Map as M import Data.Maybe import Data.Model hiding (Name) import qualified Data.Sequence as S import qualified Data.Text as T-import ZM import Data.Word import Debug.Trace import Info@@ -36,8 +34,10 @@ import Test.Tasty.HUnit import Test.Tasty.QuickCheck as QC import Text.PrettyPrint+import ZM -- import Data.Timeless+t = main main = mainTest -- main = mainMakeTests@@ -107,23 +107,14 @@ codesTests = testGroup "Absolute Types Codes Tests" (map tst $ zip models codes) where+ --tst (model,code) = testCase (unwords ["Code",prettyShow model]) $ code @?= typeName model tst (model,code) = testCase (unwords ["Code"]) $ code @?= typeName model consistentModelTests = testGroup "TypeModel Consistency Tests" $ map tst models where tst tm = testCase (unwords ["Consistency"]) $ internalConsistency tm && externalConsistency tm @?= True --- |Check internal consistency of absolute environment--- all internal references are to entries in the env-internalConsistency at =- let innerRefs = nub . catMaybes . concatMap (map extRef. toList) . typeADTs $ at- envRefs = M.keys $ typeEnv at- in innerRefs `subsetOf` envRefs--subsetOf a b = a \\ b == []--extRef (Ext ref) = Just ref-extRef _ = Nothing+internalConsistency = noErrors . refErrors . typeEnv -- |Check external consistency of absolute environment -- the key of every ADT in the env is correct (same as calculated directly on the ADT)@@ -137,7 +128,8 @@ tst :: forall a. (Model a) => Proxy a -> TestTree tst proxy = let r = absTypeModelMaybe proxy- in testCase (unwords ["Mutual Recursion",show r]) $ isLeft r && (let Left e = r in isInfixOf "mutually recursive" e) @?= True+ in testCase (unwords ["Mutual Recursion",show r]) $+ isLeft r && (let Left es = r in all (isInfixOf "mutually recursive") es) @?= True -- |Test all custom flat instances for conformity to their model customEncodingTests = testGroup "Typed Unit Tests" [@@ -259,8 +251,8 @@ ,testId "<>" $ Symbol (Cons (UnicodeSymbol '<') (Elem (UnicodeSymbol '>'))) ] where- testId s i = [testCase (unwords ["identifier parse",s]) $ L.fromString s @?= i- ,testCase (unwords ["identifier roundtrip",s]) $ L.toString (L.fromString s::Identifier) @?= s]+ testId s i = [testCase (unwords ["identifier parse",s]) $ convert s @?= i+ ,testCase (unwords ["identifier roundtrip",s]) $ convert (convert s::Identifier) @?= s] transformTests = testGroup "Transform Tests" [ testRecDeps (Proxy :: Proxy Bool) 1@@ -278,7 +270,10 @@ prop_encoding x = dynamicShow x == prettyShow x dynamicShow :: forall a. (Flat a, Model a) => a -> String-dynamicShow a = prettyShow (let Right v = decodeAbsTypeModel (absTypeModel (Proxy::Proxy a)) (flat a) in v)+--dynamicShow a = prettyShow (let Right v = decodeAbsTypeModel (absTypeModel (Proxy::Proxy a)) (flat a) in v)+dynamicShow a = case decodeAbsTypeModel (absTypeModel (Proxy::Proxy a)) (flat a) of+ Left e -> error (show e)+ Right v -> prettyShow v type RT a = a -> Bool
zm.cabal view
@@ -1,5 +1,5 @@ name: zm-version: 0.2.4+version: 0.3 synopsis: Language independent, reproducible, absolute types description: See the <http://github.com/tittoassini/zm online tutorial>.@@ -12,12 +12,13 @@ copyright: Copyright: (c) 2016 Pasqualino `Titto` Assini cabal-version: >=1.10 build-type: Simple-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 stack710.yaml stack801.yaml stack802.yaml+ stack821.yaml README.md source-repository head@@ -25,13 +26,6 @@ location: https://github.com/tittoassini/zm library- - if impl(ghcjs -any)- build-depends:- ghcjs-base >=0.2 && <0.3- else- build-depends: cryptonite >=0.22,memory >=0.13- exposed-modules: Data.Digest.Keccak ZM@@ -56,23 +50,31 @@ ZM.Dynamic ZM.Type.Generate ZM.Pretty+ ZM.Pretty.Value ZM.Model ZM.Transform ZM.Types ZM.Util- ZM.Pretty.Value+ + if impl(ghcjs -any)+ build-depends:+ ghcjs-base >=0.2 && <0.3+ else+ build-depends: cryptonite >=0.22 && <1,memory+ build-depends:- ListLike >=4.2.1,- base >=4.8 && <5,- bytestring >=0.10.6.0,- containers >=0.5.6.2,- deepseq >=1.4.1.1,- flat >=0.3,- model >=0.3,- mtl >=2.2.1,- pretty >=1.1.2.0,- text >=1.2.2.1,- transformers >=0.4.2.0+ base >=4.8 && <5,+ bytestring>=0.10.6.0 && < 0.11,+ containers == 0.5.*,+ deepseq == 1.4.*,+ pretty >= 1.1.2 && < 1.2,+ transformers >= 0.4.2.0 && < 0.6,+ convertible == 1.1.*,+ mtl >=2.2.1 && < 2.3,+ text,+ flat == 0.3.*,+ model >= 0.4.2 && < 0.5,+ either > 4.3.2 && <5 js-sources: jsbits/sha3.js default-language: Haskell2010@@ -83,19 +85,18 @@ type: exitcode-stdio-1.0 main-is: Spec.hs build-depends:- base >=4.8.2.0,- containers >=0.5.6.2,- bytestring >=0.10.6.0,- text >=1.2.2.1,- tasty >=0.11.2,- tasty-hunit >=0.9.2,- tasty-quickcheck >=0.8.4,- pretty >=1.1.2.0,- ListLike >=4.2.1,- flat >=0.3,- model >=0.3,- zm >=0.1.3,- timeit >=1.0.0.0+ base,+ containers,+ bytestring,+ text,+ pretty,+ tasty >= 0.11 && < 0.13,+ tasty-hunit >= 0.8 && < 0.10,+ tasty-quickcheck >=0.8.1 && < 0.9.2,+ timeit>=1 && <1.1,+ flat,+ model,+ zm default-language: Haskell2010 hs-source-dirs: test other-modules:@@ -108,3 +109,11 @@ Test.Data3 Test.Data3.Flat ghc-options: -threaded -rtsopts -with-rtsopts=-N++test-suite zm-doctest+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ ghc-options: -threaded+ main-is: DocSpec.hs+ build-depends: base, doctest>=0.11.1 && <0.14,filemanip>=0.3.6.3 && < 0.3.7+ HS-Source-Dirs: test