diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -323,7 +323,7 @@ ### Haskell Compatibility Tested with: - * [ghc](https://www.haskell.org/ghc/) 7.10.3, 8.0.1 and 8.0.2 (x64) + * [ghc](https://www.haskell.org/ghc/) 7.10.3, 8.0.2 and 8.2.2 (x64) * [ghcjs](https://github.com/ghcjs/ghcjs) ### Installation diff --git a/src/ZM.hs b/src/ZM.hs --- a/src/ZM.hs +++ b/src/ZM.hs @@ -1,17 +1,25 @@ module ZM( -- |Check the . - module X + module Data.Flat + ,module Data.Model + ,module ZM.Abs + ,module ZM.BLOB + ,module ZM.Dynamic + ,module ZM.Pretty + ,module ZM.Transform + ,module ZM.Types ) where -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.Dynamic as X +import Data.Flat +import Data.Model hiding (Name) +import ZM.Abs +import ZM.BLOB hiding (content) +import ZM.Dynamic import ZM.Model () -import ZM.Pretty as X +import ZM.Pretty import ZM.Pretty.Value () -import ZM.Transform as X -import ZM.Types as X +import ZM.Transform +import ZM.Types + diff --git a/src/ZM/Abs.hs b/src/ZM/Abs.hs --- a/src/ZM/Abs.hs +++ b/src/ZM/Abs.hs @@ -1,8 +1,10 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE LiberalTypeSynonyms #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE PackageImports #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} @@ -12,19 +14,21 @@ , absTypeModel , absTypeModelMaybe , absEnv + , absEnvWith , refErrors , kindErrors ) where -import "mtl" Control.Monad.Reader -import Data.Bifunctor +import Control.Monad.Trans.RWS import Data.Convertible -import Data.Foldable (toList) +import Data.Foldable (toList) import Data.List -import qualified Data.Map as M +import qualified Data.Map as M import Data.Maybe import Data.Model +import ZM.Pretty.Base () import ZM.Types +-- import Debug.Trace -- |Derive an absolute type for a type, or throw an error if derivation is impossible absType :: Model a => Proxy a -> AbsType @@ -35,56 +39,99 @@ absTypeModel = either (error . unlines) id . absTypeModelMaybe {- | -Derive an absolute type model for a type, provided that: - -* is an instance of Model -* no data type referred directly or indirectly by the type: - - * has higher kind variables - * is mutually recursive with other data types +Derive an absolute type model for a type, if possible. -} absTypeModelMaybe :: Model a => Proxy a -> Either Errors AbsTypeModel absTypeModelMaybe a = let (TypeModel t henv) = typeModel a in (\(refEnv,adtEnv) -> TypeModel (solveAll refEnv t) adtEnv) <$> absEnvs henv -absEnv :: M.Map QualName (ADT String String (TypeRef QualName)) -> Either Errors AbsEnv -absEnv = (snd <$>) . absEnvs +-- |Convert a set of relative ADTs to the equivalent ZM absolute ADTs +absEnv :: HTypeEnv -> Either Errors AbsEnv +absEnv = absEnvWith M.empty -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 +{- |Convert a set of relative ADTs to the equivalent ZM absolute ADTs, with a starting set of known absolute ADTs. +Conversion will fail if the relative ADTs are mutually recursive or refer to undefined ADTs. +-} +absEnvWith :: + AbsEnv + -> HTypeEnv + -> Either Errors AbsEnv +absEnvWith absEnv = (snd <$>) . absEnvsWith absEnv + +absEnvs :: HTypeEnv -> Either Errors (M.Map QualName AbsRef, AbsEnv) +absEnvs = absEnvsWith M.empty + +absEnvsWith :: + AbsEnv + -> HTypeEnv + -> Either Errors (BiMap QualName AbsRef AbsADT) +absEnvsWith absEnv hEnv = + let envs = fst $ execRWS (mapM_ absADT (M.keys hEnv)) extHEnv bimap + -- 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) + -- in list (Right envs) Left (mutualErrors getHRef (trace (unwords . map prettyShow . M.keys $ extHEnv) extHEnv)) + in list (Right envs) Left (mutualErrors getHRef extHEnv) + where - checkMutualErrors mgroups = - if null mgroups - then Right () - else Left $ map (\g-> unwords ["Found mutually recursive types",prettyShow g]) mgroups + -- add fake entries for absolute adts, to avoid missing references errors + extHEnv = hEnv `M.union` (mmap (\(ref,adt) -> let n = qname ref adt in (n,ADT "" 0 Nothing)) absEnv) -absADT :: QualName -> Reader HTypeEnv (AbsRef, AbsADT) -absADT qn = do - hadt <- solve qn <$> ask - cs' <- mapM (mapM (adtRef qn)) $ declCons hadt + bimap :: BiMap QualName AbsRef AbsADT + bimap = (mmap (\(ref,adt) -> (qname ref adt,ref)) absEnv,absEnv) - let adt :: AbsADT = adtNamesMap convert convert $ ADT (declName hadt) (declNumParameters hadt) cs' - return (absRef adt,adt) + qname ref adt = QualName "" (prettyShow ref) (convert $ declName adt) -adtRef :: QualName -> HTypeRef -> Reader HTypeEnv (ADTRef AbsRef) + mmap f = M.fromList . map f . M.toList + +type BuildM = RWS HTypeEnv () (BiMap QualName AbsRef AbsADT) + +--type BiMap k1 k2 v = (Ord k1, Ord k2) => (M.Map k1 k2, M.Map k2 v) +type BiMap k1 k2 v = (M.Map k1 k2, M.Map k2 v) + +blookup1 :: Ord k1 => k1 -> BiMap k1 k2 v -> Maybe k2 +blookup1 k1 (m1,_) = M.lookup k1 m1 -- >>= \k2 -> M.lookup k2 m2 + +binsert :: (Ord k1, Ord k2) => k1 -> k2 -> v -> BiMap k1 k2 v -> BiMap k1 k2 v +binsert k1 k2 v (m1,m2) = (M.insert k1 k2 m1,M.insert k2 v m2) + +absADT :: QualName -> BuildM AbsRef +absADT k = do + mr <- blookup1 k <$> get + case mr of + Just r -> return r + Nothing -> do + hadt <- solve k <$> ask + cs' <- mapM (mapM (adtRef k)) $ declCons hadt + + let adt :: AbsADT = adtNamesMap convert convert $ ADT (declName hadt) (declNumParameters hadt) cs' + let r = absRef adt + modify (binsert k r adt) + return r + +adtRef :: QualName -> HTypeRef -> BuildM (ADTRef AbsRef) adtRef _ (TypVar v) = return $ Var v adtRef me (TypRef qn) = if me == qn then return Rec - else Ext . fst <$> absADT qn + else Ext <$> absADT qn -- Invariants of ZM models +{-|Check that there are no mutual dependencies + +> mutualErrors getADTRef absEnv +> mutualErrors getHRef hEnv +-} +mutualErrors :: (Pretty r, Ord r, Foldable t) => (a -> Maybe r) -> M.Map r (t a) -> Errors +mutualErrors getRef env = either id (map (\g-> unwords ["Found mutually recursive types",prettyShow g])) $ properMutualGroups getRef env + -- |Check that all internal references in the ADT definitions are to ADTs defined in the environment refErrors :: AbsEnv -> Errors refErrors env = @@ -96,7 +143,8 @@ extRef _ = Nothing {-| -Check that all type expressions have kind *: +Check that all type expressions have kind *, that's to say: + * Type constructors are fully applied * Type variables have * kind -} @@ -126,3 +174,7 @@ if expPars == actPars then [] else [unwords ["Incorrect application of",r++",","should have",show expPars,"parameters but has",show actPars]] + +list :: a -> ([t] -> a) -> [t] -> a +list onNull _ [] = onNull +list _ onList l = onList l diff --git a/src/ZM/Pretty.hs b/src/ZM/Pretty.hs --- a/src/ZM/Pretty.hs +++ b/src/ZM/Pretty.hs @@ -10,7 +10,7 @@ hex, unPrettyRef, prettyList, - prettyTuple, + prettyTuple ) where import qualified Data.ByteString as B @@ -31,22 +31,22 @@ import Numeric (readHex) import Text.ParserCombinators.ReadP hiding (char) import Text.PrettyPrint.HughesPJClass -import Text.Printf import ZM.BLOB import ZM.Model () +import ZM.Pretty.Base import ZM.Types -- |Convert the textual representation of a hash code to its equivalent value +-- +-- >>> unPrettyRef "Kb53bec846608" +-- SHAKE128_48 181 59 236 132 102 8 unPrettyRef :: String -> SHAKE128_48 a unPrettyRef ('K':code) = let [k1,k2,k3,k4,k5,k6] = readHexCode code in SHAKE128_48 k1 k2 k3 k4 k5 k6 + --unPrettyRef :: String -> SHA3_256_6 a --unPrettyRef ('S':code) = let [k1,k2,k3,k4,k5,k6] = readHexCode code in SHA3_256_6 k1 k2 k3 k4 k5 k6 unPrettyRef code = error $ "unPrettyRef: unknown code " ++ show code --- |Display a Word in hexadecimal format -hex :: Word8 -> String -hex = printf "%02x" - -- |Display a list of Docs, as a tuple with spaced elements -- -- >>> prettyTuple (map pPrint [11,22,33::Word8]) @@ -126,14 +126,6 @@ pPrint Rec = char '\x21AB' pPrint (Ext r) = pPrint r -instance Pretty AbsRef where pPrint (AbsRef sha3) = pPrint sha3 - -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 (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 readHexCode :: String -> [Word8] readHexCode = readCode [] diff --git a/src/ZM/Pretty/Base.hs b/src/ZM/Pretty/Base.hs new file mode 100644 --- /dev/null +++ b/src/ZM/Pretty/Base.hs @@ -0,0 +1,24 @@ +module ZM.Pretty.Base (prettyWords,hex) where + +import Data.Word +import Text.PrettyPrint.HughesPJClass +import Text.Printf +import ZM.Types + +instance Pretty AbsRef where pPrint (AbsRef sha3) = pPrint sha3 + +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 (SHAKE128_48 a) where pPrint (SHAKE128_48 k1 k2 k3 k4 k5 k6) = char 'K' <> prettyWords [k1,k2,k3,k4,k5,k6] + +-- |Display a list of Words in hexadecimal format +-- +-- >>> prettyWords [11,22,33::Word8] +-- 0b1621 +prettyWords :: [Word8] -> Doc +prettyWords = text . concatMap hex + +-- |Display a Word in hexadecimal format +hex :: Word8 -> String +hex = printf "%02x" + diff --git a/src/ZM/Transform.hs b/src/ZM/Transform.hs --- a/src/ZM/Transform.hs +++ b/src/ZM/Transform.hs @@ -9,8 +9,7 @@ typeDefinition, adtDefinition, innerReferences, - references, - getADTRef + references ) where import Control.Monad.Trans.State @@ -62,12 +61,6 @@ absRecDeps :: AbsEnv -> AbsRef -> Either String [AbsRef] absRecDeps env ref = either (Left . unlines) Right $ transitiveClosure getADTRef env ref - --- WHAT ABOUT REC? --- |Return an external reference, if present -getADTRef :: ADTRef a -> Maybe a -getADTRef (Ext r) = Just r -getADTRef _ = Nothing mapSolve :: (Ord k, Show k) => M.Map k b -> [k] -> [b] mapSolve env = map (`solve` env) diff --git a/src/ZM/Types.hs b/src/ZM/Types.hs --- a/src/ZM/Types.hs +++ b/src/ZM/Types.hs @@ -6,41 +6,47 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} -module ZM.Types ( +module ZM.Types + + ( -- * Model - module Data.Model.Types, - AbsTypeModel, - AbsType, - AbsRef(..), - absRef, - AbsADT, - AbsEnv, - ADTRef(..), - asIdentifier, - Identifier(..), - UnicodeLetter(..), - UnicodeLetterOrNumberOrLine(..), - UnicodeSymbol(..), - SHA3_256_6(..), - SHAKE128_48(..), - NonEmptyList(..), - nonEmptyList, - Word7, + module Data.Model.Types + , AbsTypeModel + , AbsType + , AbsRef(..) + , absRef + , AbsADT + , AbsEnv + , ADTRef(..) + , getADTRef + , asIdentifier + , Identifier(..) + , UnicodeLetter(..) + , UnicodeLetterOrNumberOrLine(..) + , UnicodeSymbol(..) + , SHA3_256_6(..) + , SHAKE128_48(..) + , NonEmptyList(..) + , nonEmptyList + , Word7 -- * Encodings - FlatEncoding(..), UTF8Encoding(..), UTF16LEEncoding(..), NoEncoding(..) + , FlatEncoding(..) + , UTF8Encoding(..) + , UTF16LEEncoding(..) + , NoEncoding(..) -- * Exceptions - ,TypedDecoded, - TypedDecodeException(..), + , TypedDecoded + , TypedDecodeException(..) -- *Other Re-exports - NFData(), - Flat, - ZigZag(..), - LeastSignificantFirst(..), - MostSignificantFirst(..), - Value(..), - Label(..), - label, - ) where + , NFData() + , Flat + , ZigZag(..) + , LeastSignificantFirst(..) + , MostSignificantFirst(..) + , Value(..) + , Label(..) + , label + ) where import Control.DeepSeq import Control.Exception @@ -101,6 +107,11 @@ | Rec -- ^Recursive reference to the ADT itself | Ext r -- ^Reference to another ADT deriving (Eq, Ord, Show, NFData, Generic, Functor, Foldable, Traversable ,Flat) + +-- |Return an external reference, if present +getADTRef :: ADTRef a -> Maybe a +getADTRef (Ext r) = Just r +getADTRef _ = Nothing -- CHECK: Is it necessary to specify a syntax for identifiers? -- |An Identifier, the name of an ADT diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -1,7 +1,7 @@ resolver: lts-6.35 extra-deps: -- model-0.4.2 +- model-0.4.4 - flat-0.3 - mono-traversable-1.0.4.0 - cryptonite-0.22 diff --git a/stack710.yaml b/stack710.yaml --- a/stack710.yaml +++ b/stack710.yaml @@ -1,7 +1,11 @@ resolver: lts-6.35 extra-deps: -- model-0.4.2 +- model-0.4.4 - flat-0.3 - mono-traversable-1.0.4.0 -- cryptonite-0.22 +- cryptonite-0.24 +- foundation-0.0.17 +- memory-0.14.10 +- basement-0.0.4 +- mwc-random-0.13.6.0 diff --git a/stack801.yaml b/stack801.yaml deleted file mode 100644 --- a/stack801.yaml +++ /dev/null @@ -1,6 +0,0 @@ -resolver: lts-7.24 - -extra-deps: -- model-0.4.2 -- flat-0.3 -- cryptonite-0.22 diff --git a/stack802.yaml b/stack802.yaml --- a/stack802.yaml +++ b/stack802.yaml @@ -1,4 +1,4 @@ -resolver: lts-9.12 +resolver: lts-9.17 extra-deps: -- model-0.4.2 +- model-0.4.4 diff --git a/stack821.yaml b/stack821.yaml deleted file mode 100644 --- a/stack821.yaml +++ /dev/null @@ -1,4 +0,0 @@ -resolver: nightly-2017-11-09 - -extra-deps: -- model-0.4.2 diff --git a/stack822.yaml b/stack822.yaml new file mode 100644 --- /dev/null +++ b/stack822.yaml @@ -0,0 +1,4 @@ +resolver: nightly-2017-12-10 + +extra-deps: +- model-0.4.4 diff --git a/zm.cabal b/zm.cabal --- a/zm.cabal +++ b/zm.cabal @@ -1,5 +1,5 @@ name: zm -version: 0.3.1 +version: 0.3.2 synopsis: Language independent, reproducible, absolute types description: See the . @@ -12,13 +12,12 @@ 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 GHC == 8.2.1 +Tested-With: GHC == 7.10.3 GHC == 8.0.2 GHC == 8.2.2 extra-source-files: stack.yaml stack710.yaml - stack801.yaml stack802.yaml - stack821.yaml + stack822.yaml README.md source-repository head @@ -50,6 +49,7 @@ ZM.Dynamic ZM.Type.Generate ZM.Pretty + ZM.Pretty.Base ZM.Pretty.Value ZM.Model ZM.Transform @@ -70,11 +70,10 @@ 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 + model >= 0.4.4 && < 0.5, + either > 4.3.2 && <6 js-sources: jsbits/sha3.js default-language: Haskell2010 @@ -91,7 +90,7 @@ text, pretty, tasty >= 0.11 && < 0.13, - tasty-hunit >= 0.8 && < 0.10, + tasty-hunit >= 0.8 && < 0.11, tasty-quickcheck >=0.8.1 && < 0.9.2, timeit>=1 && <1.1, flat,