xml-isogen (empty) → 0.1.0
raw patch · 6 files changed
+528/−0 lines, 6 filesdep +QuickCheckdep +basedep +dom-parsersetup-changed
Dependencies added: QuickCheck, base, dom-parser, lens, mtl, semigroups, template-haskell, text, xml-conduit-writer
Files
- CHANGELOG.md +4/−0
- LICENSE +20/−0
- Setup.hs +2/−0
- src/Data/THGen/Enum.hs +130/−0
- src/Data/THGen/XML.hs +332/−0
- xml-isogen.cabal +40/−0
+ CHANGELOG.md view
@@ -0,0 +1,4 @@+0.1.0+-------++* Public release
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2016 Typeable.io contributors++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Data/THGen/Enum.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE TemplateHaskell #-}++{- |++Generate enumeration data types with prefixed constructors but unprefixed+`Show` and `Read` instances.++> enumGenerate $ EnumDesc "Animal" ["Cat", "Dog", "Gopher"]++produces++> data Animal = AnimalCat | AnimalDog | AnimalGopher++yet `Read` and `Show` parse and print regular values:++> show AnimalDog == "Dog"+> (read "Cat" :: Animal) == AnimalCat++-}++module Data.THGen.Enum+ ( Exhaustiveness(..)+ , EnumDesc(..)+ , enumGenerate+ ) where++import Control.Applicative+import Control.Lens (over, _head)+import Control.Monad+import qualified Data.Char as C+import qualified Language.Haskell.TH as TH+import qualified Test.QuickCheck as QC+import qualified Text.Read as R++data Exhaustiveness = Exhaustive | NonExhaustive+ deriving (Eq, Ord, Show)++data EnumDesc = EnumDesc Exhaustiveness String [String]++funSimple :: TH.Name -> TH.ExpQ -> TH.DecQ+funSimple name body = TH.funD name [ TH.clause [] (TH.normalB body) [] ]++getC :: Char -> R.ReadPrec Char+getC c = mfilter (==c) R.get++skipSpaces :: R.ReadPrec String+skipSpaces = do+ n <- length . takeWhile C.isSpace <$> R.look+ replicateM n R.get++readRemaining :: R.ReadPrec String+readRemaining = many R.get++done :: R.ReadPrec String+done = mfilter null R.look++mangleEnumConName :: String -> String+mangleEnumConName+ = filter C.isAlphaNum+ . unwords+ . map (over _head C.toUpper)+ . words++enumGenerate :: EnumDesc -> TH.DecsQ+enumGenerate (EnumDesc exh strName strVals') = do+ let+ name = TH.mkName strName+ strVals = map mangleEnumConName strVals'+ vals = map (\strVal -> TH.mkName (strName ++ strVal)) strVals+ unknownVal = TH.mkName ("Unknown" ++ strName)+ dataDecl <- do+ let+ constrs = map (\val -> TH.normalC val []) vals+ unknownConstr = case exh of+ Exhaustive -> []+ NonExhaustive ->+ [TH.normalC unknownVal [TH.strictType TH.isStrict [t|String|]]]+ TH.dataD+ (return [])+ name+ []+ (constrs ++ unknownConstr)+ ([''Eq, ''Ord] ++ if (exh == Exhaustive) then [''Enum, ''Bounded] else [])+ showInstDecl <- do+ unknownMatch <- case exh of+ Exhaustive -> return []+ NonExhaustive -> do+ v <- TH.newName "str"+ return+ [ TH.match+ (TH.conP unknownVal [TH.varP v])+ (TH.normalB (TH.varE v))+ []+ ]+ let+ matches = do+ (strVal, val) <- zip strVals vals+ return $ TH.match+ (TH.conP val [])+ (TH.normalB (TH.litE (TH.stringL strVal)))+ []+ showExpr = TH.lamCaseE (matches ++ unknownMatch)+ TH.instanceD+ (return [])+ [t|Show $(TH.conT name)|]+ [funSimple 'show showExpr]+ readInstDecl <- do+ let+ matches = do+ (strVal, val) <- zip strVals vals+ let+ valE = TH.conE val+ strValE = TH.litE (TH.stringL strVal)+ return $ [e|$valE <$ traverse getC ($strValE :: String) <* done|]+ unknownMatch = case exh of+ Exhaustive -> [e|R.pfail|]+ NonExhaustive -> [e|$(TH.conE unknownVal) <$> readRemaining|]+ readPrecExpr =+ [e|skipSpaces >> (R.choice $(TH.listE matches) R.<++ $unknownMatch)|]+ TH.instanceD+ (return [])+ [t|Read $(TH.conT name)|]+ [funSimple 'R.readPrec readPrecExpr]+ arbInstance <- do+ let arbExpr = [e|QC.elements $(TH.listE (map TH.conE vals))|]+ TH.instanceD+ (return [])+ [t|QC.Arbitrary $(TH.conT name)|]+ [funSimple 'QC.arbitrary arbExpr]+ return [dataDecl, readInstDecl, showInstDecl, arbInstance]
+ src/Data/THGen/XML.hs view
@@ -0,0 +1,332 @@+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FunctionalDependencies #-}++{- |++Generate XML-isomorphic types from declarative descriptions.++There are two kinds of XML-isomorphic types: enumerations and records.+Enumerations are simple enum-types generated via "Data.THGen.Enum"+plus a `FromContent` instance and a `ToXML` instance which are derived+from `Read` and `Show`. Records are a bit more complicated: to define+a record you need to supply its name, a prefix for fields, and a list+of field descriptions. A field description contains the XML tag name+and repetition kind (mandatory, optional, repeated or multiplied).++The repetition kind determines both the parsing strategy and the+wrapper around the field type:++* @a@ for mandatory fields+* @Maybe a@ for optional fields+* @[a]@ for repeated fields+* @NonEmpty a@ for multiplied fields++Example 1.++> "Color" =:= enum+> & "R"+> & "G"+> & "B"++produces++> data XmlColor+> = XmlColorR+> | XmlColorG+> | XmlColorB+> | UnknownXmlColor String++with a `FromContent` instance that expects the current element content+to be either @R@, @G@ or @B@.++Example 2.++> "Message" =:= record+> ! "author"+> + "recipient"+> ? "message" [t|Text|]+> * "attachement"++produces++> data Message = Message+> { _mAuthor :: Author+> , _mRecipient :: NonEmpty Recipient+> , _mMessage :: Maybe Text+> , _mAttachement :: [Attachement]+> } deriving (...)++with a corresponding `FromDom` instance. Lenses are generated+automatically as well.++The examples above also demonstrate that to define the declarative+descriptions of data types we provide a terse and convenient EDSL.++To define an enumeration, use the `enum` function followed by the name+of the data type to be generated. You can optionally specify if the+enumeration is exhaustive (contains only the listed constructors) or+non-exhaustive (also contains a constructor for unknown values; this+is the default):++> "Enum1" Exhaustive =:= enum+> ...++> "Enum2" NonExhaustive =:= enum+> ...++To define a record, use the `record` function followed by the name of+the data type to be generated. The prefix for the record fields is+inferred automatically by taking all of the uppercase letters in the+name. You can override it manually like so:++> "Reference" "ref" =:= record+> ...++To describe a record field you must supply its name as it appears+in the XML tag, prefixed by its repetition kind:++* @!@ for mandatory fields+* @?@ for optional fields+* @*@ for repeated fields+* @+@ for multiplied fields++The type of the field is inferred automatically from its name, so+if the field is called @"author"@ its type will be @Author@. You can+override the type by specifying it in quasiquotes like so:++> "Message" =:= record+> ! "author" [t|Person|]+> ...++-}+++module Data.THGen.XML+ ( Exhaustiveness(..)+ , PrefixName(..)+ , ExhaustivenessName(..)+ , record+ , enum+ , (!)+ , (?)+ , (*)+ , (+)+ , (&)+ , (=:=)+ -- Re-exports+ , T.Text+ , Int+ , Integer+ ) where++import Control.Lens hiding (repeated, enum, (&))+import Control.Lens.Internal.FieldTH (makeFieldOpticsForDec)+import qualified Data.Char as C+import Data.List.NonEmpty (NonEmpty)+import Data.String+import Data.THGen.Enum+import qualified Data.Text as T+import qualified Language.Haskell.TH as TH+import Prelude hiding ((+), (*))+import Text.XML.DOM.Parser+import qualified Text.XML.Writer as XW++data XmlFieldPlural+ = XmlFieldPluralMandatory -- Occurs exactly 1 time (Identity)+ | XmlFieldPluralOptional -- Occurs 0 or 1 times (Maybe)+ | XmlFieldPluralRepeated -- Occurs 0 or more times (List)+ | XmlFieldPluralMultiplied -- Occurs 1 or more times (NonEmpty)++data PrefixName = PrefixName String String++data IsoXmlDescPreField = IsoXmlDescPreField String TH.TypeQ++data IsoXmlDescField = IsoXmlDescField XmlFieldPlural String TH.TypeQ++data IsoXmlDescRecord = IsoXmlDescRecord [IsoXmlDescField]++makePrisms ''IsoXmlDescRecord++data ExhaustivenessName = ExhaustivenessName String Exhaustiveness++newtype IsoXmlDescEnumCon+ = IsoXmlDescEnumCon { unIsoXmlDescEnumCon :: String }++instance IsString IsoXmlDescEnumCon where+ fromString = IsoXmlDescEnumCon++data IsoXmlDescEnum = IsoXmlDescEnum [IsoXmlDescEnumCon]++makePrisms ''IsoXmlDescEnum++appendField+ :: XmlFieldPlural+ -> IsoXmlDescRecord+ -> IsoXmlDescPreField+ -> IsoXmlDescRecord+appendField plural xrec (IsoXmlDescPreField name ty) =+ let xfield = IsoXmlDescField plural name ty+ in over _IsoXmlDescRecord (xfield:) xrec++(!) :: IsoXmlDescRecord -> IsoXmlDescPreField -> IsoXmlDescRecord+(!) = appendField XmlFieldPluralMandatory++(?) :: IsoXmlDescRecord -> IsoXmlDescPreField -> IsoXmlDescRecord+(?) = appendField XmlFieldPluralOptional++(*) :: IsoXmlDescRecord -> IsoXmlDescPreField -> IsoXmlDescRecord+(*) = appendField XmlFieldPluralRepeated++(+) :: IsoXmlDescRecord -> IsoXmlDescPreField -> IsoXmlDescRecord+(+) = appendField XmlFieldPluralMultiplied++infixl 2 !+infixl 2 ?+infixl 2 *+infixl 2 +++appendEnumCon :: IsoXmlDescEnum -> IsoXmlDescEnumCon -> IsoXmlDescEnum+appendEnumCon xenum xenumcon =+ over _IsoXmlDescEnum (xenumcon:) xenum++(&) :: IsoXmlDescEnum -> IsoXmlDescEnumCon -> IsoXmlDescEnum+(&) = appendEnumCon++infixl 2 &++class Description name desc | desc -> name where+ (=:=) :: name -> desc -> TH.DecsQ++infix 0 =:=++instance Description PrefixName IsoXmlDescRecord where+ prefixName =:= descRecord =+ let descFields = descRecord ^. _IsoXmlDescRecord+ in isoXmlGenerateRecord prefixName (reverse descFields)++record :: IsoXmlDescRecord+record = IsoXmlDescRecord []++enum :: IsoXmlDescEnum+enum = IsoXmlDescEnum []++instance Description ExhaustivenessName IsoXmlDescEnum where+ exhaustivenessName =:= descEnum =+ let descEnumCons = descEnum ^. _IsoXmlDescEnum+ in isoXmlGenerateEnum exhaustivenessName (reverse descEnumCons)++instance IsString (TH.TypeQ -> IsoXmlDescPreField) where+ fromString = IsoXmlDescPreField++instance IsString IsoXmlDescPreField where+ fromString name = IsoXmlDescPreField name ty+ where+ ty = (TH.conT . TH.mkName) ("Xml" ++ over _head C.toUpper name)++instance s ~ String => IsString (s -> PrefixName) where+ fromString = PrefixName++instance IsString PrefixName where+ fromString strName = PrefixName strName (makeNamePrefix strName)++instance e ~ Exhaustiveness => IsString (e -> ExhaustivenessName) where+ fromString = ExhaustivenessName++instance IsString ExhaustivenessName where+ fromString strName = ExhaustivenessName strName NonExhaustive++makeNamePrefix :: String -> String+makeNamePrefix = map C.toLower . filter C.isUpper++funSimple :: TH.Name -> TH.ExpQ -> TH.DecQ+funSimple name body = TH.funD name [ TH.clause [] (TH.normalB body) [] ]++isoXmlGenerateEnum+ :: ExhaustivenessName -> [IsoXmlDescEnumCon] -> TH.DecsQ+isoXmlGenerateEnum (ExhaustivenessName strName' exh) enumCons = do+ let+ strName = "Xml" ++ strName'+ strVals = map unIsoXmlDescEnumCon enumCons+ enumDesc = EnumDesc exh strName strVals+ name = TH.mkName strName+ enumDecls <- enumGenerate enumDesc+ toXmlInst <- do+ let toXmlExpr = [e|XW.toXML . T.pack . show|]+ TH.instanceD+ (return [])+ [t|XW.ToXML $(TH.conT name)|]+ [funSimple 'XW.toXML toXmlExpr]+ fromDomInst <- do+ TH.instanceD+ (return [])+ [t|FromDom $(TH.conT name)|]+ [ funSimple 'fromDom [e|parseContent readContent|] ]+ return (enumDecls ++ [toXmlInst, fromDomInst])++isoXmlGenerateRecord :: PrefixName -> [IsoXmlDescField] -> TH.DecsQ+isoXmlGenerateRecord (PrefixName strName' strPrefix') descFields = do+ let+ strName = "Xml" ++ strName'+ strPrefix = "x" ++ strPrefix'+ name = TH.mkName strName+ fieldName str = "_" ++ strPrefix ++ over _head C.toUpper str+ dataDecl <- do+ let+ constructors = do+ IsoXmlDescField fieldPlural fieldStrName fieldType <- descFields+ let+ fName = TH.mkName (fieldName fieldStrName)+ fType = case fieldPlural of+ XmlFieldPluralMandatory -> fieldType+ XmlFieldPluralOptional -> [t| Maybe $fieldType |]+ XmlFieldPluralRepeated -> [t| [$fieldType] |]+ XmlFieldPluralMultiplied -> [t| NonEmpty $fieldType |]+ return $ TH.varStrictType fName (TH.strictType TH.isStrict fType)+ TH.dataD+ (return [])+ name+ []+ [TH.recC name constructors]+ [''Eq, ''Show]+ lensDecls <- makeFieldOpticsForDec lensRules dataDecl+ fromDomInst <- do+ let+ exprHeader = [e|pure $(TH.conE name)|]+ exprFields = do+ IsoXmlDescField fieldPlural fieldStrName _ <- descFields+ let+ exprFieldStrName = TH.litE (TH.stringL fieldStrName)+ fieldParse = case fieldPlural of+ XmlFieldPluralMandatory -> [e|inElem|]+ _ -> [e|inElemTrav|]+ return [e|$fieldParse $exprFieldStrName fromDom|]+ fromDomExpr = foldl (\e fe -> [e| $e <*> $fe |]) exprHeader exprFields+ TH.instanceD+ (return [])+ [t|FromDom $(TH.conT name)|]+ [ funSimple 'fromDom fromDomExpr ]++ toXmlInst <- do+ objName <- TH.newName strPrefix+ let+ exprFooter = [e|return ()|]+ exprFields = do+ IsoXmlDescField fieldPlural fieldStrName _ <- descFields+ let+ fieldRender = [e|XW.toXML|]+ fName = TH.mkName (fieldName fieldStrName)+ exprFieldStrName = TH.litE (TH.stringL fieldStrName)+ exprForField = case fieldPlural of+ XmlFieldPluralMandatory -> [e|id|]+ _ -> [e|traverse|]+ exprFieldValue = [e|$(TH.varE fName) $(TH.varE objName)|]+ exprFieldRender = [e|XW.element $exprFieldStrName . $fieldRender|]+ return [e|$exprForField $exprFieldRender $exprFieldValue|]+ toXmlExpr+ = TH.lamE [if null exprFields then TH.wildP else TH.varP objName]+ $ foldr (\fe e -> [e|$fe *> $e|]) exprFooter exprFields+ TH.instanceD+ (return [])+ [t|XW.ToXML $(TH.conT name)|]+ [funSimple 'XW.toXML toXmlExpr]+ return $ [dataDecl] ++ lensDecls ++ [fromDomInst, toXmlInst]
+ xml-isogen.cabal view
@@ -0,0 +1,40 @@+name: xml-isogen+version: 0.1.0+synopsis: Generate XML-isomorphic types+description:+ TemplateHaskell generators for XML-isomorphic data types, including+ instances for parsing and rendering. A convenient DSL to define those+ types.++ This is similar to XSD but is Haskell-specific.++license: MIT+license-file: LICENSE+author: Typeable.io contributors+maintainer: makeit@typeable.io+category: Data+build-type: Simple+extra-source-files: CHANGELOG.md+cabal-version: >=1.22++library+ exposed-modules: Data.THGen.Enum+ Data.THGen.XML++ build-depends: QuickCheck >= 2.8+ , base >=4.8 && <5+ , dom-parser >= 0.1.0+ , lens >= 4.13+ , mtl >= 2.2+ , semigroups >= 0.18+ , template-haskell >= 2.10+ , text >= 1.2+ , xml-conduit-writer >= 0.1++ hs-source-dirs: src++ default-language: Haskell2010+ default-extensions: TemplateHaskell+ LambdaCase+ FlexibleInstances+ TypeFamilies