zm 0.3.1 → 0.3.2
raw patch · 14 files changed
+193/−116 lines, 14 filesdep −mtldep ~eitherdep ~modeldep ~tasty-hunit
Dependencies removed: mtl
Dependency ranges changed: either, model, tasty-hunit
Files
- README.md +1/−1
- src/ZM.hs +17/−9
- src/ZM/Abs.hs +82/−30
- src/ZM/Pretty.hs +6/−14
- src/ZM/Pretty/Base.hs +24/−0
- src/ZM/Transform.hs +1/−8
- src/ZM/Types.hs +42/−31
- stack.yaml +1/−1
- stack710.yaml +6/−2
- stack801.yaml +0/−6
- stack802.yaml +2/−2
- stack821.yaml +0/−4
- stack822.yaml +4/−0
- zm.cabal +7/−8
README.md view
@@ -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
src/ZM.hs view
@@ -1,17 +1,25 @@ module ZM( -- |Check the <https://github.com/tittoassini/zm tutorial and github repo>.- 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+
src/ZM/Abs.hs view
@@ -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
src/ZM/Pretty.hs view
@@ -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 []
+ src/ZM/Pretty/Base.hs view
@@ -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"+
src/ZM/Transform.hs view
@@ -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)
src/ZM/Types.hs view
@@ -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
stack.yaml view
@@ -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
stack710.yaml view
@@ -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
− stack801.yaml
@@ -1,6 +0,0 @@-resolver: lts-7.24--extra-deps:-- model-0.4.2-- flat-0.3-- cryptonite-0.22
stack802.yaml view
@@ -1,4 +1,4 @@-resolver: lts-9.12+resolver: lts-9.17 extra-deps:-- model-0.4.2+- model-0.4.4
− stack821.yaml
@@ -1,4 +0,0 @@-resolver: nightly-2017-11-09--extra-deps:-- model-0.4.2
+ stack822.yaml view
@@ -0,0 +1,4 @@+resolver: nightly-2017-12-10++extra-deps:+- model-0.4.4
zm.cabal view
@@ -1,5 +1,5 @@ name: zm-version: 0.3.1+version: 0.3.2 synopsis: Language independent, reproducible, absolute types description: See the <http://github.com/tittoassini/zm online tutorial>.@@ -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,