diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,5 +1,7 @@ -[![Build Status](https://travis-ci.org/tittoassini/zm.svg?branch=master)](https://travis-ci.org/tittoassini/zm) [![Hackage version](https://img.shields.io/hackage/v/zm.svg)](http://hackage.haskell.org/package/zm) +[![Build Status](https://travis-ci.org/Quid2/zm.svg?branch=master)](https://travis-ci.org/Quid2/zm) [![Hackage version](https://img.shields.io/hackage/v/zm.svg)](http://hackage.haskell.org/package/zm) +[![Stackage Nightly](http://stackage.org/package/zm/badge/nightly)](http://stackage.org/nightly/package/zm) +[![Stackage LTS](http://stackage.org/package/zm/badge/lts)](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 diff --git a/src/ZM.hs b/src/ZM.hs --- a/src/ZM.hs +++ b/src/ZM.hs @@ -1,15 +1,12 @@ module ZM( - -- |Check the . + -- |Check the . 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 diff --git a/src/ZM/Abs.hs b/src/ZM/Abs.hs --- a/src/ZM/Abs.hs +++ b/src/ZM/Abs.hs @@ -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]] diff --git a/src/ZM/Dynamic.hs b/src/ZM/Dynamic.hs --- a/src/ZM/Dynamic.hs +++ b/src/ZM/Dynamic.hs @@ -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) diff --git a/src/ZM/Pretty.hs b/src/ZM/Pretty.hs --- a/src/ZM/Pretty.hs +++ b/src/ZM/Pretty.hs @@ -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 diff --git a/src/ZM/Transform.hs b/src/ZM/Transform.hs --- a/src/ZM/Transform.hs +++ b/src/ZM/Transform.hs @@ -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 diff --git a/src/ZM/Types.hs b/src/ZM/Types.hs --- a/src/ZM/Types.hs +++ b/src/ZM/Types.hs @@ -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) - diff --git a/src/ZM/Util.hs b/src/ZM/Util.hs --- a/src/ZM/Util.hs +++ b/src/ZM/Util.hs @@ -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 - diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -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 diff --git a/stack710.yaml b/stack710.yaml --- a/stack710.yaml +++ b/stack710.yaml @@ -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 diff --git a/stack801.yaml b/stack801.yaml --- a/stack801.yaml +++ b/stack801.yaml @@ -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 diff --git a/stack802.yaml b/stack802.yaml --- a/stack802.yaml +++ b/stack802.yaml @@ -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 diff --git a/stack821.yaml b/stack821.yaml new file mode 100644 --- /dev/null +++ b/stack821.yaml @@ -0,0 +1,4 @@ +resolver: nightly-2017-11-09 + +extra-deps: +- model-0.4.2 diff --git a/test/DocSpec.hs b/test/DocSpec.hs new file mode 100644 --- /dev/null +++ b/test/DocSpec.hs @@ -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 diff --git a/test/Info.hs b/test/Info.hs --- a/test/Info.hs +++ b/test/Info.hs @@ -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))) diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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 diff --git a/zm.cabal b/zm.cabal --- a/zm.cabal +++ b/zm.cabal @@ -1,5 +1,5 @@ name: zm -version: 0.2.4 +version: 0.3 synopsis: Language independent, reproducible, absolute types description: See the . @@ -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