module Fadno.Xml.EmitTypes
(
emitSchema
,emitElement,emitSimpleType,emitComplexType,emitCompositor
,emitGroup,emitChoice,emitSequence,emitParticle,emitAttrFields
,Emit,Env(..),schema,EmitState(..),types,stack,runEmit,die
,Name(..),Namespace(..),Cardinality(..)
,Field(..),fieldName,fieldType,fieldCardinality,fieldXmlEmit,fieldIdx,FieldEmit(..)
,Ctor(..),ctorName,ctorFields
,Type(..),typeName,typeType,typeDerives,typeImpls,typeEmit,typeCtors,typeEnumValues,coreType
,DerivesFamily(..),DataTypeEmit(..),CoreType(..),Impl(..)
) where
import Fadno.Xml.ParseXsd
import Data.Monoid
import Control.Lens hiding (Choice,element,elements,anon)
import Control.Monad.State.Strict
import Control.Monad.Reader
import Data.Maybe
import Data.Data
import Control.Exception hiding (handle)
import qualified Data.Map.Strict as M
data Cardinality =
One |
ZeroOrOne |
Many
deriving (Eq,Show,Data,Typeable,Ord,Enum,Bounded)
data Namespace =
NSElement |
NSSimple |
NSUnion |
NSComplex |
NSBuiltIn |
NSChoice |
NSSequence |
NSGroup
deriving (Eq,Show,Data,Typeable,Ord,Enum,Bounded)
data Name = Name {
nNamespace :: Namespace
, nName :: QN
, nIdx :: Int }
deriving (Eq,Show,Data,Typeable,Ord)
data FieldEmit =
FieldAttribute |
FieldElement |
FieldText |
FieldOther
deriving (Eq,Show,Data,Typeable,Ord)
data Field = Field {
_fieldName :: QN
, _fieldType :: Type
, _fieldCardinality :: Cardinality
, _fieldXmlEmit :: FieldEmit
, _fieldIdx :: Int
} deriving (Eq,Data,Typeable,Ord)
instance Show Field where
show (Field n t c x i) =
"Field {_fieldName = " ++ show n ++
",_fieldType = {_typeName = " ++ show (_typeName t) ++
"},_fieldCardinality = " ++ show c ++
",_fieldXmlEmit = " ++ show x ++
",_fieldIdx = " ++ show i ++
"}"
data Ctor = Ctor {
_ctorName :: String
, _ctorFields :: [Field]
} deriving (Eq,Show,Data,Typeable,Ord)
data DerivesFamily =
NewTypeString |
NewTypeIntegral |
NewTypeNum |
DataEnum |
OtherDerives
deriving (Eq,Show,Data,Typeable,Ord,Enum,Bounded)
data Impl =
Bounds (Maybe (Bound String), Maybe (Bound String)) |
Pattern String |
NewTypeShow |
TopLevel
deriving (Eq,Show,Data,Typeable,Ord)
data CoreType =
CTString |
CTDecimal |
CTFloat |
CTDouble |
CTInt |
CTBool
deriving (Eq,Show,Data,Typeable,Ord,Enum,Bounded)
data DataTypeEmit =
DataTypeComplex |
DataTypeSimple |
DataTypeCompositor
deriving (Eq,Show,Data,Typeable,Ord)
data Type =
NewType {
_typeName :: Name
, _typeType :: Type
, _typeDerives :: DerivesFamily
, _typeImpls :: [Impl]
, _typeDoc :: Maybe Documentation
} |
DataType {
_typeName :: Name
, _typeCtors :: [Ctor]
, _typeDerives :: DerivesFamily
, _typeImpls :: [Impl]
, _typeEmit :: DataTypeEmit
, _typeDoc :: Maybe Documentation
} |
EnumType {
_typeName :: Name
, _typeEnumValues :: [String]
, _typeDerives :: DerivesFamily
, _typeImpls :: [Impl]
, _typeDoc :: Maybe Documentation
} |
BuiltIn {
_typeName :: Name
, _coreType :: CoreType
, _typeDerives :: DerivesFamily
, _typeImpls :: [Impl]
} deriving (Eq,Show,Data,Typeable,Ord)
$(makeLenses ''Type)
$(makeLenses ''Ctor)
$(makeLenses ''Field)
data Env = Env {
_schema :: Schema
}
$(makeLenses ''Env)
data EmitState = EmitState { _types :: M.Map Name Type, _stack :: [Name] }
$(makeLenses ''EmitState)
instance Monoid EmitState where
mempty = EmitState mempty mempty
(EmitState a b) `mappend` (EmitState c d) = EmitState (a<>c) (b<>d)
type Emit a = ReaderT Env (StateT EmitState IO) a
runEmit :: Env -> EmitState -> Emit a -> IO (a, EmitState)
runEmit env st act = runStateT (runReaderT act env) st
emitSchema :: Schema -> Emit ()
emitSchema s = do
els <- M.keys <$> mapM emitElement (_elements s)
types %= M.mapWithKey
(\k v -> if nName k `elem` els
then over typeImpls (TopLevel:) v
else v)
builtInString :: Type
builtInString = mkBuiltIn "string" CTString NewTypeString
builtIns :: M.Map QN Type
builtIns = foldr (\b -> M.insert (nName (_typeName b)) b) mempty
[builtInInteger,builtInDecimal,builtInDouble,
builtInFloat,builtInBoolean,builtInString]
where
builtInInteger = mkBuiltIn "integer" CTInt NewTypeIntegral
builtInDecimal = mkBuiltIn "decimal" CTDecimal NewTypeNum
builtInFloat = mkBuiltIn "float" CTFloat NewTypeNum
builtInDouble = mkBuiltIn "double" CTDouble NewTypeNum
builtInBoolean = mkBuiltIn "boolean" CTBool OtherDerives
mkBuiltIn :: String -> CoreType -> DerivesFamily -> Type
mkBuiltIn n ct df = BuiltIn (Name NSBuiltIn (QN n (Just "xs")) 0) ct df [NewTypeShow]
emitElement :: Element -> Emit Type
emitElement (ElementType _ t _ doc) = do
rt <- resolvedRef t
case rt of
Left ct -> emitComplexType Nothing ct
Right st -> emitSimpleType st
emitElement (ElementComplex n c _ doc) = emitComplexType (Just n) c
emitElement (ElementRef {}) = die "ElementRef unsupported"
emitElement (ElementSimple {}) = die "ElementSimple unsupported"
die :: MonadIO m => String -> m a
die = liftIO . throwIO . userError
resolvedRef :: (Resolvable (Ref a)) => Ref a -> Emit a
resolvedRef r = do
s <- view schema
case firstOf refvalue (resolve s r) of
Just a -> return a
Nothing -> die $ "resolvedRef: resolve failed on " ++ show r
emitSimpleType :: SimpleType -> Emit Type
emitSimpleType t =
case view simpleTypeName t of
Nothing -> use stack >>= \s -> die $ "emitSimpleType: anon type: " ++ show t ++
", stack: " ++ show s
Just stn -> do
bt <- tryBuiltIn t
maybe (checkDefinedType NSSimple stn $ doSimpleType t) return bt
doSimpleType :: SimpleType -> Name -> Emit Type
doSimpleType (SimpleTypeRestrict _ (SimpleRestriction base enumz mins maxs patt) doc) n = do
bt <- resolvedRef base
if not (null enumz)
then emitEnum bt n enumz doc
else do
btt <- emitSimpleType bt
return $ NewType n btt (_typeDerives btt)
([Bounds (mins,maxs) | isJust mins || isJust maxs] ++
maybe [] (return.Pattern) patt ++
_typeImpls btt) doc
doSimpleType (SimpleTypeUnion _ (Union refs sts) doc) n = do
rts <- mapM resolvedRef refs
rtts <- mapM emitSimpleType rts
let doAnon t = checkUniqueType NSUnion Nothing (doSimpleType t)
atns <- mapM doAnon sts
let doCtor i t =
Ctor (_qLocal $ nName (_typeName t))
[Field (QN (show i) Nothing) t One FieldAttribute 0]
return $ fixFields $
DataType n (zipWith doCtor [(1 :: Int) ..] $ rtts ++ atns)
OtherDerives [] DataTypeSimple doc
tryBuiltIn :: SimpleType -> Emit (Maybe Type)
tryBuiltIn t =
case view simpleTypeName t of
Nothing -> return Nothing
Just tn ->
case M.lookup tn builtIns of
Just bt -> return (Just bt)
Nothing ->
case firstOf (simpleTypeRestriction.simpleRestrictBase.unresolved) t of
Nothing -> return Nothing
Just bt | bt == anySimpleTypeName -> return (Just builtInString)
| otherwise -> return Nothing
emitEnum :: SimpleType -> Name -> [String] -> Maybe Documentation -> Emit Type
emitEnum _base n vals doc = return $ EnumType n vals DataEnum [] doc
emitComplexType :: Maybe QN -> ComplexType -> Emit Type
emitComplexType anon@(Just _) t =
checkUniqueType NSComplex anon $ doComplexType t
emitComplexType Nothing t = do
n <- maybe (die $ "emitComplexType: no complex name: " ++ show t) return $
view complexTypeName t
checkDefinedType NSComplex n $ doComplexType t
doComplexType :: ComplexType -> Name -> Emit Type
doComplexType (ComplexTypeSimple _ (SimpleContentExtension scb atts) doc) mn = do
rt <- resolvedRef scb >>= emitSimpleType
ats <- emitAttrFields atts
return $ fixFields $ DataType mn
[Ctor "" (Field (getRefType scb) rt One FieldText 0:ats)]
OtherDerives [] DataTypeComplex doc
doComplexType (ComplexTypeCompositor _ comp atts doc) mn = do
ats <- emitAttrFields atts
c <- maybe (return []) (emitCompositor [nName mn]) comp
return $ fixFields $
DataType mn [Ctor "" (ats ++ c)] OtherDerives [] DataTypeComplex doc
doComplexType (ComplexTypeComplex _ (ComplexContentExtension ccb atts comp) doc) mn = do
ct <- resolvedRef ccb >>= emitComplexType (Just $ nName mn)
ats <- emitAttrFields atts
c <- maybe (return []) (emitCompositor [nName mn]) comp
return $ fixFields $ DataType mn
[Ctor "" (Field (getRefType ccb) ct One FieldOther 0:(ats ++ c))]
OtherDerives [] DataTypeComplex doc
getRefType :: Ref t -> QN
getRefType (Unresolved n) = n
getRefType (Resolved n _) = n
getRefType Final = error "Attempt to resolve ref on final"
emitCompositor :: [QN] -> Compositor -> Emit [Field]
emitCompositor ns (CompositorGroup g) = emitGroup ns g
emitCompositor ns (CompositorChoice c) = emitChoice ns c Nothing
emitCompositor ns (CompositorSequence s) = emitSequence ns Nothing s Nothing
appendNames :: [QN] -> Maybe QN -> [QN]
appendNames ss = maybe ss (:ss)
emitGroup :: [QN] -> Group -> Emit [Field]
emitGroup ns (GroupRef r o) = do
g <- resolvedRef r
t <- checkDefinedType NSGroup (getRefType r) $ \tn ->
do
fs <- emitGroup ns g
return $ DataType tn [Ctor "" fs]
OtherDerives [] DataTypeComplex Nothing
return $ forOccurs o $ Field (getRefType r) t One FieldOther 0
emitGroup ns (GroupChoice n o c doc) =
concatMap (forOccurs o) <$> emitChoice (appendNames ns n) c doc
emitGroup ns (GroupSequence n o s doc) =
concatMap (forOccurs o) <$> emitSequence (appendNames ns n) (Just o) s doc
emitChoice :: [QN] -> Choice -> Maybe Documentation -> Emit [Field]
emitChoice ns (Choice o ps) doc = do
fss <- mapM (emitParticle ns) ps
t <- checkUniqueType NSChoice (Just $ head ns) $ \mn ->
do
let cctor fs = Ctor (_qLocal (chooseName fs)) fs
chooseName [f] = _fieldName f
chooseName fs = _fieldName (head fs)
return $ fixFields $
DataType mn (map cctor fss) OtherDerives [] DataTypeCompositor doc
return $ forOccurs o (Field (head ns) t One FieldOther 0)
fixFields :: Type -> Type
fixFields = over typeCtors (\cs -> evalState (mapM fixC cs) mempty)
where fixC :: Ctor -> State (M.Map QN Int) Ctor
fixC c@(Ctor _ fs) = do
fs' <- mapM fixF fs
return $ set ctorFields fs' c
fixF :: Field -> State (M.Map QN Int) Field
fixF f@(Field fn _ _ _ _) = do
seen <- M.lookup fn <$> get
modify (M.insertWith (+) fn 1)
return $ maybe f (\i -> set fieldIdx i f) seen
emitSequence :: [QN] -> Maybe Occurs -> Sequence -> Maybe Documentation -> Emit [Field]
emitSequence ns parentO (Sequence o ps) doc = do
fs <- concat <$> mapM (emitParticle ns) ps
case (occursToCardinality o,fmap occursToCardinality parentO) of
(One,Nothing) -> return fs
(One,Just One) -> return fs
_ -> do
t <- checkUniqueType NSSequence (Just $ head ns) $ \mn ->
return $ fixFields $
DataType mn [Ctor "" fs] OtherDerives [] DataTypeCompositor doc
return $ forOccurs o (Field (head ns) t One FieldOther 0)
emitParticle :: [QN] -> Particle -> Emit [Field]
emitParticle _ (PartElement e) = do
et <- emitElement e
fn <- maybe (die "emitParticle: emitted element must have name") return $
firstOf elementName e
let o = fromMaybe (Occurs Nothing Nothing) $ firstOf elementOccurs e
return $ forOccurs o $ Field fn et One FieldElement 0
emitParticle ns (PartGroup g) = emitGroup ns g
emitParticle ns (PartChoice c) = emitChoice ns c Nothing
emitParticle ns (PartSequence s) = emitSequence ns Nothing s Nothing
forOccurs :: Occurs -> Field -> [Field]
forOccurs (Occurs Nothing Nothing) f = [f]
forOccurs (Occurs (Just "0") Nothing) f = [set fieldCardinality ZeroOrOne f]
forOccurs (Occurs _ _) f = [set fieldCardinality Many f]
occursToCardinality :: Occurs -> Cardinality
occursToCardinality (Occurs Nothing Nothing) = One
occursToCardinality (Occurs Nothing (Just "1")) = One
occursToCardinality (Occurs (Just "0") Nothing) = ZeroOrOne
occursToCardinality (Occurs (Just "1") Nothing) = One
occursToCardinality (Occurs (Just "1") (Just "1")) = One
occursToCardinality (Occurs _ _) = Many
emitAttrFields :: Attributes -> Emit [Field]
emitAttrFields = doAttrs
where doAttrs (Attributes as ags) =
(++) <$> (catMaybes <$> mapM resolveAttr as) <*>
(concat <$> mapM resolveAttrGroup ags)
forUse Prohibited _ = Nothing
forUse Optional a = Just $ set fieldCardinality ZeroOrOne a
forUse Required a = Just $ set fieldCardinality One a
resolveAttr (AttributeRef r u _) = do
a <- resolvedRef r
maybe Nothing (forUse u) <$> resolveAttr a
resolveAttr (AttributeSimpleType n t) = do
a <- checkDefinedType NSSimple n (doSimpleType t)
return $ Just $ Field n a One FieldAttribute 0
resolveAttr (AttributeType n r u _) =
resolvedRef r >>= emitSimpleType >>= \t ->
return $ forUse u $ Field n t One FieldAttribute 0
resolveAttrGroup (AttributeGroup _ as doc) = doAttrs as
resolveAttrGroup (AttributeGroupRef r) = resolvedRef r >>= resolveAttrGroup
checkUniqueType :: Namespace -> Maybe QN -> (Name -> Emit Type) -> Emit Type
checkUniqueType ns mtn act = do
n <- case mtn of
Just t -> return t
Nothing -> fmap (take 1) (use stack) >>= \h ->
case h of [Name _ a _] -> return a
_ -> die $ "checkType: empty stack on anon type: " ++ show ns
let find i = do
let cand = Name ns n i
mt <- M.lookup cand <$> use types
maybe (return cand) (\_ -> find (succ i)) mt
mn <- find 0
buildType mn act
checkDefinedType :: Namespace -> QN -> (Name -> Emit Type) -> Emit Type
checkDefinedType ns tn act = do
let mn = Name ns tn 0
ts <- M.lookup mn <$> use types
case ts of
Just t -> return t
Nothing -> buildType mn act
buildType :: Name -> (Name -> Emit Type) -> Emit Type
buildType mn act = do
stack %= (mn:)
nt <- act mn
stack %= tail
types %= M.insert mn nt
return nt