-- expanded from stub module to add new rules. module Rules.Xml(rules) where import List (nub,sortBy) import RuleUtils -- useful to have a look at this too rules :: [RuleDef] rules = [ ("Haskell2Xml", userRuleXmlOld, "Representation" , "encode terms as XML (HaXml<=1.13)", Nothing) , ("XmlContent", userRuleXmlNew, "Representation" , "encode terms as XML (HaXml>=1.14)", Nothing) , ("Parse", userRuleTextParse, "Utility" , "parse values back from standard 'Show'" , Just "Generates the Parse class supplied in\ \ module Text.ParserCombinators.TextParser\ \ as part of HaXml>=1.14. This represents\ \ a replacement for the Prelude.Read class,\ \ with better error messages.") ] {- datatype that rules manipulate :- data Data = D { name :: Name, -- type's name constraints :: [(Class,Var)], vars :: [Var], -- Parameters body :: [Body], derives :: [Class], -- derived classes statement :: Statement} -- type of statement | Directive --| | TypeName Name --| used by derive (ignore) deriving (Eq,Show) data Body = Body { constructor :: Constructor, labels :: [Name], -- [] for a non-record datatype. types :: [Type]} deriving (Eq,Show) data Statement = DataStmt | NewTypeStmt deriving (Eq,Show) type Name = String type Var = String type Class = String type Constructor = String type Rule = (Tag, Data->Doc) -} userRuleXmlOld dat = let cs = body dat -- constructors cvs = mknss cs namesupply -- variables in instanceheader "Haskell2Xml" dat $$ block (toHTfn cs cvs dat : ( text "fromContents (CElem (Elem constr [] cs):etc)" $$ vcat (preorder cs (zipWith readsfn cvs cs))) : zipWith3 showsfn [0..] cvs cs) userRuleXmlNew dat = let cs = body dat -- constructors cvs = mknss cs namesupply -- variables in instanceheader "HTypeable" dat $$ block [toHTfn cs cvs dat] $$ instanceheader "XmlContent" dat $$ block ( case cs of [c] -> text "parseContents = do" $$ nest 4 (text "{ inElementWith (flip isPrefixOf)" <+> text (show (constructor c)) <+> text "$" $$ parseFn True (head cvs) c $$ text "}" ) _ -> text "parseContents = do" $$ nest 4 (text "{ e@(Elem t _ _) <- elementWith (flip isPrefixOf)" <+> text (show (preorder cs (map constructor cs))) $$ text "; case t of" $$ nest 2 (text "_" $$ nest 2 (vcat (preorder cs (zipWith (parseFn False) cvs cs)))) $$ text "}" ) : zipWith3 showsfn [0..] cvs cs) toHTfn cs cvs dat = let typ = name dat fvs = vars dat pats = concat (zipWith mkpat cvs cs) in text "toHType v =" $$ nest 4 ( text "Defined" <+> fsep [ text "\"" <> text typ <> text "\"" , bracketList (map text fvs) , bracketList (zipWith toConstr cvs cs) ] ) $$ if null pats then empty else nest 2 (text "where") $$ nest 4 (vcat (map (<+> text "= v") pats)) $$ nest 4 (vcat (map (simplest typ (zip cvs cs)) fvs)) namesupply = [text [x,y] | x <- ['a' .. 'z'], y <- ['a' .. 'z'] ++ ['A' .. 'Z']] mknss [] _ = [] mknss (c:cs) ns = let (thisns,rest) = splitAt (length (types c)) ns in thisns: mknss cs rest mkpat ns c = if null ns then [] else [mypattern (constructor c) (types c) ns] toConstr :: [Doc] -> Body -> Doc toConstr ns c = let cn = constructor c ts = types c fvs = nub (concatMap deepvars ts) in text "Constr" <+> fsep [ text "\"" <> text cn <> text "\"" , bracketList (map text fvs) , bracketList (map (\v-> text "toHType" <+> v) ns) ] where deepvars (Arrow t1 t2) = [] --deepvars (Apply t1 t2) = deepvars t1 ++ deepvars t2 deepvars (LApply c ts) = concatMap deepvars ts deepvars (Var s) = [s] deepvars (Con s) = [] deepvars (Tuple ts) = concatMap deepvars ts deepvars (List t) = deepvars t --first [] fv = error ("cannot locate free type variable "++fv) --first ((ns,c):cs) fv = -- let npats = [ (n,pat) | (n,t) <- zip ns (types c) -- , (True,pat) <- [ find fv t ] -- ] -- in -- if null npats then -- first cs fv -- else let (n,pat) = head npats -- in parens pat <+> text "= toHType" <+> n -- -- where -- -- find :: String -> Type -> (Bool,Doc) -- find v (Arrow t1 t2) = (False,error "can't ShowXML for arrow type") -- find v (Apply t1 t2) = let (tf1,pat1) = find v t1 -- (tf2,pat2) = find v t2 -- in perhaps (tf1 || tf2) -- (pat1 <+> snd (perhaps tf2 pat2)) -- find v (LApply c ts) = let (_,cpat) = find v c -- tfpats = map (find v) ts -- (tfs,pats) = unzip tfpats -- in perhaps (or tfs) -- (parens (cpat <+> -- bracketList (map (snd.uncurry perhaps) tfpats))) -- find v (Var s) = perhaps (v==s) (text v) -- find v (Con s) = (False, text "Defined" <+> -- text "\"" <> text s <> text "\"") -- find v (Tuple ts) = let tfpats = map (find v) ts -- (tfs,pats) = unzip tfpats -- in perhaps (or tfs) -- (parens (text "Tuple" <+> -- bracketList (map (snd.uncurry perhaps) tfpats))) -- find v (List t) = let (tf,pat) = find v t -- in perhaps tf (parens (text "List" <+> pat)) -- perhaps tf doc = if tf then (True,doc) else (False,text "_") simplest typ cs fv = let npats = [ (depth,(n,pat)) | (ns,c) <- cs , (n,t) <- zip ns (types c) , (depth, pat) <- [ find fv t ] ] (_,(n,pat)) = foldl closest (Nothing,error "free tyvar not found") npats in parens pat <+> text "= toHType" <+> n where find :: String -> Type -> (Maybe Int,Doc) find v (Arrow t1 t2) = (Nothing,error "can't derive Haskell2Xml/HTypeable for arrow type") -- find v (Apply t1 t2) = let (d1,pat1) = find v t1 -- (d2,pat2) = find v t2 -- in perhaps (combine [d1,d2]) -- (pat1 <+> snd (perhaps d2 pat2)) find v (LApply c ts) | c == (Con typ) = (Nothing, text "_") | otherwise = let (_,cpat) = find v c dpats = map (find v) ts (ds,pats) = unzip dpats in perhaps (combine ds) (cpat <+> bracketList (map (snd.uncurry perhaps) dpats) <+> text "_") find v (Var s) = perhaps (if v==s then Just 0 else Nothing) (text v) find v (Con s) = (Nothing, text "Defined" <+> text "\"" <> text s <> text "\"") find v (Tuple ts) = let dpats = map (find v) ts (ds,pats) = unzip dpats in perhaps (combine ds) (text "Tuple" <+> bracketList (map (snd.uncurry perhaps) dpats)) find v (List t) = let (d,pat) = find v t in perhaps (inc d) (text "List" <+> parens pat) perhaps Nothing doc = (Nothing, text "_") perhaps jn doc = (jn,doc) combine ds = let js = [ n | (Just n) <- ds ] in if null js then Nothing else inc (Just (minimum js)) inc Nothing = Nothing inc (Just n) = Just (n+1) closest :: (Maybe Int,a) -> (Maybe Int,a) -> (Maybe Int,a) closest (Nothing,_) b@(Just _,_) = b closest a@(Just n,_) b@(Just m,_) | n< m = a | m<=n = b closest a b = a -- showsfn (n = index) (ns = variables) (cn = constructor body) showsfn n ns cn = let cons = constructor cn typ = types cn sc = parens (text "showConstr" <+> text (show n) <+> parens (text "toHType" <+> text "v")) cfn [] = text "[]" cfn [x] = parens (text "toContents" <+> x) cfn xs = parens (text "concat" <+> bracketList (map (text "toContents" <+>) xs)) in text "toContents" <+> text "v@" <> mypattern cons typ ns <+> text "=" $$ nest 4 (text "[mkElemC" <+> sc <+> cfn ns <> text "]") ---- -- text "fromContents (CElem (Elem constr [] cs):etc)" $$ ---- -- readsfn (ns = variables) (cn = constructor body) readsfn ns cn = let cons = text (constructor cn) typ = types cn num = length ns - 1 str d = text "\"" <> d <> text "\"" trails = take num (map text [ ['c','s',y,z] | y <- ['0'..'9'] , z <- ['0'..'9'] ]) cfn x = parens (text "fromContents" <+> x) (init,[last]) = splitAt num ns something = parens ( text "\\" <> parenList [last, text "_"] <> text "->" <+> parens (cons <+> hsep ns <> text "," <+> text "etc") ) mkLambda (n,cv) z = parens ( text "\\" <> parenList [n,cv] <> text "->" <+> fsep [z, cfn cv] ) in nest 4 ( text "|" <+> str cons <+> text "`isPrefixOf` constr =" $$ nest 4 ( if null ns then parenList [cons, text "etc"] else fsep [ foldr mkLambda something (zip init trails) , cfn (text "cs")] ) ) -- Constructors are matched with "isPrefixOf" rather than "==" -- because of parametric polymorphism. For a datatype -- data A x = A | B x -- the XML tags will be , , , etc. -- However prefix-matching presents a problem for types like -- data C = C | CD -- because (C `isPrefixOf`) matches both constructors. The solution -- (implemented by "preorder") is to order the constructors such that -- is matched before . preorder cs = map snd . reverse . sortBy (\(a,_) (b,_)-> compare a b) . zip (map constructor cs) -- parseFn (ns = variables) (cn = constructor body) parseFn single ns cn = let cons = constructor cn arity = length (types cn) var v = text ";" <+> v <+> text "<- parseContents" intro = if single then empty else text "|" <+> text (show cons) <+> text "`isPrefixOf` t -> interior e $" in case arity of 0 -> intro <+> nest 8 (text "return" <+> text cons) 1 -> intro <+> nest 8 (text "fmap" <+> text cons <+> text "parseContents") _ -> intro $$ nest 8 (text "return" <+> text cons <+> (fsep (replicate arity (text "`apply` parseContents")))) -- instanceheader cls dat = let fv = vars dat tycon = name dat ctx = map (\v-> text cls <+> text v) parenSpace = parens . hcat . sepWith space in hsep [ text "instance" , opt fv (\v -> parenList (ctx v) <+> text "=>") , text cls , opt1 (texts (tycon: fv)) parenSpace id , text "where" ] mypattern :: Constructor -> [a] -> [Doc] -> Doc mypattern c l ns = if null l then text c else parens (hsep (text c : take (length l) ns)) -- ----------------------------------------------------------------------- -- userRuleTextParse dat = let cs = body dat -- constructors cvs = mknss cs namesupply -- variables isNullary c = null (types c) in instanceheader "Parse" dat $$ nest 4 ( case cs of [] -> empty _ | all isNullary cs -> text "parse = enumeration" <+> text (show (name dat)) <+> text "[" <+> fsep ( text (constructor (head cs)) : map (\c-> text "," <+> text (constructor c)) (tail cs)) <+> text "]" | otherwise -> text "parse = constructors" $$ nest 4 (text "[" <+> textParseFn (head cvs) (head cs) $$ vcat (zipWith (\cv c-> text "," <+> textParseFn cv c) (tail cvs) (tail cs)) $$ text "]" ) ) -- textParseFn (ns = variables) (cn = constructor body) textParseFn ns cn = let cons = constructor cn arity = length (types cn) fields = labels cn doField f = text "`discard` isWord \",\" `apply` field" <+> text (show f) in fsep ( text "(" <+> text (show cons) : text "," <+> nest 2 (case arity of 0 -> text "return" <+> text cons 1 | null fields -> text "fmap" <+> text cons <+> text "parse" _ | null fields -> text "return" <+> text cons <+> (fsep (replicate arity (text "`apply` parse"))) | otherwise -> text "return" <+> text cons <+> fsep ( text "`discard` isWord \"{\" `apply` field" <+> text (show (head fields)) : map doField (tail fields) ++ [text "`discard` isWord \"}\""] ) ) : text ")" : []) -- ----------------------------------------------------------------------- --