multifocal (empty) → 0.0.1
raw patch · 29 files changed
+4005/−0 lines, 29 filesdep +HaXmldep +arraydep +basesetup-changed
Dependencies added: HaXml, array, base, containers, haskell-src-exts, hxt, hxt-xpath, mtl, parsec, pointless-haskell, pointless-lenses, pointless-rewrite, pretty, process, syb
Files
- LICENSE +31/−0
- README +32/−0
- Setup.lhs +3/−0
- dist/build/Language/TLT/TltLexer.hs +487/−0
- dist/build/Language/TLT/TltParser.hs +645/−0
- examples/company.2lt +5/−0
- examples/company.xml +41/−0
- examples/company.xsd +44/−0
- examples/imdb.2lt +8/−0
- examples/imdb.xml +33/−0
- examples/imdb.xsd +76/−0
- examples/imdb2mod.xml +37/−0
- multifocal.cabal +49/−0
- src/Data/Transform/TwoLevel.hs +478/−0
- src/Language/TLT/Tlt2Strat.hs +76/−0
- src/Language/TLT/TltLexer.x +86/−0
- src/Language/TLT/TltParser.y +104/−0
- src/Language/TLT/TltSyntax.hs +21/−0
- src/Language/XML/HaXmlAliases.hs +90/−0
- src/Language/XML/Type2Xml.hs +130/−0
- src/Language/XML/Type2Xsd.hs +197/−0
- src/Language/XML/Xml2Type.hs +160/−0
- src/Language/XML/Xsd2Type.hs +317/−0
- src/Language/XPath/HXTAliases.hs +33/−0
- src/Language/XPath/XPath2Pf.hs +215/−0
- src/UI/CmdLine.hs +119/−0
- src/UI/GenHaskell.hs +322/−0
- src/UI/LensMenu.hs +116/−0
- src/UI/Menu.hs +50/−0
+ LICENSE view
@@ -0,0 +1,31 @@+Copyright (c) 2012, University of Minho++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * The names of contributors may not be used to endorse or promote+ products derived from this software without specific prior+ written permission. ++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README view
@@ -0,0 +1,32 @@+Multifocal++This cabal package can be installed with:++$ cabal install multifocal++For a manual install, execute:++$ runhaskell Setup.lhs configure+$ runhaskell Setup.lhs build+$ runhaskell Setup.lhs install++For an example, try running the following steps:++1) generate a target XML Schema file and an optimized lens executable from the source XML Schema file imdb.xsd according to the transformation imdb.2lt.++$ multifocal -i examples/imdb.xsd -t examples/imdb.2lt -o examples/imdb2.xsd -c examples/Imdb.hs -e++2) compile the resulting file++$ ghc --make examples/Imdb.hs -o imdb++3) Migrate a source XML document into a target XML document++$ ./imdb -s examples/imdb.xml -f -o examples/imdb2.xml++4) Translate an updated target XML document back to the source++./imdb -s examples/imdb.xml -t examples/imdb2mod.xml -b -o examples/imdbmod.xml+++
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ dist/build/Language/TLT/TltLexer.hs view
@@ -0,0 +1,487 @@+{-# LANGUAGE CPP,MagicHash #-}+{-# LINE 1 "src/Language/TLT/TltLexer.x" #-}++-----------------------------------------------------------------------------+-- |+-- Module : Language.TLT.TltLexer+-- Copyright : (c) 2011 University of Minho+-- License : BSD3+--+-- Maintainer : hpacheco@di.uminho.pt+-- Stability : experimental+-- Portability : non-portable+--+-- Multifocal:+-- Bidirectional Two-level Transformation of XML Schemas+-- +-- Lexer for the two-level language.+--+-----------------------------------------------------------------------------++module Language.TLT.TltLexer where++import Text.ParserCombinators.Parsec (SourcePos)++#if __GLASGOW_HASKELL__ >= 603+#include "ghcconfig.h"+#elif defined(__GLASGOW_HASKELL__)+#include "config.h"+#endif+#if __GLASGOW_HASKELL__ >= 503+import Data.Array+import Data.Char (ord)+import Data.Array.Base (unsafeAt)+#else+import Array+import Char (ord)+#endif+#if __GLASGOW_HASKELL__ >= 503+import GHC.Exts+#else+import GlaExts+#endif+{-# LINE 1 "templates/wrappers.hs" #-}+{-# LINE 1 "templates/wrappers.hs" #-}+{-# LINE 1 "<built-in>" #-}+{-# LINE 1 "<command-line>" #-}+{-# LINE 1 "templates/wrappers.hs" #-}+-- -----------------------------------------------------------------------------+-- Alex wrapper code.+--+-- This code is in the PUBLIC DOMAIN; you may copy it freely and use+-- it for any purpose whatsoever.++{-# LINE 18 "templates/wrappers.hs" #-}++-- -----------------------------------------------------------------------------+-- The input type+++type AlexInput = (AlexPosn, -- current position,+ Char, -- previous char+ String) -- current input string++alexInputPrevChar :: AlexInput -> Char+alexInputPrevChar (p,c,s) = c++alexGetChar :: AlexInput -> Maybe (Char,AlexInput)+alexGetChar (p,c,[]) = Nothing+alexGetChar (p,_,(c:s)) = let p' = alexMove p c in p' `seq`+ Just (c, (p', c, s))+++{-# LINE 51 "templates/wrappers.hs" #-}++-- -----------------------------------------------------------------------------+-- Token positions++-- `Posn' records the location of a token in the input text. It has three+-- fields: the address (number of chacaters preceding the token), line number+-- and column of a token within the file. `start_pos' gives the position of the+-- start of the file and `eof_pos' a standard encoding for the end of file.+-- `move_pos' calculates the new position after traversing a given character,+-- assuming the usual eight character tab stops.+++data AlexPosn = AlexPn !Int !Int !Int+ deriving (Eq,Show)++alexStartPos :: AlexPosn+alexStartPos = AlexPn 0 1 1++alexMove :: AlexPosn -> Char -> AlexPosn+alexMove (AlexPn a l c) '\t' = AlexPn (a+1) l (((c+7) `div` 8)*8+1)+alexMove (AlexPn a l c) '\n' = AlexPn (a+1) (l+1) 1+alexMove (AlexPn a l c) _ = AlexPn (a+1) l (c+1)+++-- -----------------------------------------------------------------------------+-- Default monad+++data AlexState = AlexState {+ alex_pos :: !AlexPosn, -- position at current input location+ alex_inp :: String, -- the current input+ alex_chr :: !Char, -- the character before the input+ alex_scd :: !Int -- the current startcode++++ }++-- Compile with -funbox-strict-fields for best results!++runAlex :: String -> Alex a -> Either String a+runAlex input (Alex f) + = case f (AlexState {alex_pos = alexStartPos,+ alex_inp = input, + alex_chr = '\n',++++ alex_scd = 0}) of Left msg -> Left msg+ Right ( _, a ) -> Right a++newtype Alex a = Alex { unAlex :: AlexState -> Either String (AlexState, a) }++instance Monad Alex where+ m >>= k = Alex $ \s -> case unAlex m s of + Left msg -> Left msg+ Right (s',a) -> unAlex (k a) s'+ return a = Alex $ \s -> Right (s,a)++alexGetInput :: Alex AlexInput+alexGetInput+ = Alex $ \s@AlexState{alex_pos=pos,alex_chr=c,alex_inp=inp} -> + Right (s, (pos,c,inp))++alexSetInput :: AlexInput -> Alex ()+alexSetInput (pos,c,inp)+ = Alex $ \s -> case s{alex_pos=pos,alex_chr=c,alex_inp=inp} of+ s@(AlexState{}) -> Right (s, ())++alexError :: String -> Alex a+alexError message = Alex $ \s -> Left message++alexGetStartCode :: Alex Int+alexGetStartCode = Alex $ \s@AlexState{alex_scd=sc} -> Right (s, sc)++alexSetStartCode :: Int -> Alex ()+alexSetStartCode sc = Alex $ \s -> Right (s{alex_scd=sc}, ())++alexMonadScan = do+ inp <- alexGetInput+ sc <- alexGetStartCode+ case alexScan inp sc of+ AlexEOF -> alexEOF+ AlexError inp' -> alexError "lexical error"+ AlexSkip inp' len -> do+ alexSetInput inp'+ alexMonadScan+ AlexToken inp' len action -> do+ alexSetInput inp'+ action inp len++-- -----------------------------------------------------------------------------+-- Useful token actions++type AlexAction result = AlexInput -> Int -> result++-- just ignore this token and scan another one+-- skip :: AlexAction result+skip input len = alexMonadScan++-- ignore this token, but set the start code to a new value+-- begin :: Int -> AlexAction result+begin code input len = do alexSetStartCode code; alexMonadScan++-- perform an action for this token, and set the start code to a new value+-- andBegin :: AlexAction result -> Int -> AlexAction result+(action `andBegin` code) input len = do alexSetStartCode code; action input len++-- token :: (String -> Int -> token) -> AlexAction token+token t input len = return (t input len)++++-- -----------------------------------------------------------------------------+-- Monad (with ByteString input)++{-# LINE 251 "templates/wrappers.hs" #-}+++-- -----------------------------------------------------------------------------+-- Basic wrapper++{-# LINE 273 "templates/wrappers.hs" #-}+++-- -----------------------------------------------------------------------------+-- Basic wrapper, ByteString version++{-# LINE 297 "templates/wrappers.hs" #-}++{-# LINE 322 "templates/wrappers.hs" #-}+++-- -----------------------------------------------------------------------------+-- Posn wrapper++-- Adds text positions to the basic model.++{-# LINE 339 "templates/wrappers.hs" #-}+++-- -----------------------------------------------------------------------------+-- Posn wrapper, ByteString version++{-# LINE 354 "templates/wrappers.hs" #-}+++-- -----------------------------------------------------------------------------+-- GScan wrapper++-- For compatibility with previous versions of Alex, and because we can.++alex_base :: AlexAddr+alex_base = AlexA# "\xf8\xff\xff\xff\xfd\xff\xff\xff\x00\x00\x00\x00\x01\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\xff\xff\xff\x9f\xff\xff\xff\x00\x00\x00\x00\xd0\xff\xff\xff\x00\x00\x00\x00\x94\xff\xff\xff\x00\x00\x00\x00\xa0\xff\xff\xff\x98\xff\xff\xff\x00\x00\x00\x00\xb2\xff\xff\xff\xa6\xff\xff\xff\x9c\xff\xff\xff\x00\x00\x00\x00\xaa\xff\xff\xff\xab\xff\xff\xff\x00\x00\x00\x00\xad\xff\xff\xff\xb6\xff\xff\xff\xb7\xff\xff\xff\x00\x00\x00\x00\xb3\xff\xff\xff\xba\xff\xff\xff\xb4\xff\xff\xff\xae\xff\xff\xff\xb1\xff\xff\xff\xc2\xff\xff\xff\xc6\xff\xff\xff\xbb\xff\xff\xff\xc7\xff\xff\xff\x00\x00\x00\x00\xbc\xff\xff\xff\xc9\xff\xff\xff\xbd\xff\xff\xff\xc4\xff\xff\xff\xc3\xff\xff\xff\xc0\xff\xff\xff\xc1\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\xcc\xff\xff\xff\xd2\xff\xff\xff\xca\xff\xff\xff\x00\x00\x00\x00\xcb\xff\xff\xff\xd3\xff\xff\xff\xc8\xff\xff\xff\xc5\xff\xff\xff\x00\x00\x00\x00\xd1\xff\xff\xff\xcd\xff\xff\xff\xd5\xff\xff\xff\xd7\xff\xff\xff\xda\xff\xff\xff\x00\x00\x00\x00\xdb\xff\xff\xff\xd6\xff\xff\xff\xe0\xff\xff\xff\xd8\xff\xff\xff\xe1\xff\xff\xff\x00\x00\x00\x00\xe6\xff\xff\xff\xd9\xff\xff\xff\xe3\xff\xff\xff\x00\x00\x00\x00\xe4\xff\xff\xff\xde\xff\xff\xff\xe8\xff\xff\xff\xeb\xff\xff\xff\xdc\xff\xff\xff"#++alex_table :: AlexAddr+alex_table = AlexA# "\x00\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\x01\x00\xff\xff\xff\xff\x09\x00\x0a\x00\x07\x00\x0c\x00\x0e\x00\x10\x00\x13\x00\x14\x00\x11\x00\x17\x00\x15\x00\x01\x00\x1b\x00\x03\x00\x1a\x00\x18\x00\x01\x00\x2e\x00\x1f\x00\x05\x00\x06\x00\x27\x00\x02\x00\x02\x00\x45\x00\x20\x00\x21\x00\x22\x00\x1e\x00\x23\x00\x24\x00\x1c\x00\x25\x00\x29\x00\x2a\x00\x28\x00\x2b\x00\x2c\x00\x2d\x00\x31\x00\x26\x00\x0b\x00\x32\x00\x2f\x00\x33\x00\x35\x00\x37\x00\x36\x00\x3a\x00\x3d\x00\x38\x00\x40\x00\x42\x00\x3b\x00\x3c\x00\x41\x00\x43\x00\x3e\x00\x46\x00\x44\x00\x4a\x00\x4b\x00\x00\x00\x47\x00\x4c\x00\x4d\x00\x00\x00\x48\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x00\x00\x00\x00\x1d\x00\x00\x00\x00\x00\x34\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x08\x00\x19\x00\x39\x00\x00\x00\x3f\x00\x49\x00\x0f\x00\x00\x00\x00\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#++alex_check :: AlexAddr+alex_check = AlexA# "\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0a\x00\x0a\x00\x6f\x00\x3e\x00\x70\x00\x7c\x00\x79\x00\x72\x00\x61\x00\x6e\x00\x79\x00\x6c\x00\x6c\x00\x20\x00\x63\x00\x22\x00\x6e\x00\x65\x00\x20\x00\x74\x00\x65\x00\x28\x00\x29\x00\x75\x00\x22\x00\x22\x00\x72\x00\x72\x00\x79\x00\x77\x00\x76\x00\x68\x00\x65\x00\x65\x00\x72\x00\x65\x00\x72\x00\x74\x00\x6d\x00\x6f\x00\x73\x00\x68\x00\x74\x00\x3e\x00\x65\x00\x6e\x00\x74\x00\x6f\x00\x73\x00\x69\x00\x6c\x00\x67\x00\x65\x00\x65\x00\x61\x00\x75\x00\x6e\x00\x6e\x00\x6d\x00\x65\x00\x61\x00\x65\x00\x65\x00\x6c\x00\xff\xff\x73\x00\x65\x00\x63\x00\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\x68\x00\xff\xff\xff\xff\xff\xff\xff\xff\x6d\x00\x6e\x00\x6f\x00\x70\x00\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#++alex_deflt :: AlexAddr+alex_deflt = AlexA# "\xff\xff\xff\xff\xff\xff\x04\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#++alex_accept = listArray (0::Int,77) [[],[(AlexAccSkip)],[(AlexAcc (alex_action_1))],[],[],[(AlexAcc (alex_action_2))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_4))],[],[],[(AlexAcc (alex_action_5))],[],[(AlexAcc (alex_action_6))],[],[(AlexAcc (alex_action_7))],[],[],[(AlexAcc (alex_action_8))],[],[],[],[(AlexAcc (alex_action_9))],[],[],[(AlexAcc (alex_action_10))],[],[],[],[(AlexAcc (alex_action_11))],[],[],[],[],[],[],[],[],[],[(AlexAcc (alex_action_12))],[],[],[],[],[],[],[],[(AlexAcc (alex_action_13))],[(AlexAcc (alex_action_14))],[],[],[],[(AlexAcc (alex_action_15))],[],[],[],[],[(AlexAcc (alex_action_16))],[],[],[],[],[],[(AlexAcc (alex_action_17))],[],[],[],[],[],[(AlexAcc (alex_action_18))],[],[],[],[(AlexAcc (alex_action_19))],[],[],[],[],[]]+{-# LINE 52 "src/Language/TLT/TltLexer.x" #-}+++makeAlexAction ::Monad m => (String -> Token) -> AlexInput -> Int -> m Token+makeAlexAction cons = \ (_,_,inp) len ->return $cons (take len inp)++-- | Just to make alexMonadScan work, although we do not use it+alexEOF = return undefined++data Token = TokNop | TokComp | TokChoice | TokTry | TokMany+ | TokAll | TokOnce | TokEverywhere | TokOutermost+ | TokAt | TokWhen | TokHoist | TokPlunge | TokRename+ | TokErase | TokSelect+ | TokString String | TokSym Char+ deriving Show++alexMonadScanTokens :: Alex [Token]+alexMonadScanTokens = do+ inp <- alexGetInput+ sc <- alexGetStartCode+ case alexScan inp sc of+ AlexEOF -> return []+ AlexError inp' -> alexError "lexical error"+ AlexSkip inp' len -> do+ alexSetInput inp'+ alexMonadScanTokens+ AlexToken inp' len action -> do+ alexSetInput inp'+ token <- action inp len+ tokens <- alexMonadScanTokens+ return $ token : tokens++lexTLT :: String -> Either String [Token]+lexTLT s = runAlex s alexMonadScanTokens+++alex_action_1 = makeAlexAction (\s -> TokString $ tail $ init s) +alex_action_2 = makeAlexAction (\s -> TokSym '(') +alex_action_3 = makeAlexAction (\s -> TokSym ')') +alex_action_4 = makeAlexAction (\s -> TokNop) +alex_action_5 = makeAlexAction (\s -> TokComp) +alex_action_6 = makeAlexAction (\s -> TokChoice) +alex_action_7 = makeAlexAction (\s -> TokTry) +alex_action_8 = makeAlexAction (\s -> TokMany) +alex_action_9 = makeAlexAction (\s -> TokAll) +alex_action_10 = makeAlexAction (\s -> TokOnce) +alex_action_11 = makeAlexAction (\s -> TokEverywhere) +alex_action_12 = makeAlexAction (\s -> TokOutermost) +alex_action_13 = makeAlexAction (\s -> TokAt) +alex_action_14 = makeAlexAction (\s -> TokWhen) +alex_action_15 = makeAlexAction (\s -> TokHoist) +alex_action_16 = makeAlexAction (\s -> TokPlunge) +alex_action_17 = makeAlexAction (\s -> TokRename) +alex_action_18 = makeAlexAction (\s -> TokErase) +alex_action_19 = makeAlexAction (\s -> TokSelect) +{-# LINE 1 "templates/GenericTemplate.hs" #-}+{-# LINE 1 "templates/GenericTemplate.hs" #-}+{-# LINE 1 "<built-in>" #-}+{-# LINE 1 "<command-line>" #-}+{-# LINE 1 "templates/GenericTemplate.hs" #-}+-- -----------------------------------------------------------------------------+-- ALEX TEMPLATE+--+-- This code is in the PUBLIC DOMAIN; you may copy it freely and use+-- it for any purpose whatsoever.++-- -----------------------------------------------------------------------------+-- INTERNALS and main scanner engine++{-# LINE 37 "templates/GenericTemplate.hs" #-}++{-# LINE 47 "templates/GenericTemplate.hs" #-}+++data AlexAddr = AlexA# Addr#++#if __GLASGOW_HASKELL__ < 503+uncheckedShiftL# = shiftL#+#endif++{-# INLINE alexIndexInt16OffAddr #-}+alexIndexInt16OffAddr (AlexA# arr) off =+#ifdef WORDS_BIGENDIAN+ narrow16Int# i+ where+ i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low)+ high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))+ low = int2Word# (ord# (indexCharOffAddr# arr off'))+ off' = off *# 2#+#else+ indexInt16OffAddr# arr off+#endif++++++{-# INLINE alexIndexInt32OffAddr #-}+alexIndexInt32OffAddr (AlexA# arr) off = +#ifdef WORDS_BIGENDIAN+ narrow32Int# i+ where+ i = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#`+ (b2 `uncheckedShiftL#` 16#) `or#`+ (b1 `uncheckedShiftL#` 8#) `or#` b0)+ b3 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#)))+ b2 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#)))+ b1 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))+ b0 = int2Word# (ord# (indexCharOffAddr# arr off'))+ off' = off *# 4#+#else+ indexInt32OffAddr# arr off+#endif++++++#if __GLASGOW_HASKELL__ < 503+quickIndex arr i = arr ! i+#else+-- GHC >= 503, unsafeAt is available from Data.Array.Base.+quickIndex = unsafeAt+#endif+++++-- -----------------------------------------------------------------------------+-- Main lexing routines++data AlexReturn a+ = AlexEOF+ | AlexError !AlexInput+ | AlexSkip !AlexInput !Int+ | AlexToken !AlexInput !Int a++-- alexScan :: AlexInput -> StartCode -> AlexReturn a+alexScan input (I# (sc))+ = alexScanUser undefined input (I# (sc))++alexScanUser user input (I# (sc))+ = case alex_scan_tkn user input 0# input sc AlexNone of+ (AlexNone, input') ->+ case alexGetChar input of+ Nothing -> ++++ AlexEOF+ Just _ ->++++ AlexError input'++ (AlexLastSkip input'' len, _) ->++++ AlexSkip input'' len++ (AlexLastAcc k input''' len, _) ->++++ AlexToken input''' len k+++-- Push the input through the DFA, remembering the most recent accepting+-- state it encountered.++alex_scan_tkn user orig_input len input s last_acc =+ input `seq` -- strict in the input+ let + new_acc = check_accs (alex_accept `quickIndex` (I# (s)))+ in+ new_acc `seq`+ case alexGetChar input of+ Nothing -> (new_acc, input)+ Just (c, new_input) -> ++++ let+ (base) = alexIndexInt32OffAddr alex_base s+ ((I# (ord_c))) = ord c+ (offset) = (base +# ord_c)+ (check) = alexIndexInt16OffAddr alex_check offset+ + (new_s) = if (offset >=# 0#) && (check ==# ord_c)+ then alexIndexInt16OffAddr alex_table offset+ else alexIndexInt16OffAddr alex_deflt s+ in+ case new_s of + -1# -> (new_acc, input)+ -- on an error, we want to keep the input *before* the+ -- character that failed, not after.+ _ -> alex_scan_tkn user orig_input (len +# 1#) + new_input new_s new_acc++ where+ check_accs [] = last_acc+ check_accs (AlexAcc a : _) = AlexLastAcc a input (I# (len))+ check_accs (AlexAccSkip : _) = AlexLastSkip input (I# (len))+ check_accs (AlexAccPred a predx : rest)+ | predx user orig_input (I# (len)) input+ = AlexLastAcc a input (I# (len))+ check_accs (AlexAccSkipPred predx : rest)+ | predx user orig_input (I# (len)) input+ = AlexLastSkip input (I# (len))+ check_accs (_ : rest) = check_accs rest++data AlexLastAcc a+ = AlexNone+ | AlexLastAcc a !AlexInput !Int+ | AlexLastSkip !AlexInput !Int++data AlexAcc a user+ = AlexAcc a+ | AlexAccSkip+ | AlexAccPred a (AlexAccPred user)+ | AlexAccSkipPred (AlexAccPred user)++type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool++-- -----------------------------------------------------------------------------+-- Predicates on a rule++alexAndPred p1 p2 user in1 len in2+ = p1 user in1 len in2 && p2 user in1 len in2++--alexPrevCharIsPred :: Char -> AlexAccPred _ +alexPrevCharIs c _ input _ _ = c == alexInputPrevChar input++--alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _ +alexPrevCharIsOneOf arr _ input _ _ = arr ! alexInputPrevChar input++--alexRightContext :: Int -> AlexAccPred _+alexRightContext (I# (sc)) user _ _ input = + case alex_scan_tkn user input 0# input sc AlexNone of+ (AlexNone, _) -> False+ _ -> True+ -- TODO: there's no need to find the longest+ -- match when checking the right context, just+ -- the first match will do.++-- used by wrappers+iUnbox (I# (i)) = i
+ dist/build/Language/TLT/TltParser.hs view
@@ -0,0 +1,645 @@+{-# OPTIONS_GHC -w #-}+{-# OPTIONS -fglasgow-exts -cpp #-}+-----------------------------------------------------------------------------+-- |+-- Module : Language.TLT.TltParser+-- Copyright : (c) 2011 University of Minho+-- License : BSD3+--+-- Maintainer : hpacheco@di.uminho.pt+-- Stability : experimental+-- Portability : non-portable+--+-- Multifocal:+-- Bidirectional Two-level Transformation of XML Schemas+-- +-- Parser for the two-level language.+--+-----------------------------------------------------------------------------++module Language.TLT.TltParser where++import Language.TLT.TltSyntax+import Language.TLT.TltLexer+import Language.XPath.HXTAliases+import qualified Data.Array as Happy_Data_Array+import qualified GHC.Exts as Happy_GHC_Exts++-- parser produced by Happy Version 1.18.6++newtype HappyAbsSyn = HappyAbsSyn HappyAny+#if __GLASGOW_HASKELL__ >= 607+type HappyAny = Happy_GHC_Exts.Any+#else+type HappyAny = forall a . a+#endif+happyIn4 :: (TLT) -> (HappyAbsSyn )+happyIn4 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn4 #-}+happyOut4 :: (HappyAbsSyn ) -> (TLT)+happyOut4 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut4 #-}+happyIn5 :: (TLT) -> (HappyAbsSyn )+happyIn5 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn5 #-}+happyOut5 :: (HappyAbsSyn ) -> (TLT)+happyOut5 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut5 #-}+happyIn6 :: (TLT) -> (HappyAbsSyn )+happyIn6 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn6 #-}+happyOut6 :: (HappyAbsSyn ) -> (TLT)+happyOut6 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut6 #-}+happyIn7 :: (TLT) -> (HappyAbsSyn )+happyIn7 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn7 #-}+happyOut7 :: (HappyAbsSyn ) -> (TLT)+happyOut7 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut7 #-}+happyIn8 :: (TLT) -> (HappyAbsSyn )+happyIn8 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn8 #-}+happyOut8 :: (HappyAbsSyn ) -> (TLT)+happyOut8 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut8 #-}+happyIn9 :: (TLT) -> (HappyAbsSyn )+happyIn9 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn9 #-}+happyOut9 :: (HappyAbsSyn ) -> (TLT)+happyOut9 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut9 #-}+happyIn10 :: (TLT) -> (HappyAbsSyn )+happyIn10 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn10 #-}+happyOut10 :: (HappyAbsSyn ) -> (TLT)+happyOut10 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut10 #-}+happyInTok :: (Token) -> (HappyAbsSyn )+happyInTok x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyInTok #-}+happyOutTok :: (HappyAbsSyn ) -> (Token)+happyOutTok x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOutTok #-}+++happyActOffsets :: HappyAddr+happyActOffsets = HappyA# "\x01\x00\x01\x00\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x3a\x00\x39\x00\x00\x00\x38\x00\x36\x00\x00\x00\x09\x00\x01\x00\xed\xff\x14\x00\x00\x00\x00\x00\x00\x00\x11\x00\x11\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x01\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#++happyGotoOffsets :: HappyAddr+happyGotoOffsets = HappyA# "\x19\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x44\x00\x43\x00\x42\x00\x27\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x02\x00\x00\x00\x00\x00\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2d\x00\x28\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#++happyDefActions :: HappyAddr+happyDefActions = HappyA# "\x00\x00\x00\x00\xfe\xff\xfa\xff\xf9\xff\xf8\xff\xf7\xff\xf5\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xea\xff\x00\x00\x00\x00\xe7\xff\x00\x00\x00\x00\x00\x00\x00\x00\xe6\xff\xe8\xff\xe9\xff\x00\x00\x00\x00\xed\xff\xfd\xff\xfc\xff\x00\x00\xee\xff\xef\xff\xf0\xff\xf1\xff\xf2\xff\x00\x00\x00\x00\xf3\xff\xf4\xff\x00\x00\xec\xff\xeb\xff\xf6\xff\xfb\xff"#++happyCheck :: HappyAddr+happyCheck = HappyA# "\xff\xff\x14\x00\x01\x00\x01\x00\x01\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x01\x00\x12\x00\x02\x00\x03\x00\x02\x00\x03\x00\x01\x00\x00\x00\x11\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x0f\x00\x02\x00\x03\x00\x12\x00\x01\x00\x13\x00\x0f\x00\x13\x00\x01\x00\x12\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x01\x00\x01\x00\x01\x00\x01\x00\x11\x00\xff\xff\x11\x00\x11\x00\x11\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#++happyTable :: HappyAddr+happyTable = HappyA# "\x00\x00\xff\xff\x08\x00\x2b\x00\x2c\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x1f\x00\x16\x00\x27\x00\x28\x00\x27\x00\x28\x00\x1f\x00\x16\x00\x19\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x20\x00\x27\x00\x28\x00\x21\x00\x1d\x00\x2f\x00\x20\x00\x2e\x00\x21\x00\x21\x00\x28\x00\x03\x00\x04\x00\x05\x00\x06\x00\x29\x00\x03\x00\x04\x00\x05\x00\x06\x00\x2a\x00\x03\x00\x04\x00\x05\x00\x06\x00\x17\x00\x03\x00\x04\x00\x05\x00\x06\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x22\x00\x23\x00\x24\x00\x25\x00\x1a\x00\x00\x00\x1b\x00\x1c\x00\x1d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#++happyReduceArr = Happy_Data_Array.array (1, 25) [+ (1 , happyReduce_1),+ (2 , happyReduce_2),+ (3 , happyReduce_3),+ (4 , happyReduce_4),+ (5 , happyReduce_5),+ (6 , happyReduce_6),+ (7 , happyReduce_7),+ (8 , happyReduce_8),+ (9 , happyReduce_9),+ (10 , happyReduce_10),+ (11 , happyReduce_11),+ (12 , happyReduce_12),+ (13 , happyReduce_13),+ (14 , happyReduce_14),+ (15 , happyReduce_15),+ (16 , happyReduce_16),+ (17 , happyReduce_17),+ (18 , happyReduce_18),+ (19 , happyReduce_19),+ (20 , happyReduce_20),+ (21 , happyReduce_21),+ (22 , happyReduce_22),+ (23 , happyReduce_23),+ (24 , happyReduce_24),+ (25 , happyReduce_25)+ ]++happy_n_terms = 21 :: Int+happy_n_nonterms = 7 :: Int++happyReduce_1 = happySpecReduce_1 0# happyReduction_1+happyReduction_1 happy_x_1+ = case happyOut6 happy_x_1 of { happy_var_1 -> + happyIn4+ (happy_var_1+ )}++happyReduce_2 = happySpecReduce_1 1# happyReduction_2+happyReduction_2 happy_x_1+ = happyIn5+ (Nop+ )++happyReduce_3 = happySpecReduce_1 1# happyReduction_3+happyReduction_3 happy_x_1+ = happyIn5+ (Erase+ )++happyReduce_4 = happySpecReduce_3 1# happyReduction_4+happyReduction_4 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut6 happy_x_2 of { happy_var_2 -> + happyIn5+ (happy_var_2+ )}++happyReduce_5 = happySpecReduce_1 2# happyReduction_5+happyReduction_5 happy_x_1+ = case happyOut7 happy_x_1 of { happy_var_1 -> + happyIn6+ (happy_var_1+ )}++happyReduce_6 = happySpecReduce_1 2# happyReduction_6+happyReduction_6 happy_x_1+ = case happyOut8 happy_x_1 of { happy_var_1 -> + happyIn6+ (happy_var_1+ )}++happyReduce_7 = happySpecReduce_1 2# happyReduction_7+happyReduction_7 happy_x_1+ = case happyOut9 happy_x_1 of { happy_var_1 -> + happyIn6+ (happy_var_1+ )}++happyReduce_8 = happySpecReduce_1 2# happyReduction_8+happyReduction_8 happy_x_1+ = case happyOut10 happy_x_1 of { happy_var_1 -> + happyIn6+ (happy_var_1+ )}++happyReduce_9 = happySpecReduce_3 2# happyReduction_9+happyReduction_9 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut6 happy_x_2 of { happy_var_2 -> + happyIn6+ (happy_var_2+ )}++happyReduce_10 = happySpecReduce_1 3# happyReduction_10+happyReduction_10 happy_x_1+ = happyIn7+ (Nop+ )++happyReduce_11 = happySpecReduce_3 3# happyReduction_11+happyReduction_11 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut6 happy_x_1 of { happy_var_1 -> + case happyOut6 happy_x_3 of { happy_var_3 -> + happyIn7+ (Comp happy_var_1 happy_var_3+ )}}++happyReduce_12 = happySpecReduce_3 3# happyReduction_12+happyReduction_12 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut6 happy_x_1 of { happy_var_1 -> + case happyOut6 happy_x_3 of { happy_var_3 -> + happyIn7+ (Choice happy_var_1 happy_var_3+ )}}++happyReduce_13 = happySpecReduce_2 3# happyReduction_13+happyReduction_13 happy_x_2+ happy_x_1+ = case happyOut5 happy_x_2 of { happy_var_2 -> + happyIn7+ (Try happy_var_2+ )}++happyReduce_14 = happySpecReduce_2 3# happyReduction_14+happyReduction_14 happy_x_2+ happy_x_1+ = case happyOut5 happy_x_2 of { happy_var_2 -> + happyIn7+ (Many happy_var_2+ )}++happyReduce_15 = happySpecReduce_2 4# happyReduction_15+happyReduction_15 happy_x_2+ happy_x_1+ = case happyOut5 happy_x_2 of { happy_var_2 -> + happyIn8+ (All happy_var_2+ )}++happyReduce_16 = happySpecReduce_2 4# happyReduction_16+happyReduction_16 happy_x_2+ happy_x_1+ = case happyOut5 happy_x_2 of { happy_var_2 -> + happyIn8+ (Once happy_var_2+ )}++happyReduce_17 = happySpecReduce_2 4# happyReduction_17+happyReduction_17 happy_x_2+ happy_x_1+ = case happyOut5 happy_x_2 of { happy_var_2 -> + happyIn8+ (Everywhere happy_var_2+ )}++happyReduce_18 = happySpecReduce_2 4# happyReduction_18+happyReduction_18 happy_x_2+ happy_x_1+ = case happyOut5 happy_x_2 of { happy_var_2 -> + happyIn8+ (Outermost happy_var_2+ )}++happyReduce_19 = happySpecReduce_3 5# happyReduction_19+happyReduction_19 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOutTok happy_x_2 of { (TokString happy_var_2) -> + case happyOut5 happy_x_3 of { happy_var_3 -> + happyIn9+ (At happy_var_2 happy_var_3+ )}}++happyReduce_20 = happySpecReduce_3 5# happyReduction_20+happyReduction_20 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOutTok happy_x_2 of { (TokString happy_var_2) -> + case happyOut5 happy_x_3 of { happy_var_3 -> + happyIn9+ (When happy_var_2 happy_var_3+ )}}++happyReduce_21 = happySpecReduce_1 5# happyReduction_21+happyReduction_21 happy_x_1+ = happyIn9+ (Hoist+ )++happyReduce_22 = happySpecReduce_2 5# happyReduction_22+happyReduction_22 happy_x_2+ happy_x_1+ = case happyOutTok happy_x_2 of { (TokString happy_var_2) -> + happyIn9+ (Plunge happy_var_2+ )}++happyReduce_23 = happySpecReduce_2 5# happyReduction_23+happyReduction_23 happy_x_2+ happy_x_1+ = case happyOutTok happy_x_2 of { (TokString happy_var_2) -> + happyIn9+ (Rename happy_var_2+ )}++happyReduce_24 = happySpecReduce_1 6# happyReduction_24+happyReduction_24 happy_x_1+ = happyIn10+ (Erase+ )++happyReduce_25 = happySpecReduce_2 6# happyReduction_25+happyReduction_25 happy_x_2+ happy_x_1+ = case happyOutTok happy_x_2 of { (TokString happy_var_2) -> + happyIn10+ (case parseXPath happy_var_2 of { Nothing -> error ("error parsing xpath expression "++happy_var_2); Just xp -> Select xp }+ )}++happyNewToken action sts stk [] =+ happyDoAction 20# notHappyAtAll action sts stk []++happyNewToken action sts stk (tk:tks) =+ let cont i = happyDoAction i tk action sts stk tks in+ case tk of {+ TokNop -> cont 1#;+ TokComp -> cont 2#;+ TokChoice -> cont 3#;+ TokTry -> cont 4#;+ TokMany -> cont 5#;+ TokAll -> cont 6#;+ TokOnce -> cont 7#;+ TokEverywhere -> cont 8#;+ TokOutermost -> cont 9#;+ TokAt -> cont 10#;+ TokWhen -> cont 11#;+ TokHoist -> cont 12#;+ TokPlunge -> cont 13#;+ TokRename -> cont 14#;+ TokErase -> cont 15#;+ TokSelect -> cont 16#;+ TokString happy_dollar_dollar -> cont 17#;+ TokSym '(' -> cont 18#;+ TokSym ')' -> cont 19#;+ _ -> happyError' (tk:tks)+ }++happyError_ tk tks = happyError' (tk:tks)++newtype HappyIdentity a = HappyIdentity a+happyIdentity = HappyIdentity+happyRunIdentity (HappyIdentity a) = a++instance Monad HappyIdentity where+ return = HappyIdentity+ (HappyIdentity p) >>= q = q p++happyThen :: () => HappyIdentity a -> (a -> HappyIdentity b) -> HappyIdentity b+happyThen = (>>=)+happyReturn :: () => a -> HappyIdentity a+happyReturn = (return)+happyThen1 m k tks = (>>=) m (\a -> k a tks)+happyReturn1 :: () => a -> b -> HappyIdentity a+happyReturn1 = \a tks -> (return) a+happyError' :: () => [(Token)] -> HappyIdentity a+happyError' = HappyIdentity . happyError++parseTLTToks tks = happyRunIdentity happySomeParser where+ happySomeParser = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut4 x))++happySeq = happyDontSeq+++happyError :: [Token] -> a+happyError (x:_) = error $ "Parser Error: " ++ show x+-- ^ returns the first non-valid token++parseTLT :: String -> TLT+parseTLT str =+ case (lexTLT str) of+ (Left err) -> error $ "Lexer error: " ++ show err+ (Right toks) -> parseTLTToks toks+{-# LINE 1 "templates/GenericTemplate.hs" #-}+{-# LINE 1 "templates/GenericTemplate.hs" #-}+{-# LINE 1 "<built-in>" #-}+{-# LINE 1 "<command-line>" #-}+{-# LINE 1 "templates/GenericTemplate.hs" #-}+-- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp ++{-# LINE 30 "templates/GenericTemplate.hs" #-}+++data Happy_IntList = HappyCons Happy_GHC_Exts.Int# Happy_IntList++++++{-# LINE 51 "templates/GenericTemplate.hs" #-}++{-# LINE 61 "templates/GenericTemplate.hs" #-}++{-# LINE 70 "templates/GenericTemplate.hs" #-}++infixr 9 `HappyStk`+data HappyStk a = HappyStk a (HappyStk a)++-----------------------------------------------------------------------------+-- starting the parse++happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll++-----------------------------------------------------------------------------+-- Accepting the parse++-- If the current token is 0#, it means we've just accepted a partial+-- parse (a %partial parser). We must ignore the saved token on the top of+-- the stack in this case.+happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) =+ happyReturn1 ans+happyAccept j tk st sts (HappyStk ans _) = + (happyTcHack j (happyTcHack st)) (happyReturn1 ans)++-----------------------------------------------------------------------------+-- Arrays only: do the next action++++happyDoAction i tk st+ = {- nothing -}+++ case action of+ 0# -> {- nothing -}+ happyFail i tk st+ -1# -> {- nothing -}+ happyAccept i tk st+ n | (n Happy_GHC_Exts.<# (0# :: Happy_GHC_Exts.Int#)) -> {- nothing -}++ (happyReduceArr Happy_Data_Array.! rule) i tk st+ where rule = (Happy_GHC_Exts.I# ((Happy_GHC_Exts.negateInt# ((n Happy_GHC_Exts.+# (1# :: Happy_GHC_Exts.Int#))))))+ n -> {- nothing -}+++ happyShift new_state i tk st+ where (new_state) = (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#))+ where (off) = indexShortOffAddr happyActOffsets st+ (off_i) = (off Happy_GHC_Exts.+# i)+ check = if (off_i Happy_GHC_Exts.>=# (0# :: Happy_GHC_Exts.Int#))+ then (indexShortOffAddr happyCheck off_i Happy_GHC_Exts.==# i)+ else False+ (action)+ | check = indexShortOffAddr happyTable off_i+ | otherwise = indexShortOffAddr happyDefActions st++{-# LINE 130 "templates/GenericTemplate.hs" #-}+++indexShortOffAddr (HappyA# arr) off =+ Happy_GHC_Exts.narrow16Int# i+ where+ i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.uncheckedShiftL# high 8#) low)+ high = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr (off' Happy_GHC_Exts.+# 1#)))+ low = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr off'))+ off' = off Happy_GHC_Exts.*# 2#++++++data HappyAddr = HappyA# Happy_GHC_Exts.Addr#+++++-----------------------------------------------------------------------------+-- HappyState data type (not arrays)++{-# LINE 163 "templates/GenericTemplate.hs" #-}++-----------------------------------------------------------------------------+-- Shifting a token++happyShift new_state 0# tk st sts stk@(x `HappyStk` _) =+ let (i) = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in+-- trace "shifting the error token" $+ happyDoAction i tk new_state (HappyCons (st) (sts)) (stk)++happyShift new_state i tk st sts stk =+ happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk)++-- happyReduce is specialised for the common cases.++happySpecReduce_0 i fn 0# tk st sts stk+ = happyFail 0# tk st sts stk+happySpecReduce_0 nt fn j tk st@((action)) sts stk+ = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk)++happySpecReduce_1 i fn 0# tk st sts stk+ = happyFail 0# tk st sts stk+happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk')+ = let r = fn v1 in+ happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))++happySpecReduce_2 i fn 0# tk st sts stk+ = happyFail 0# tk st sts stk+happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk')+ = let r = fn v1 v2 in+ happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))++happySpecReduce_3 i fn 0# tk st sts stk+ = happyFail 0# tk st sts stk+happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk')+ = let r = fn v1 v2 v3 in+ happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))++happyReduce k i fn 0# tk st sts stk+ = happyFail 0# tk st sts stk+happyReduce k nt fn j tk st sts stk+ = case happyDrop (k Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) sts of+ sts1@((HappyCons (st1@(action)) (_))) ->+ let r = fn stk in -- it doesn't hurt to always seq here...+ happyDoSeq r (happyGoto nt j tk st1 sts1 r)++happyMonadReduce k nt fn 0# tk st sts stk+ = happyFail 0# tk st sts stk+happyMonadReduce k nt fn j tk st sts stk =+ happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk))+ where (sts1@((HappyCons (st1@(action)) (_)))) = happyDrop k (HappyCons (st) (sts))+ drop_stk = happyDropStk k stk++happyMonad2Reduce k nt fn 0# tk st sts stk+ = happyFail 0# tk st sts stk+happyMonad2Reduce k nt fn j tk st sts stk =+ happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk))+ where (sts1@((HappyCons (st1@(action)) (_)))) = happyDrop k (HappyCons (st) (sts))+ drop_stk = happyDropStk k stk++ (off) = indexShortOffAddr happyGotoOffsets st1+ (off_i) = (off Happy_GHC_Exts.+# nt)+ (new_state) = indexShortOffAddr happyTable off_i+++++happyDrop 0# l = l+happyDrop n (HappyCons (_) (t)) = happyDrop (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) t++happyDropStk 0# l = l+happyDropStk n (x `HappyStk` xs) = happyDropStk (n Happy_GHC_Exts.-# (1#::Happy_GHC_Exts.Int#)) xs++-----------------------------------------------------------------------------+-- Moving to a new state after a reduction+++happyGoto nt j tk st = + {- nothing -}+ happyDoAction j tk new_state+ where (off) = indexShortOffAddr happyGotoOffsets st+ (off_i) = (off Happy_GHC_Exts.+# nt)+ (new_state) = indexShortOffAddr happyTable off_i+++++-----------------------------------------------------------------------------+-- Error recovery (0# is the error token)++-- parse error if we are in recovery and we fail again+happyFail 0# tk old_st _ stk =+-- trace "failing" $ + happyError_ tk++{- We don't need state discarding for our restricted implementation of+ "error". In fact, it can cause some bogus parses, so I've disabled it+ for now --SDM++-- discard a state+happyFail 0# tk old_st (HappyCons ((action)) (sts)) + (saved_tok `HappyStk` _ `HappyStk` stk) =+-- trace ("discarding state, depth " ++ show (length stk)) $+ happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk))+-}++-- Enter error recovery: generate an error token,+-- save the old token and carry on.+happyFail i tk (action) sts stk =+-- trace "entering error recovery" $+ happyDoAction 0# tk action sts ( (Happy_GHC_Exts.unsafeCoerce# (Happy_GHC_Exts.I# (i))) `HappyStk` stk)++-- Internal happy errors:++notHappyAtAll :: a+notHappyAtAll = error "Internal Happy error\n"++-----------------------------------------------------------------------------+-- Hack to get the typechecker to accept our action functions+++happyTcHack :: Happy_GHC_Exts.Int# -> a -> a+happyTcHack x y = y+{-# INLINE happyTcHack #-}+++-----------------------------------------------------------------------------+-- Seq-ing. If the --strict flag is given, then Happy emits +-- happySeq = happyDoSeq+-- otherwise it emits+-- happySeq = happyDontSeq++happyDoSeq, happyDontSeq :: a -> b -> b+happyDoSeq a b = a `seq` b+happyDontSeq a b = b++-----------------------------------------------------------------------------+-- Don't inline any functions from the template. GHC has a nasty habit+-- of deciding to inline happyGoto everywhere, which increases the size of+-- the generated parser quite a bit.+++{-# NOINLINE happyDoAction #-}+{-# NOINLINE happyTable #-}+{-# NOINLINE happyCheck #-}+{-# NOINLINE happyActOffsets #-}+{-# NOINLINE happyGotoOffsets #-}+{-# NOINLINE happyDefActions #-}++{-# NOINLINE happyShift #-}+{-# NOINLINE happySpecReduce_0 #-}+{-# NOINLINE happySpecReduce_1 #-}+{-# NOINLINE happySpecReduce_2 #-}+{-# NOINLINE happySpecReduce_3 #-}+{-# NOINLINE happyReduce #-}+{-# NOINLINE happyMonadReduce #-}+{-# NOINLINE happyGoto #-}+{-# NOINLINE happyFail #-}++-- end of Happy Template.
+ examples/company.2lt view
@@ -0,0 +1,5 @@+everywhere (try (at "manager" (select "//name[1]" >> rename "managername") ))+>> everywhere (try (at "employee" erase))+>> once (at "dept" (+ hoist >> outermost (at "dept" (select "name" >> rename "branch")) >> plunge "dept"+))
+ examples/company.xml view
@@ -0,0 +1,41 @@+<?xml version="1.0" encoding="UTF-8"?> +<company xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" xsi:noNamespaceSchemaLocation="company.xsd"> + <dept> + <name>Research</name> + <manager> + <employee> + <person> + <name>Ralf</name> + <address>Amesterdam</address> + </person> + <salary>8000</salary> + </employee> + </manager> + <employee> + <person> + <name>Joost</name> + <address>Amesterdam</address> + </person> + <salary>1000</salary> + </employee> + <employee> + <person> + <name>Marlow</name> + <address>Cambridge</address> + </person> + <salary>2000</salary> + </employee> + <dept> + <name>Strategy</name> + <manager> + <employee> + <person> + <name>Blair</name> + <address>London</address> + </person> + <salary>10000</salary> + </employee> + </manager> + </dept> + </dept> +</company>
+ examples/company.xsd view
@@ -0,0 +1,44 @@+<?xml version="1.0" encoding="UTF-8"?> +<xsd:schema xmlns:xsd="http://www.w3.org/2001/XMLSchema"> + <xsd:element name="company"> + <xsd:complexType> + <xsd:sequence> + <xsd:element name="dept" type="Dept"/> + </xsd:sequence> + </xsd:complexType> + </xsd:element> + <xsd:group name="depts"> + <xsd:sequence> + <xsd:element name="dept" minOccurs="0" maxOccurs="unbounded"/> + </xsd:sequence> + </xsd:group> + <xsd:complexType name="Dept"> + <xsd:sequence> + <xsd:element name="name" type="xsd:string"/> + <xsd:element name="manager"> + <xsd:complexType> + <xsd:sequence> + <xsd:element name="employee" type="Employee"/> + </xsd:sequence> + </xsd:complexType> + </xsd:element> + <xsd:choice minOccurs="0" maxOccurs="unbounded"> + <xsd:element name="employee" type="Employee"/> + <xsd:element name="dept" type="Dept"/> + </xsd:choice> + </xsd:sequence> + </xsd:complexType> + <xsd:complexType name="Employee"> + <xsd:sequence> + <xsd:element name="person"> + <xsd:complexType> + <xsd:sequence> + <xsd:element name="name" type="xsd:string"/> + <xsd:element name="address" type="xsd:string"/> + </xsd:sequence> + </xsd:complexType> + </xsd:element> + <xsd:element name="salary" type="xsd:integer"/> + </xsd:sequence> + </xsd:complexType> +</xsd:schema>
+ examples/imdb.2lt view
@@ -0,0 +1,8 @@+everywhere (try (at "series" erase))+>> everywhere (try (at "movie" (+ outermost (when "reviews" (select "count(//@comment)" >> plunge "@popularity"))+ >> outermost (when "boxoffices" (select "sum(//@value)" >> plunge "@profit"))+)))+>> everywhere (try (at "actor" (+ outermost (at "played" (select "award/@name" >> all (rename "awname")))+)))
+ examples/imdb.xml view
@@ -0,0 +1,33 @@+<?xml version="1.0" encoding="UTF-8"?>+<imdb xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" xsi:noNamespaceSchemaLocation="imdb.xsd">+ <movie>+ <year>1994</year>+ <title>Pulp Fiction</title>+ <review user="mike" comment="The masterpiece without a message"/>+ <director>Quentin Tarantino</director>+ <boxoffice country="UK" value="4243333"/>+ <boxoffice country="Germany" value="1147984"/>+ </movie>+ <movie>+ <year>2003</year>+ <title>Kill Bill: Vol. 1</title>+ <review user="emma" comment="Gorgeous!"/>+ <director>Quentin Tarantino</director>+ <boxoffice country="USA" value="22089322"/>+ <boxoffice country="Japan" value="3521628"/>+ </movie>+ <movie>+ <year>2004</year>+ <title>The Punisher</title>+ <director>Jonathan Hensleigh</director>+ </movie>+ <actor>+ <name>Uma Thurman</name>+ <played>+ <year>2003</year>+ <title>Kill Bill: Vol. 1</title>+ <role>The Bride</role>+ <award name="Saturn Award - Best Actress" result="Won"/>+ </played>+ </actor>+</imdb>
+ examples/imdb.xsd view
@@ -0,0 +1,76 @@+<?xml version="1.0" encoding="UTF-8"?>+<xsd:schema xmlns:xsd="http://www.w3.org/2001/XMLSchema">+ <xsd:element name="imdb" type="IMDB"/>+ <xsd:complexType name="Movie">+ <xsd:sequence>+ <xsd:element name="year" type="xsd:integer"/>+ <xsd:element name="title" type="xsd:string"/>+ <xsd:group ref="reviews"/>+ <xsd:element name="director" type="xsd:string"/>+ <xsd:group ref="boxoffices"/>+ </xsd:sequence>+ </xsd:complexType>+ <xsd:group name="reviews">+ <xsd:sequence>+ <xsd:element name="review" minOccurs="0" maxOccurs="unbounded">+ <xsd:complexType>+ <xsd:attribute name="user" type="xsd:string" use="required"/>+ <xsd:attribute name="comment" type="xsd:string" use="required"/>+ </xsd:complexType>+ </xsd:element>+ </xsd:sequence>+ </xsd:group>+ <xsd:group name="boxoffices">+ <xsd:sequence>+ <xsd:element name="boxoffice" minOccurs="0" maxOccurs="unbounded">+ <xsd:complexType>+ <xsd:attribute name="country" type="xsd:string" use="required"/>+ <xsd:attribute name="value" type="xsd:nonNegativeInteger" use="optional"/>+ </xsd:complexType>+ </xsd:element>+ </xsd:sequence>+ </xsd:group>+ <xsd:complexType name="Series">+ <xsd:sequence>+ <xsd:element name="year" type="xsd:integer"/>+ <xsd:element name="title" type="xsd:string"/>+ <xsd:group ref="reviews"/>+ <xsd:element name="season" minOccurs="0" maxOccurs="unbounded">+ <xsd:complexType>+ <xsd:sequence>+ <xsd:element name="year" type="xsd:integer"/>+ <xsd:element name="episode" type="xsd:integer" minOccurs="0" maxOccurs="unbounded"/>+ </xsd:sequence>+ </xsd:complexType>+ </xsd:element>+ </xsd:sequence>+ </xsd:complexType>+ <xsd:complexType name="Actor">+ <xsd:sequence>+ <xsd:element name="name" type="xsd:string"/>+ <xsd:element name="played" type="Played" minOccurs="0" maxOccurs="unbounded"/>+ </xsd:sequence>+ </xsd:complexType>+ <xsd:complexType name="IMDB">+ <xsd:sequence>+ <xsd:choice minOccurs="0" maxOccurs="unbounded">+ <xsd:element name="movie" type="Movie"/>+ <xsd:element name="series" type="Series"/>+ </xsd:choice>+ <xsd:element name="actor" type="Actor" minOccurs="0" maxOccurs="unbounded"/>+ </xsd:sequence>+ </xsd:complexType>+ <xsd:complexType name="Played">+ <xsd:sequence>+ <xsd:element name="year" type="xsd:integer"/>+ <xsd:element name="title" type="xsd:string"/>+ <xsd:element name="role" type="xsd:string"/>+ <xsd:element name="award" minOccurs="0" maxOccurs="unbounded">+ <xsd:complexType>+ <xsd:attribute name="name" type="xsd:string" use="required"/>+ <xsd:attribute name="result" type="xsd:string" use="required"/>+ </xsd:complexType>+ </xsd:element>+ </xsd:sequence>+ </xsd:complexType>+</xsd:schema>
+ examples/imdb2mod.xml view
@@ -0,0 +1,37 @@+<?xml version='1.0' encoding='utf-8' ?>+<imdb xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance"+ xsi:noNamespaceSchemaLocation="examples/imdb2.xsd"+ ><movie popularity="1" profit="5391317"+ ><year+ >1994</year+ ><title+ >Pulp Fiction</title+ ><director+ >Quentin Tarantino</director></movie+ ><movie popularity="1" profit="25610950"+ ><year+ >2003</year+ ><title+ >Kill Bill: Vol. 1</title+ ><director+ >Quentin Tarantino</director></movie+ ><movie popularity="0" profit="0"+ ><year+ >2004</year+ ><title+ >The Punisher</title+ ><director+ >Jonathan Hensleigh</director></movie+ >+ <movie popularity="2" profit="15"+ ><year+ >2012</year+ ><title+ >Sherlock Holmes: Game of Shadows</title+ ><director+ >Guy Ritchie</director></movie+ ><actor+ ><name+ >Uma Thurman</name+ ><awname+ >Saturn Award - Best Actress</awname></actor></imdb>
+ multifocal.cabal view
@@ -0,0 +1,49 @@+Name: multifocal+Version: 0.0.1+License: BSD3+License-file: LICENSE+Author: Hugo Pacheco <hpacheco@di.uminho.pt>, Alcino Cunha <alcino@di.uminho.pt>+Maintainer: Hugo Pacheco <hpacheco@di.uminho.pt>+Synopsis: Bidirectional Two-level Transformation of XML Schemas+Description: Library that implements a two-level transformation (<http://dx.doi.org/10.1007/978-3-540-69611-7_19>) for creating bidirectional views of XML Schemas based on bidirectional lenses. It supports the specialization of generic queries as two-level transformation steps and the optimization of the generated lens data transformations.+ +Homepage: ++Category: Generics++extra-source-files: README, src/Language/TLT/TltLexer.x, src/Language/TLT/TltParser.y+ , examples/company.xsd, examples/company.xml, examples/imdb.xsd, examples/imdb.xml, examples/imdb2mod.xml+ , examples/company.2lt, examples/imdb.2lt++Build-type: Simple+Cabal-Version: >= 1.4++Library+ hs-source-dirs: src+ Build-Depends: mtl >= 1, base >= 4 && < 5, pointless-haskell >= 0.0.8, pointless-lenses >= 0.0.9, pointless-rewrite >= 0.0.3, process, containers, haskell-src-exts >= 1.11.1, syb >= 0.3, hxt >= 9.1.5, hxt-xpath >= 9.1.1, parsec >= 3.1.2, array, pretty >= 1.1.0.0, HaXml >= 1.22.5++ exposed-modules:+ Data.Transform.TwoLevel+ Language.TLT.Tlt2Strat+ Language.TLT.TltLexer+ Language.TLT.TltParser+ Language.TLT.TltSyntax+ Language.XML.HaXmlAliases+ Language.XML.Type2Xml+ Language.XML.Type2Xsd+ Language.XML.Xml2Type+ Language.XML.Xsd2Type+ Language.XPath.HXTAliases+ Language.XPath.XPath2Pf+ UI.GenHaskell+ UI.Menu+ UI.LensMenu+ extensions: DeriveDataTypeable, TypeOperators, ImpredicativeTypes, FlexibleContexts, RankNTypes, ViewPatterns, ScopedTypeVariables, GADTs, TypeFamilies, ViewPatterns, DoAndIfThenElse+ +Executable multifocal+ hs-source-dirs: src+ Main-is: UI/CmdLine.hs++ Build-Depends: mtl >= 1, base >= 4 && < 5, pointless-haskell >= 0.0.6, pointless-lenses >= 0.0.8, pointless-rewrite >= 0.0.3, process, containers, haskell-src-exts >= 1.11.1, syb >= 0.3, hxt >= 9.1.5, hxt-xpath >= 9.1.1, parsec >= 3.1.2, array, pretty >= 1.1.0.0, HaXml >= 1.22.5++ extensions: DeriveDataTypeable, TypeOperators, ImpredicativeTypes, FlexibleContexts, RankNTypes, ViewPatterns, ScopedTypeVariables, GADTs, TypeFamilies, ViewPatterns, DoAndIfThenElse
+ src/Data/Transform/TwoLevel.hs view
@@ -0,0 +1,478 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.Transform.TwoLevel+-- Copyright : (c) 2011 University of Minho+-- License : BSD3+--+-- Maintainer : hpacheco@di.uminho.pt+-- Stability : experimental+-- Portability : non-portable+--+-- Multifocal:+-- Bidirectional Two-level Transformation of XML Schemas+-- +-- Combinators for Two-Level Data Transformation.+--+-----------------------------------------------------------------------------++module Data.Transform.TwoLevel where++import Data.Type+import Data.Pf+import Data.Equal+import Data.Eval+import Data.Spine+import Data.Lens+import Data.Default+import Generics.Pointless.Lenses+import Generics.Pointless.Combinators+import Generics.Pointless.Functors hiding (rep)+import Transform.Examples.Company+import Transform.Rewriting (reducePf,reduceIO)+import Transform.Rules.XPath+import Transform.Rules.PF+import Transform.Rules.Lenses++import Prelude hiding (all,Functor,until)+import Control.Monad.State as ST hiding (Functor,lift,when)+import Data.List hiding (all)+import Data.Char+import Data.Map as Map hiding (map)+import Data.Maybe++import Unsafe.Coerce++-- * Utils++maybeRead :: Read a => String -> Maybe a+maybeRead = maybe Nothing (Just . fst) . listToMaybe . reads++safeTail :: [a] -> [a]+safeTail [] = []+safeTail (x:xs) = xs++-- * Data rewriting monad: with a log of applied rules and an index of type names++type NewDatas = Map String DynFctr+type Log = [(String,String)]+type RuleTMonad m a = StateT (Log,NewDatas) m a++type RuleT = forall a . Type a -> RuleTMonad Maybe (View a)+newtype RuleTRep = RuleTRep RuleT++nextName :: String -> String+nextName (span (/= '\'') -> (prefix,suffix)) = case (maybeRead (safeTail suffix) :: Maybe Int) of+ { Just i -> prefix ++ "'" ++ show (succ i)+ ; otherwise -> prefix ++ suffix ++ "'1" }++newData :: Functor f => String -> Fctr f -> RuleTMonad Maybe (Type (Fix f))+newData name fctr = do+ (log,datas) <- ST.get+ case (Map.lookup name datas) of+ { Just (DynF g) -> case feq fctr g of+ { Just Eq -> return (NewData name fctr)+ ; otherwise -> newData (nextName name) fctr }+ ; otherwise -> do+ ST.put (log,Map.insert name (DynF fctr) datas)+ return (NewData name fctr) }++data View a where+ View :: Pf (Lens a b) -> Type b -> View a+ +data ViewFunc a where+ ViewFunc :: Pf (a -> b) -> Type b -> ViewFunc a++instance Show (View a) where+ show (View _ b) = "(View Lens " ++ (show b) ++ ")"++transformtype :: Type a -> RuleT -> DynType+transformtype a r = maybe (DynT a) id $ do+ (View lns b,m) <- transform a r+ return $ DynT b++transformSafe :: Type a -> RuleT -> (View a,Map String DynFctr)+transformSafe a r = maybe (View ID_LNS a,Map.empty) (id >< snd) $ runStateT (r a) ([],collectNewDatas a)++transform :: Type a -> RuleT -> Maybe (View a,Map String DynFctr)+transform a r = maybe Nothing (Just . (id >< snd)) $ runStateT (r a) ([],collectNewDatas a)++-- Print the string representation of the target type encapsulated in a view.+showType :: View a -> String+showType (View _ b) = show b++showPf :: Type a -> View a -> String+showPf a (View f b) = gshow (Pf $ Lns a b) f++showOptimisedPf :: Type a -> View a -> String+showOptimisedPf a (View lns b) = gshow (Pf $ Lns a b) lns'+ where lns' = reducePf optimise_all_lns (Lns a b) lns+ +showOptimisedPfIO :: Type a -> View a -> IO ()+showOptimisedPfIO a (View lns b) = reduceIO optimise_all_lns (Lns a b) lns >> return ()++showLog :: Type a -> Log -> String +showLog t l = show t ++ unlines (Prelude.map aux $ reverse l)+ where aux (n,s) = "\n<= {" ++ n ++ "}\n " ++ s++-- Apply a traceable data transformation rule.+success :: String -> View a -> RuleTMonad Maybe (View a)+success n v = do+ (x,datas) <- ST.get+ ST.put $ ((n,showType v) : x,datas)+ return v+ +-- ** Two-level generic combinators++-- Sequential composition+(>>>) :: RuleT -> RuleT -> RuleT+(r >>> s) a = do (View f b) <- r a+ (View g c) <- s b+ return $ (View (COMP_LNS b g f) c)++-- Left-biased choice+(|||) :: RuleT -> RuleT -> RuleT+(r ||| s) x = r x `mplus` s x++-- Identity+nop :: RuleT+nop x = return $ (View ID_LNS x)++-- Apply a rule or do nothing.+try :: RuleT -> RuleT+try r = r ||| nop++-- Repeat until failure, zero or more times.+many :: RuleT -> RuleT+many r = try (r >>> many r)++-- ** Two-level locators++type TPredicate = forall a . Type a -> Bool++listP :: TPredicate -> TPredicate+listP p (List a) = p a+listP p _ = False++atP :: String -> TPredicate+atP name a@(dataName -> Just n) = sameName name n+atP name _ = False++andP :: TPredicate -> TPredicate -> TPredicate+andP f g a = f a && g a++orP :: TPredicate -> TPredicate -> TPredicate+orP f g a = f a || g a++prodP :: [TPredicate] -> TPredicate+prodP [p] a = p a+prodP (p:ps) (Prod a b) = p a && prodP ps b+prodP _ _ = False++sumP :: [TPredicate] -> TPredicate+sumP [p] a = p a+sumP (p:ps) (Either a b) = p a && sumP ps b+sumP _ _ = False++notP :: TPredicate -> TPredicate+notP p a = Prelude.not (p a)++-- Apply a rule whenever a type-level predicate is satisfied.+when :: TPredicate -> RuleT -> RuleT+when q r a = guard (q a) >> r a++-- Apply a rule to a data type with a given name.+at :: String -> RuleT -> RuleT+at name r = when (atP name) r++not :: RuleT -> RuleT -> RuleT+not r s a = case transform a r of+ { Just v -> mzero+ ; otherwise -> s a+ }++hoist :: RuleT+hoist a@(Data _ fctr) = return $ View OUT_LNS (rep fctr a)+hoist a@(NewData _ fctr) = return $ View OUT_LNS (rep fctr a)+hoist _ = mzero++plunge :: String -> RuleT+plunge s a = do+ FRep f <- inferKFctr a+ new <- newData s f+ Eq <- teq (rep f Dynamic) (rep f new)+ return $ View INN_LNS new++rename :: String -> RuleT+rename s a@(Data _ fctr) = do+ new <- newData s fctr+ return $ View (CATA_LNS INN_LNS) new+rename s a@(NewData _ fctr) = do+ new <- newData s fctr+ return $ View (CATA_LNS INN_LNS) new+rename s a = mzero++-- ** Two-level abstractions++erase :: RuleT+erase a = success "erase" $ View (BANG_LNS (constPf $ defvalue a)) One++-- The argument types may involve patterns, i.e., type variables+liftPf :: Type a -> Type b -> Pf (a -> b) -> RuleT+liftPf patt app func a = do+ (Eq,vars) <- teqvars patt a+ b <- replacevar app vars+ lns <- lensify (Fun a b) func+ success "liftPf" $ View lns b ++lift :: Type a -> Type b -> Pf (Lens a b) -> RuleT+lift patt app lns a = do+ (Eq,vars) <- teqvars patt a+ b <- replacevar app vars+ success "lift" $ View lns b++liftQ :: Typeable r => Pf (Q r) -> RuleT+liftQ (q :: Pf (Q r)) a = do+ let r = typeof :: Type r+ q' = reducePf optimise_xpath (Fun a r) (APPLYQ a q)+ liftQ' a r q'+ +liftQ' :: Type a -> Type r -> Pf (a -> r) -> RuleTMonad Maybe (View a)+liftQ' a r@(teq (List Dynamic) -> Just Eq) q = do+ ViewFunc l b <- eraseDyns a q+ liftPf a b l a+liftQ' a r@(teq Dynamic -> Just Eq) q = do+ ViewFunc l b <- eraseDyn a q+ liftPf a b l a+liftQ' a r q = liftPf a r q a++-- tries to eliminate dynamic values from an xpath query+eraseDyns :: MonadPlus m => Type a -> Pf (a -> [Dynamic]) -> m (ViewFunc a)+eraseDyns a pf = do+ DynT b <- collectDyn (Pf (Fun a (List Dynamic))) pf+ let pf' = reducePf optimise_pf (Fun a (List b)) (COMP (List Dynamic) (MAP $ UNDYN b) pf)+ -- unwrap singleton lists+ case pf' of+ (COMP b WRAP f) -> return $ ViewFunc f b+ otherwise -> return $ ViewFunc pf' (List b)+-- tries to eliminate dynamic values from an xpath query returning a single value+eraseDyn :: MonadPlus m => Type a -> Pf (a -> Dynamic) -> m (ViewFunc a)+eraseDyn a pf = do+ DynT b <- collectDyn (Pf (Fun a Dynamic)) pf+ let pf' = reducePf optimise_pf (Fun a b) (COMP Dynamic (UNDYN b) pf)+ return $ ViewFunc pf' b++-- ** Two-level strategies++onceNorm :: RuleT -> RuleT+onceNorm r = once r >>> normalize++-- Apply a rule exhaustively many times starting from the top.+outermost :: RuleT -> RuleT+outermost r = many (onceNorm r)++allNorm :: RuleT -> RuleT+allNorm r = all r >>> normalize++-- Apply argument rule everywhere, in a bottom-up approach+everywhere :: RuleT -> RuleT+everywhere r = allNorm (everywhere r) >>> r++-- Apply argument rule where possible, in a bottom-up approach+anywhere :: RuleT -> RuleT+anywhere r = everywhere (try r)++-- Apply argument rule everywhere, in a top-down approach+everywhere' :: RuleT -> RuleT+everywhere' r = r >>> allNorm (everywhere' r)++type RuleF = forall f. Functor f => Fctr f -> RuleTMonad Maybe (ViewF f)++type NatPfLens f g = forall a. Type a -> Pf (Lens (Rep f a) (Rep g a))++data ViewF f where+ ViewF :: (Functor f,Functor g) => NatPfLens f g -> Fctr g -> ViewF f++-- Apply a rule to all childs.+all :: RuleT -> RuleT+all r (List a) = do+ View f b <- r a+ return $ View (MAP_LNS f) (List b)+all r (Prod a b) = do+ View f c <- r a+ View g d <- r b+ return $ View (PROD_LNS f g) (Prod c d)+all r (Either a b) = do+ View f c <- r a+ View g d <- r b+ return $ View (SUM_LNS f g) (Either c d)+all r t@(Data s f) = (do+ ViewF l g <- allF r f+ Eq <- feq f g+ let cata = CATA_LNS $ COMP_LNS (rep g t) INN_LNS (l t)+ return $ View cata t)+ `mplus` (do+ (ViewF l g) <- allF r f+ new <- newData s g+ let cata = CATA_LNS $ COMP_LNS (rep g new) INN_LNS (l new)+ return $ View cata new)+all r t@(NewData s f) = do+ (ViewF l g) <- allF r f+ new <- newData s g+ let cata = CATA_LNS $ COMP_LNS (rep g new) INN_LNS (l new)+ return $ View cata new+all r a = return $ View ID_LNS a++allF :: RuleT -> RuleF+allF r I = return $ ViewF (\a -> ID_LNS) I+allF r L = return $ ViewF (\a -> ID_LNS) L+allF r (K t) = do+ View l t' <- r t+ return $ ViewF (\a -> l) (K t')+allF r (f :*!: g) = do+ ViewF lf f' <- allF r f+ ViewF lg g' <- allF r g+ return $ ViewF (\a -> PROD_LNS (lf a) (lg a)) (f' :*!: g')+allF r (f :+!: g) = do+ ViewF lf f' <- allF r f+ ViewF lg g' <- allF r g+ return $ ViewF (\a -> SUM_LNS (lf a) (lg a)) (f' :+!: g')+allF r (f :@!: g) = do+ ViewF lf f' <- allF r f+ ViewF lg g' <- allF r g+ return $ ViewF (\a -> COMP_LNS (rep (f :@!: g') a) (lf (rep g' a)) (FMAP_LNS f (Fun (rep g a) (rep g' a)) (lg a))) (f' :@!: g')++once :: RuleT -> RuleT+once r (Id a) = mzero+once r (List a) = r (List a) `mplus` (do+ (View f b) <- once r a+ return $ View (MAP_LNS f) (List b))+once r (Prod a b) = r (Prod a b) `mplus` (do+ View f c <- once r a+ return $ View (PROD_LNS f ID_LNS) (Prod c b))+ `mplus` (do+ View g d <- once r b+ return $ View (PROD_LNS ID_LNS g) (Prod a d))+once r (Either a b) = r (Either a b) `mplus` (do+ View f c <- once r a+ return $ View (SUM_LNS f ID_LNS) (Either c b))+ `mplus` (do+ View g d <- once r b+ return $ View (SUM_LNS ID_LNS g) (Either a d))+once r a@(Data s f) = r a `mplus` (do+ ViewF l g <- onceF r f+ Eq <- feq f g+ let anal = (ANA_LNS $ COMP_LNS (rep f a) (l a) OUT_LNS)+ return $ View anal a)+ `mplus` (do+ ViewF l g <- onceF r f+ new <- newData s g+ let anal = ANA_LNS $ COMP_LNS (rep f a) (l a) OUT_LNS+ return $ View anal new)+once r a@(NewData s f) = r a `mplus` (do+ ViewF l g <- onceF r f+ new <- newData s g+ let anal = ANA_LNS $ COMP_LNS (rep f a) (l a) OUT_LNS+ return $ View anal new)+once r a = r a++onceF :: RuleT -> RuleF +onceF r f = do+ View l ga <- onceF' r f (Id Any)+ FRep g <- inferFctr (Id Any) ga+ return $ ViewF (\b -> unsafeCoerce l) g++onceF' :: RuleT -> Fctr f -> Type a -> RuleTMonad Maybe (View (Rep f a))+onceF' r I a = mzero+onceF' r L a = r (List a)+onceF' r (K t) a = r t `mplus` (do+ View l t' <- once r t+ return $ View l t')+onceF' r (f :*!: g) a = r (rep (f:*!:g) a) `mplus` (do+ View lf b <- onceF' r f a+ return $ View (PROD_LNS lf ID_LNS) $ Prod b (rep g a))+ `mplus` (do+ View lg b <- onceF' r g a+ return $ View (PROD_LNS ID_LNS lg) $ Prod (rep f a) b)+onceF' r (f :+!: g) a = r (rep (f:+!:g) a) `mplus` (do+ View lf b <- onceF' r f a+ return $ View (SUM_LNS lf ID_LNS) $ Either b (rep g a))+ `mplus` (do+ View lg b <- onceF' r g a+ return $ View (SUM_LNS ID_LNS lg) $ Either (rep f a) b)+onceF' r (f :@!: g) a = r (rep (f:@!:g) a) `mplus` (do+ View lf b <- onceF' r f (rep g a)+ return $ View lf b)+ `mplus` (do+ View lg b <- onceF' r g a+ return $ View (FMAP_LNS f (Fun (rep g a) b) lg) $ rep f b)++-- ** Normalized type equality++normalizetype :: RuleT+normalizetype = many (once normalizetyperules)++normalizetyperules :: RuleT+normalizetyperules = prodAssoc ||| sumAssoc++normalizedteq :: Type a -> Type b -> Bool+normalizedteq a b = let dyna = transformtype a normalizetype+ dynb = transformtype b normalizetype+ in applyDynT2 (\a b -> teqBool (replacedyn a) b) dyna dynb+ +-- ** Normalization++normalize :: RuleT+normalize = many (once normalizerules)++normalizerules :: RuleT+normalizerules = prodAssoc ||| prodOne ||| listOne ||| filterOne+ ||| sumAssoc ||| eitherSame ||| listList++prodOne :: RuleT+prodOne (Prod a One) = return $ View (FST_LNS BANG) a+prodOne (Prod One a) = return $ View (SND_LNS BANG) a+prodOne _ = mzero++listOne :: RuleT+listOne (Either (List a) One) = do+ l <- lensify (Fun (Either (List a) One) (List a)) (ID `EITHER` ZERO)+ return $ View l (List a)+listOne (Either One (List a)) = do+ l <- lensify (Fun (Either One (List a)) (List a)) (ZERO `EITHER` ID)+ return $ View l (List a)+listOne _ = mzero++filterOne :: RuleT+filterOne (List (Either a One)) = return $ View FILTER_LEFT_LNS (List a)+filterOne (List (Either One a)) = return $ View FILTER_RIGHT_LNS (List a)+filterOne (List a@(Data _ _)) = filterOne' (List a)+filterOne (List a@(NewData _ _)) = filterOne' (List a)+filterOne _ = mzero++filterOne' :: (Mu a,Functor (PF a)) => Type [a] -> RuleTMonad Maybe (View [a])+filterOne' (List a@(dataNameFctr -> Just (n,f :+!: K One))) = do+ guard $ Prelude.not $ isRec f+ new <- newData n f+ Eq <- teq (rep f a) (rep f new)+ let l = COMP_LNS (List $ rep f a) (MAP_LNS INN_LNS) $ COMP_LNS (List $ rep (f :+!: K One) a) FILTER_LEFT_LNS (MAP_LNS OUT_LNS)+ return $ View l $ List new+filterOne' _ = mzero++eitherSame :: RuleT+eitherSame (Either a a') = do+ Eq <- teq a a'+ return $ View (ID_LNS .\/<< ID_LNS) a+eitherSame _ = mzero++listList :: RuleT+listList (List (List a)) = return $ View CONCAT_LNS (List a)+listList _ = mzero++prodAssoc :: RuleT+prodAssoc (Prod (Prod a b) c) = return $ View ASSOCR_LNS (Prod a (Prod b c))+prodAssoc _ = mzero++sumAssoc :: RuleT+sumAssoc (Either (Either a b) c) = return $ View COASSOCR_LNS (Either a (Either b c))+sumAssoc _ = mzero+
+ src/Language/TLT/Tlt2Strat.hs view
@@ -0,0 +1,76 @@+-----------------------------------------------------------------------------+-- |+-- Module : Language.TLT.Tlt2Strat+-- Copyright : (c) 2011 University of Minho+-- License : BSD3+--+-- Maintainer : hpacheco@di.uminho.pt+-- Stability : experimental+-- Portability : non-portable+--+-- Multifocal:+-- Bidirectional Two-level Transformation of XML Schemas+-- +-- Conversion from the two-level language into strategic combinators+--+-----------------------------------------------------------------------------++module Language.TLT.Tlt2Strat where++import Data.Type+import Data.Equal+import Data.Spine++import Data.Transform.TwoLevel+import Language.TLT.TltSyntax+import Language.XML.Xsd2Type+import Language.XPath.XPath2Pf++import Control.Monad.State as ST hiding (when)+import Data.Map as Map+import Data.List as List++tlt2strat :: MonadPlus m => TLT -> StateT TopMap m RuleTRep+tlt2strat Nop = return $ RuleTRep nop+tlt2strat (Comp r1 r2) = do+ RuleTRep x <- tlt2strat r1+ RuleTRep y <- tlt2strat r2+ return $ RuleTRep (x >>> y)+tlt2strat (Choice r1 r2) = do+ RuleTRep x <- tlt2strat r1+ RuleTRep y <- tlt2strat r2+ return $ RuleTRep (x ||| y)+tlt2strat (Try r) = do+ RuleTRep x <- tlt2strat r+ return $ RuleTRep (try x)+tlt2strat (Many r) = do+ RuleTRep x <- tlt2strat r+ return $ RuleTRep (many x) +tlt2strat (All r) = do+ RuleTRep x <- tlt2strat r+ return $ RuleTRep (allNorm x)+tlt2strat (Once r) = do+ RuleTRep x <- tlt2strat r+ return $ RuleTRep (onceNorm x)+tlt2strat (Everywhere r) = do+ RuleTRep x <- tlt2strat r+ return $ RuleTRep (everywhere x)+tlt2strat (Outermost r) = do+ RuleTRep x <- tlt2strat r+ return $ RuleTRep (outermost x)+tlt2strat (At name r) = do+ RuleTRep x <- tlt2strat r+ return $ RuleTRep (at name x)+tlt2strat (When name r) = do+ RuleTRep x <- tlt2strat r+ types <- ST.get+ case Map.lookup name types of+ Just (DynT t) -> return $ RuleTRep $ when (normalizedteq t) x+ otherwise -> error $ "element tag " ++ name ++ " undefined in input XML Schema"+tlt2strat (Hoist) = return $ RuleTRep hoist+tlt2strat (Plunge name) = return $ RuleTRep $ plunge name+tlt2strat (Rename name) = return $ RuleTRep $ rename name+tlt2strat Erase = return $ RuleTRep erase+tlt2strat (Select xpath) = do+ pf <- xpath2pf xpath+ return $ RuleTRep (liftQ pf)
+ src/Language/TLT/TltLexer.x view
@@ -0,0 +1,86 @@+{+-----------------------------------------------------------------------------+-- |+-- Module : Language.TLT.TltLexer+-- Copyright : (c) 2011 University of Minho+-- License : BSD3+--+-- Maintainer : hpacheco@di.uminho.pt+-- Stability : experimental+-- Portability : non-portable+--+-- Multifocal:+-- Bidirectional Two-level Transformation of XML Schemas+-- +-- Lexer for the two-level language.+--+-----------------------------------------------------------------------------++module Language.TLT.TltLexer where++import Text.ParserCombinators.Parsec (SourcePos)+}++%wrapper "monad"++$digit = 0-9 -- digits+$alpha = [a-zA-Z] -- alphabetic characters++tokens :-++$white+ ;+\"[^\"]*\" { makeAlexAction (\s -> TokString $ tail $ init s) }+\( { makeAlexAction (\s -> TokSym '(') }+\) { makeAlexAction (\s -> TokSym ')') }+"nop" { makeAlexAction (\s -> TokNop) }+">>" { makeAlexAction (\s -> TokComp) }+"||" { makeAlexAction (\s -> TokChoice) }+"try" { makeAlexAction (\s -> TokTry) }+"many" { makeAlexAction (\s -> TokMany) }+"all" { makeAlexAction (\s -> TokAll) }+"once" { makeAlexAction (\s -> TokOnce) }+"everywhere" { makeAlexAction (\s -> TokEverywhere) }+"outermost" { makeAlexAction (\s -> TokOutermost) }+"at" { makeAlexAction (\s -> TokAt) }+"when" { makeAlexAction (\s -> TokWhen) }+"hoist" { makeAlexAction (\s -> TokHoist) }+"plunge" { makeAlexAction (\s -> TokPlunge) }+"rename" { makeAlexAction (\s -> TokRename) }+"erase" { makeAlexAction (\s -> TokErase) }+"select" { makeAlexAction (\s -> TokSelect) }++{++makeAlexAction ::Monad m => (String -> Token) -> AlexInput -> Int -> m Token+makeAlexAction cons = \ (_,_,inp) len ->return $cons (take len inp)++-- | Just to make alexMonadScan work, although we do not use it+alexEOF = return undefined++data Token = TokNop | TokComp | TokChoice | TokTry | TokMany+ | TokAll | TokOnce | TokEverywhere | TokOutermost+ | TokAt | TokWhen | TokHoist | TokPlunge | TokRename+ | TokErase | TokSelect+ | TokString String | TokSym Char+ deriving Show++alexMonadScanTokens :: Alex [Token]+alexMonadScanTokens = do+ inp <- alexGetInput+ sc <- alexGetStartCode+ case alexScan inp sc of+ AlexEOF -> return []+ AlexError inp' -> alexError "lexical error"+ AlexSkip inp' len -> do+ alexSetInput inp'+ alexMonadScanTokens+ AlexToken inp' len action -> do+ alexSetInput inp'+ token <- action inp len+ tokens <- alexMonadScanTokens+ return $ token : tokens++lexTLT :: String -> Either String [Token]+lexTLT s = runAlex s alexMonadScanTokens++}
+ src/Language/TLT/TltParser.y view
@@ -0,0 +1,104 @@+{+-----------------------------------------------------------------------------+-- |+-- Module : Language.TLT.TltParser+-- Copyright : (c) 2011 University of Minho+-- License : BSD3+--+-- Maintainer : hpacheco@di.uminho.pt+-- Stability : experimental+-- Portability : non-portable+--+-- Multifocal:+-- Bidirectional Two-level Transformation of XML Schemas+-- +-- Parser for the two-level language.+--+-----------------------------------------------------------------------------++module Language.TLT.TltParser where++import Language.TLT.TltSyntax+import Language.TLT.TltLexer+import Language.XPath.HXTAliases+}++%name parseTLTToks+%tokentype {Token}++%token+ nop { TokNop }+ comp { TokComp }+ choice { TokChoice }+ try { TokTry }+ many { TokMany }+ all { TokAll }+ once { TokOnce }+ everywhere { TokEverywhere }+ outermost { TokOutermost }+ at { TokAt }+ when { TokWhen }+ hoist { TokHoist }+ plunge { TokPlunge }+ rename { TokRename }+ erase { TokErase }+ select { TokSelect }+ string { TokString $$ }+ '(' { TokSym '(' }+ ')' { TokSym ')' }++%left comp choice+%left '(' ')'++%%++start :: { TLT }+start : tlt { $1 }++tltparens :: { TLT }+tltparens : nop { Nop }+ | erase { Erase }+ | '(' tlt ')' { $2 }++tlt :: { TLT }+tlt : tlbase { $1 }+ | tlstrat { $1 }+ | tlloc { $1 }+ | tllens { $1 }+ | '(' tlt ')' { $2 }++tlbase :: { TLT }+tlbase : nop { Nop }+ | tlt comp tlt { Comp $1 $3 }+ | tlt choice tlt { Choice $1 $3 }+ | try tltparens { Try $2 }+ | many tltparens { Many $2 }++tlstrat :: { TLT }+tlstrat : all tltparens { All $2 }+ | once tltparens { Once $2 }+ | everywhere tltparens { Everywhere $2 }+ | outermost tltparens { Outermost $2 }++tlloc :: { TLT }+tlloc : at string tltparens { At $2 $3 }+ | when string tltparens { When $2 $3 }+ | hoist { Hoist }+ | plunge string { Plunge $2 }+ | rename string { Rename $2 }++tllens :: { TLT }+tllens : erase { Erase }+ | select string { case parseXPath $2 of { Nothing -> error ("error parsing xpath expression "++$2); Just xp -> Select xp } }++{+happyError :: [Token] -> a+happyError (x:_) = error $ "Parser Error: " ++ show x+-- ^ returns the first non-valid token++parseTLT :: String -> TLT+parseTLT str =+ case (lexTLT str) of+ (Left err) -> error $ "Lexer error: " ++ show err+ (Right toks) -> parseTLTToks toks+}
+ src/Language/TLT/TltSyntax.hs view
@@ -0,0 +1,21 @@+module Language.TLT.TltSyntax where++import Language.XPath.HXTAliases++data TLT = Nop+ | Comp TLT TLT+ | Choice TLT TLT+ | Try TLT+ | Many TLT+ | All TLT+ | Once TLT+ | Everywhere TLT+ | Outermost TLT+ | At String TLT+ | When String TLT+ | Hoist+ | Plunge String+ | Rename String+ | Erase+ | Select XPath+ deriving Show
+ src/Language/XML/HaXmlAliases.hs view
@@ -0,0 +1,90 @@+-----------------------------------------------------------------------------+-- |+-- Module : Language.XML.HaXmlAliases+-- Copyright : (c) 2011 University of Minho+-- License : BSD3+--+-- Maintainer : hpacheco@di.uminho.pt+-- Stability : experimental+-- Portability : non-portable+--+-- Multifocal:+-- Bidirectional Two-level Transformation of XML Schemas+-- +-- Alaises for the HaXml library.+--+-----------------------------------------------------------------------------++module Language.XML.HaXmlAliases+ where++import Text.XML.HaXml.Types+import Text.XML.HaXml.ParseLazy as Lazy hiding (document)+import Text.XML.HaXml.Parse as Strict hiding (document)+import Text.XML.HaXml.Posn+import Text.XML.HaXml.Schema.Schema+import Text.XML.HaXml.Schema.Parse+import Text.XML.HaXml.Schema.XSDTypeModel+import Text.XML.HaXml.Util+import Text.XML.HaXml.Namespaces+import Text.XML.HaXml.Schema.TypeConversion+import Text.XML.HaXml.Schema.Environment+import Text.XML.HaXml.Pretty+import Text.PrettyPrint.HughesPJ+import Control.Monad++-- | Parses a XML file into HaXml 'Document' type.+parseXml :: String -> String -> Document Posn+parseXml = Strict.xmlParse++-- | Parses a XML file into HaXml 'Document' type. (Lazy)+parseXmlLazy :: String -> String -> Document Posn+parseXmlLazy = Lazy.xmlParse++-- | Parses a XML DTD into Haxml 'DocTypeDecl' type.+parseDtd :: String -> String -> Maybe DocTypeDecl+parseDtd = Strict.dtdParse++-- | Parses a XML DTD into Haxml 'DocTypeDecl' type. (Lazy)+parseDtdLazy :: String -> String -> Maybe DocTypeDecl+parseDtdLazy = Lazy.dtdParse++doc2Xsd :: Document Posn -> Maybe Schema+doc2Xsd doc = case runParser schema [docContent (posInNewCxt "" Nothing) doc] of+ (Right schema,[]) -> return schema+ (Left msg,_) -> fail msg++one2posn :: Document () -> Document Posn+one2posn (Document a b e c) = Document a b (one2posn' e) c+ where+ one2posn' :: Element () -> Element Posn+ one2posn' (Elem n as cs) = Elem n as $ map one2posn'' cs+ + one2posn'' :: Content () -> Content Posn+ one2posn'' (CElem e _) = CElem (one2posn' e) noPos+ one2posn'' (CString b c _) = CString b c noPos+ one2posn'' (CRef r _) = CRef r noPos+ one2posn'' (CMisc m _) = CMisc m noPos++parseXsd :: String -> String -> Maybe Schema+parseXsd name content = do+ let doc@Document{} = resolveAllNames qualify+ . either (error . ("not XML:\n"++)) id+ . xmlParse' name+ $ content+ doc2Xsd doc++renderXml :: Document a -> String+renderXml = render . document++testDoc = do+ xml <- readFile "examples/imdb.xml"+ print $ document $ parseXml "examples/imdb.xml" xml+ +testXsd = do+ xml <- readFile "examples/company.xsd"+ print $ parseXsd "examples/company.xsd" xml+testSchema = do+ xml <- readFile "examples/imdb.xsd"+ print $ parseXsd "examples/imdb.xsd" xml+
+ src/Language/XML/Type2Xml.hs view
@@ -0,0 +1,130 @@+-----------------------------------------------------------------------------+-- |+-- Module : Language.XML.Type2Xml+-- Copyright : (c) 2011 University of Minho+-- License : BSD3+--+-- Maintainer : hpacheco@di.uminho.pt+-- Stability : experimental+-- Portability : non-portable+--+-- Multifocal:+-- Bidirectional Two-level Transformation of XML Schemas+-- +-- Translation from haskell values to XML documents.+--+-----------------------------------------------------------------------------++module Language.XML.Type2Xml where+ +import Data.Type+import Data.Equal+import Data.Spine+import Language.XML.Xml2Type+import Language.XML.Xsd2Type+import Language.XML.Type2Xsd+import Language.XML.HaXmlAliases+import Generics.Pointless.Functors hiding (rep)+import Generics.Pointless.RecursionPatterns+import Generics.Pointless.Combinators++import Text.XML.HaXml.Schema.XSDTypeModel hiding (K)+import Text.XML.HaXml.Types+import Text.XML.HaXml.Posn+import Data.List+import Data.Maybe+import Control.Monad.State as ST++type XmlGenM b = MonadPlus m => StateT [Attribute] m b++value2xml :: FilePath -> Type a -> a -> Maybe (Document ())+value2xml schemaloc t v = evalStateT (value2xml' schemaloc t v) []++value2xml' :: FilePath -> Type a -> a -> XmlGenM (Document ())+value2xml' schemaloc t v = do+ el <- value2topelement schemaloc t v+ return $ Document (Prolog (Just (XMLDecl "1.0" (Just (EncodingDecl "utf-8")) Nothing)) [] Nothing []) [] el []++value2topelement :: FilePath -> Type a -> a -> XmlGenM (Element ())+value2topelement schemaloc t v = do+ els <- value2elements t v+ let header = [ genAttribute "xmlns:xsi" "http://www.w3.org/2001/XMLSchema-instance"+ , genAttribute "xsi:noNamespaceSchemaLocation" schemaloc]+ case els of+ [Elem name atts cts] -> return $ Elem name (header++atts) cts+ otherwise -> error "multiple or inexistent top elements"+ +value2elements :: Type a -> a -> XmlGenM [Element ()]+value2elements (Either One a) (Left _) | isAtt a = return []+value2elements (Either One a) (Right x) | isAtt a = datavalue2attribute a x >>= addAttVal >> return []+value2elements (Data "Maybe" (K One :+!: K a)) v | isAtt a = case (out v) of+ Left _ -> return []+ Right x -> datavalue2attribute a x >>= addAttVal >> return []+value2elements (Either a One) (Left x) | isAtt a = datavalue2attribute a x >>= addAttVal >> return []+value2elements (Either a One) (Right _) | isAtt a = return []+value2elements (Either One a) (Left _) = return []+value2elements (Either One a) (Right x) = value2elements a x+value2elements (Data "Maybe" (K One :+!: K a)) v = case (out v) of+ Left _ -> return []+ Right x -> value2elements a x+value2elements (Either a One) (Left x) = value2elements a x+value2elements (Either a One) (Right _) = return []+value2elements (List a) lv = mapM (value2elements a) lv >>= return . concat+value2elements a v | isAtt a = datavalue2attribute a v >>= addAttVal >> return []+value2elements d v | isData d = datavalue2element d v >>= return . (:[])+value2elements Dynamic (Dyn t v) = datavalue2element t v >>= return . (:[])+value2elements (Prod a b) (x,y) = do+ elsx <- value2elements a x+ elsy <- value2elements b y+ return $ elsx ++ elsy+value2elements e@(Either a b) (Left x) | not (isMaybe e) = value2elements a x+value2elements e@(Either a b) (Right y) | not (isMaybe e) = value2elements b y++basicvalue2primitive :: Type a -> a -> XmlGenM String+basicvalue2primitive (List Char) str = return str+basicvalue2primitive (isNat -> Just Eq) (Nat n) = return $ show n+basicvalue2primitive Int i = return $ show i+basicvalue2primitive Bool True = return "true"+basicvalue2primitive Bool False = return "false"++datavalue2attribute :: Type a -> a -> XmlGenM Attribute+datavalue2attribute (Data s f) v = datavalue2attribute (NewData s f) (nu (vnn v) v)+datavalue2attribute d@(NewData ('@':s) f) v | isAtt d && isBasic repf = do+ bv <- basicvalue2primitive repf (out v)+ return $ genAttribute s bv+ where repf = rep f d++dynvalue2elements :: Type a -> a -> XmlGenM [Content ()]+dynvalue2elements Dynamic (Dyn t v) = value2elements t v >>= return . celems++listvalue2element :: Type a -> a -> XmlGenM (Content ())+listvalue2element (List a) lv = mapM (basicvalue2primitive a) lv >>= return . cstring . unwords++datavalue2element :: Type a -> a -> XmlGenM (Element ())+datavalue2element d@(Data s f) v = datavalue2element (NewData s f) (nu (vnn v) v)+datavalue2element d@(NewData (nodename -> s) f) v+ | isDynamic repf = dynvalue2elements repf (out v) >>= return . Elem (N s) []+ | isBasic repf = basicvalue2primitive repf (out v) >>= return . Elem (N s) [] . (:[]) . cstring+ | isBasicList repf = listvalue2element repf (out v) >>= return . Elem (N s) [] . (:[])+ | otherwise = do+ atts <- getAttVals+ putAttVals []+ els <- value2elements repf (out v)+ atts' <- getAttVals+ putAttVals atts+ return $ Elem (N s) atts' (celems els)+ where repf = rep f d++cstring :: String -> Content ()+cstring str = CString False str ()++getAttVals :: XmlGenM [Attribute]+getAttVals = ST.get++putAttVals :: [Attribute] -> XmlGenM ()+putAttVals atts = ST.put atts++addAttVal :: Attribute -> XmlGenM ()+addAttVal att = do+ atts <- ST.get+ ST.put (atts++[att])
+ src/Language/XML/Type2Xsd.hs view
@@ -0,0 +1,197 @@+-----------------------------------------------------------------------------+-- |+-- Module : Language.XML.Type2Xsd+-- Copyright : (c) 2011 University of Minho+-- License : BSD3+--+-- Maintainer : hpacheco@di.uminho.pt+-- Stability : experimental+-- Portability : non-portable+--+-- Multifocal:+-- Bidirectional Two-level Transformation of XML Schemas+-- +-- Translation from haskell type representations to XML Schemas.+--+-----------------------------------------------------------------------------++module Language.XML.Type2Xsd where++import Data.Type+import Data.Equal+import Language.XML.Xml2Type+import Language.XML.Xsd2Type+import Language.XML.HaXmlAliases++import Text.XML.HaXml.Schema.XSDTypeModel hiding (K)+import Text.XML.HaXml.Types+import Data.List+import Data.Maybe+import Control.Monad.State as ST++-- (attributes of the current element,recursive complex elements)+type XsdGenM a = MonadPlus m => StateT ([Element ()],[Element ()]) m a++type2xsd :: Type a -> Maybe Schema+type2xsd t = type2doc t >>= doc2Xsd . one2posn++type2doc :: Type a -> Maybe (Document ())+type2doc t = evalStateT (type2doc' t) ([],[])++type2doc' :: Type a -> XsdGenM (Document ())+type2doc' t = do+ els <- type2topelements t+ (_,complexels) <- ST.get+ return $ Document+ (Prolog (Just (XMLDecl "1.0" (Just (EncodingDecl "utf-8")) Nothing)) [] Nothing [])+ [] (Elem (N "xsd:schema")+ [ genAttribute "xmlns:xsd" "http://www.w3.org/2001/XMLSchema"]+ (celems els ++ celems complexels)+ ) []+ +type2topelements :: Type a -> XsdGenM [Element ()]+type2topelements e@(Either a b) | not (isMaybe e) = do+ x <- type2element a + y <- type2element b+ return (maybeToList x ++ maybeToList y)+type2topelements t = do+ mb <- type2element t+ case mb of { Just el -> return [el]; Nothing -> error "top-level attribute?" }++type2element :: Type a -> XsdGenM (Maybe (Element ()))+type2element (Either One a) = type2element (Either a One)+type2element (Data "Maybe" (K One :+!: K a)) = type2element (Either a One)+type2element (Either a One) | isAtt a = data2attribute a >>= addAtt . maybe2attribute >> return Nothing+type2element a | isAtt a = data2attribute a >>= addAtt . nonmaybe2attribute >> return Nothing+type2element (Either a One) = type2element a >>= return . fmap maybe2element+type2element (List a) = type2element a >>= return . fmap list2element+type2element d | isData d = data2element d >>= return . Just+type2element (Id (Var s)) = return $ Just $ Elem (N "xsd:element") [genAttribute "name" s,genAttribute "type" (ref s)] []+type2element Dynamic = return $ Just $ Elem (N "xsd:any") [] []+type2element t = error $ "type2element: " ++ show t++isMaybe :: Type a -> Bool+isMaybe (Either a One) = True+isMaybe (Either One a) = True+isMaybe (Data "Maybe" (K One :+!: K a)) = True+isMaybe _ = False++isBasicList :: Type a -> Bool+isBasicList (List a) = isBasic a+isBasicList _ = False++isDynamic :: Type a -> Bool+isDynamic Dynamic = True+isDynamic _ = False++nonmaybe2attribute :: Element () -> Element ()+nonmaybe2attribute (Elem n atts cts) = Elem n (atts ++ [genAttribute "use" "required"]) cts++maybe2attribute :: Element () -> Element ()+maybe2attribute (Elem n atts cts) = Elem n (atts ++ [genAttribute "use" "optional"]) cts++maybe2element :: Element () -> Element ()+maybe2element (Elem n atts cts) = Elem n (atts ++ [genAttribute "minOccurs" "0",genAttribute "maxOccurs" "1"]) cts++list2element :: Element () -> Element ()+list2element (Elem n atts cts) = Elem n (atts ++ [genAttribute "minOccurs" "0",genAttribute "maxOccurs" "unbounded"]) cts++basic2primitive :: Type a -> XsdGenM String+basic2primitive (List Char) = return "xsd:string"+basic2primitive (Data "Nat" _) = return "xsd:nonNegativeInteger"+basic2primitive Int = return "xsd:integer"+basic2primitive Bool = return "xsd:boolean"++basiclist2list :: Type a -> XsdGenM (Element ())+basiclist2list (List a) = do+ t <- basic2primitive a+ return $ Elem (N "xsd:list") [genAttribute "itemType" t] []++data2attribute :: Type a -> XsdGenM (Element ())+data2attribute (dataNameFctr -> Just (nodename -> ('@':s),f)) | isBasic repf = do+ t <- basic2primitive repf+ return $ Elem (N "xsd:attribute") [genAttribute "name" s,genAttribute "type" t] []+ where repf = rep f $ One+data2attribute a = error $ "data2attribute: " ++ show a++data2element :: Type a -> XsdGenM (Element ())+data2element (Data s f) = data2element (NewData s f)+data2element (NewData s f) | isOne repf = do+ let complex = Elem (N "xsd:complexType") [] (celems [Elem (N "xsd:sequence") [] []])+ return $ Elem (N "xsd:element") [genAttribute "name" (nodename s)] (celems [complex])+ | isDynamic repf = do+ return $ Elem (N "xsd:element") [genAttribute "name" (nodename s)] []+ | isBasic repf = do+ t <- basic2primitive repf+ return $ Elem (N "xsd:element") [genAttribute "name" (nodename s),genAttribute "type" t] []+ | isBasicList repf = do+ l <- basiclist2list repf+ let simple = Elem (N "xsd:simpleType") [] (celems [l])+ return $ Elem (N "xsd:element") [genAttribute "name" (nodename s)] (celems [simple])+ | otherwise = do+ atts <- getAtts+ putAtts []+ mbels <- type2content False repf+ let els = maybe [] (:[]) mbels+ atts' <- getAtts+ let complex = Elem (N "xsd:complexType") [genAttribute "name" (ref $ refname s)] (celems els ++ celems atts')+ addTopComplex complex+ putAtts atts+ return $ Elem (N "xsd:element") [genAttribute "name" (nodename s),genAttribute "type" (ref $ refname s)] []+ where repf = rep f $ Id $ Var $ refname s++-- Bool for identifying if we need to create a sequence container or not+type2content :: Bool -> Type a -> XsdGenM (Maybe (Element ()))+type2content b (Either One a) = type2content b (Either a One)+type2content b (Data "Maybe" (K One :+!: K a)) = type2content b (Either a One)+type2content b (Either a One) | isAtt a = data2attribute a >>= addAtt . maybe2attribute >> return Nothing+type2content b a | isAtt a = data2attribute a >>= addAtt . nonmaybe2attribute >> return Nothing+type2content b (Either a One) = type2content b a >>= return . fmap maybe2element+type2content b (List a) = type2content b a >>= return . fmap list2element+type2content b p@(Prod _ _) = prods2elements p >>= return . Just . Elem (N "xsd:sequence") [] . celems+type2content b e@(Either _ _) | not (isMaybe e) = sums2elements e >>= return . Just . Elem (N "xsd:choice") [] . celems+type2content False t = type2element t >>= return . fmap (\el -> Elem (N "xsd:sequence") [] (celems [el]))+type2content True t = type2element t++prods2elements :: Type a -> XsdGenM [Element ()]+prods2elements (Prod a b) = do+ x <- prods2elements a+ y <- prods2elements b+ return (x ++ y)+prods2elements t = type2content True t >>= return . maybe [] (:[])++sums2elements :: Type a -> XsdGenM [Element ()]+sums2elements e@(Either a b) | not (isMaybe e) = do+ x <- sums2elements a+ y <- sums2elements b+ return (x ++ y)+sums2elements t = type2content True t >>= return . maybe [] (:[])++ref :: String -> String+ref s = s++"REF"++celems :: [Element ()] -> [Content ()]+celems = map (\e -> CElem e ())++genAttribute :: String -> String -> Attribute+genAttribute n v = (N n, AttValue [Left $ v])++addTopComplex :: Element () -> XsdGenM ()+addTopComplex e = do+ (atts,tops) <- ST.get+ if (elem e tops) then return () else ST.put (atts,e:tops)++getAtts :: XsdGenM [Element ()]+getAtts = do+ (atts,_) <- ST.get+ return atts++putAtts :: [Element ()] -> XsdGenM ()+putAtts atts = do+ (_,tops) <- ST.get+ ST.put (atts,tops)++addAtt :: Element () -> XsdGenM ()+addAtt att = do+ (atts,tops) <- ST.get+ ST.put (atts++[att],tops)
+ src/Language/XML/Xml2Type.hs view
@@ -0,0 +1,160 @@+-----------------------------------------------------------------------------+-- |+-- Module : Language.XML.Xml2Type+-- Copyright : (c) 2011 University of Minho+-- License : BSD3+--+-- Maintainer : hpacheco@di.uminho.pt+-- Stability : experimental+-- Portability : non-portable+--+-- Multifocal:+-- Bidirectional Two-level Transformation of XML Schemas+-- +-- Translation from XML documents to haskell values.+--+-----------------------------------------------------------------------------++module Language.XML.Xml2Type where++import Data.Type+import Data.Spine+import Data.Equal+import Generics.Pointless.Functors hiding (rep)+import Generics.Pointless.RecursionPatterns+import Generics.Pointless.Combinators hiding (and)+import Language.XML.Xsd2Type+import Language.XML.HaXmlAliases++import Text.XML.HaXml.Types+import Text.XML.HaXml.Pretty+import Text.XML.HaXml.Posn+import Text.PrettyPrint.HughesPJ++import Control.Monad+import Data.List as List+import Data.Char++xml2value :: MonadPlus m => Type b -> Document Posn -> m b+xml2value a (Document _ _ e _) = topelement2value a e++topelement2value :: MonadPlus m => Type b -> Element Posn -> m b+topelement2value t (Elem n atts cts) = --trace "topelement2value" $+ do let atts' = filter (not . rootatt) atts+ element2value t (Elem n atts' cts)+ where rootatt :: Attribute -> Bool+ rootatt (qname -> n,_) = isPrefixOf "xmlns" n || isPrefixOf "xsi" n++element2value :: MonadPlus m => Type b -> Element Posn -> m b+element2value (Either a b) e = --trace "element2value" $+ (element2value a e >>= return . Left)+ `mplus`+ (element2value b e >>= return . Right)+element2value (Prod a b) e = --trace "element2value" $+ do { x <- element2value a e; y <- empty2value b; return (x,y) }+ `mplus`+ do { x <- empty2value a; y <- element2value b e; return (x,y) }+element2value (listT -> Just (List a)) e = --trace "element2value" $+ element2value a e >>= return . (:[])+element2value (Data s f) e = element2value (NewData s f) e >>= return . (\v -> nu (vnn v) v)+element2value d@(NewData s f) (Elem n atts cts) | nodename s == qname n = --trace ("element2value " ++ show d) $+ do let ctsSpace = filter (not . whitespace) cts+ (x,[],[]) <- attscts2value (rep f d) (atts,ctsSpace)+ return (inn x)+element2value d@(NewData s f) (Elem n atts cts) | isAtt d && nodename s == "@"++qname n = --trace ("element2value " ++ show d) $+ do let ctsSpace = filter (not . whitespace) cts+ (x,atts',cts') <- attscts2value (rep f d) (atts,ctsSpace)+ --trace ("element:" ++ s ++ " " ++ show atts' ++ show (map content cts')) $+ guard $ (null atts') && (null cts')+ return (inn x)+element2value Dynamic e = --trace "element2value" $+ return $ Dyn (List Char) (render $ element e)+element2value t (Elem n atts ctts) = --trace "element2value" $+ --trace ("type " ++ show t ++ " not an element " ++ show n)+ mzero++attscts2value :: MonadPlus m => Type b -> ([Attribute],[Content Posn]) -> m (b,[Attribute],[Content Posn])+attscts2value One (atts,cts) = --trace ("attscts2value " ++ show One) $+ return (_L,atts,cts)+attscts2value t@(Either a b) (atts,cts) = --trace ("attscts2value " ++ show t) $+ do { (x,atts',cts') <- attscts2value a (atts,cts); return (Left x,atts',cts') }+ `mplus`+ do { (y,atts',cts') <- attscts2value b (atts,cts); return (Right y,atts',cts') }+attscts2value t@(Prod a b) (atts,cts) = --trace ("attscts2value " ++ show t) $+ do (x,atts',cts') <- attscts2value a (atts,cts)+ (y,atts'',cts'') <- attscts2value b (atts',cts')+ return ((x,y),atts'',cts'')+attscts2value t@(listT -> Just (List a)) (atts,[]) = --trace ("attscts2value " ++ show t) $+ return ([],atts,[])+attscts2value t@(listT -> Just (List a)) (atts,ct:cts) = --trace ("attscts2value " ++ show t) $+ do { x <- content2value a ct; (xs,atts',cts') <- attscts2value (List a) (atts,cts); return (x:xs,atts',cts') }+ `mplus`+ return ([],atts,ct:cts)+attscts2value d@(dataName -> Just n) (atts,cts) | isAtt d = --trace ("attscts2value " ++ show d) $+ do { guard (not $ null atts); x <- attribute2value d (head atts); return (x,tail atts,cts) }+ `mplus`+ do { x <- empty2value d; return (x,atts,cts) }+attscts2value d@(dataName -> Just n) (atts,cts) | isData d = --trace ("attscts2value " ++ show d) $+ do { guard (not $ null cts); x <- content2value d (head cts); return (x,atts,tail cts) }+ `mplus`+ do { x <- empty2value d; return (x,atts,cts) }+attscts2value t (atts,ct:cts) | isBasic t = --trace ("attscts2value " ++ show t) $+ do { x <- content2value t ct; return (x,atts,cts) }+attscts2value t (atts,cts) = error $ "attscts2value: " ++ show t ++ " " ++ show atts ++ " " ++ show (map content cts)++content2value :: MonadPlus m => Type b -> Content Posn -> m b+content2value t (CElem el _) = --trace "content2value" $+ element2value t el+content2value (listT -> Just (List a)) (CString _ str _) | isBasic a = --trace "content2value" $+ mapM (basic2value a) $ words str+content2value t (CString _ str _) | isBasic t = --trace "content2value" $+ basic2value t str +content2value t (CRef _ _) = error "content: references unsupported"+content2value t (CMisc _ i) = error "content: misc unsupported"++empty2value :: MonadPlus m => Type b -> m b+empty2value One = return _L+empty2value (listT -> Just (List a)) = return []+empty2value (Prod a b) = do { x <- empty2value a; y <- empty2value b; return (x,y) }+empty2value (Either a b) = (empty2value a >>= return . Left) `mplus` (empty2value b >>= return . Right)+empty2value d@(Data _ f) = empty2value (rep f d) >>= return . inn+empty2value d@(NewData _ f) = empty2value (rep f d) >>= return . inn+empty2value t = --trace ("empty2value: " ++ show t)+ mzero++attribute2value :: MonadPlus m => Type b -> Attribute -> m b+attribute2value d@(Data s f) (n,AttValue l) | isAtt d && nodename s == "@"++(qname n) = --trace "attribute2value" $+ do { x <- attvalue2value (rep f d) l; return (inn x) }+attribute2value d@(NewData s f) (n,AttValue l) | isAtt d && nodename s == "@"++(qname n) = --trace "attribute2value" $+ do { x <- attvalue2value (rep f d) l; return (inn x) }+attribute2value t (n,AttValue l) = error $ "attribute: " ++ show t ++ " " ++ " " ++ show n ++ " " ++ show l++attvalue2value :: MonadPlus m => Type b -> [Either String Reference] -> m b+attvalue2value (List a) l | isBasic a = mapM (basic2value a) (dropRefs l)+ where dropRefs = map (\(Left x) -> x) . filter isLeft+attvalue2value a [Left str] | isBasic a = basic2value a str+attvalue2value t l = error $ "attvalue2value: " ++ show t++basic2value :: MonadPlus m => Type b -> String -> m b+basic2value (List Char) s = return s+basic2value d@(Data "Nat" _) s = do { Eq <- teq d nat; basic2value Int s >>= return . intNat }+basic2value Int s = return $ fromEnum (read s :: Int)+basic2value Bool s+ | map toLower s == "true" = return True+ | map toLower s == "false" = return False+basic2value t s = --trace ("basic2value: " ++ show t ++ " " ++ show s)+ mzero++isLeft :: Either a b -> Bool+isLeft (Left _) = True+isLeft (Right _) = False++-- Alternative pattern matching for lists, to avoid matching strings+listT :: Type a -> Maybe (Type a)+listT (List Char) = Nothing+listT (List a) = Just (List a)+listT _ = Nothing++whitespace :: Content Posn -> Bool+whitespace (CString _ s _) = and (map isSpace s)+whitespace _ = False
+ src/Language/XML/Xsd2Type.hs view
@@ -0,0 +1,317 @@+-----------------------------------------------------------------------------+-- |+-- Module : Language.XML.Xsd2Type+-- Copyright : (c) 2011 University of Minho+-- License : BSD3+--+-- Maintainer : hpacheco@di.uminho.pt+-- Stability : experimental+-- Portability : non-portable+--+-- Multifocal:+-- Bidirectional Two-level Transformation of XML Schemas+-- +-- Translation from XML Schemas to haskell type representations.+--+-----------------------------------------------------------------------------++module Language.XML.Xsd2Type where++import Data.Type+import Data.Equal+import Data.Transform.TwoLevel hiding (not)+import Generics.Pointless.Combinators++import Language.XML.HaXmlAliases++import Text.XML.HaXml.Types hiding (ElementDecl,Choice)+import qualified Text.XML.HaXml.Schema.XSDTypeModel as T(Any(..))+import Text.XML.HaXml.Schema.XSDTypeModel hiding (Any(..))++import Control.Monad+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe+import Control.Monad.State as ST+import Data.List++xsd2type :: MonadPlus m => Schema -> m DynType+xsd2type s = xsd2toptype s >>= return . fst++xsd2toptype :: MonadPlus m => Schema -> m (DynType,TopMap)+xsd2toptype (Schema _ _ _ _ _ _ _ items) = do+ -- process top items+ (_,deps) <- runStateT (topitems2type items) Map.empty+ -- process variable dependencies+ let toprocess = map (\(a,(x,y,z)) -> (a,x,z)) $ Map.toList deps+ (_,top) <- runStateT (dependencies deps toprocess) Map.empty+ -- process root elements+ let els = map (\(SchemaElement e) -> e) $ filter isElement items+ cl <- mapM (element2type (TopItems top)) els+ dynt <- applyDynT reshape (nestedEither cl)+ return (dynt,top)++isElement :: SchemaItem -> Bool+isElement (SchemaElement e) = True+isElement _ = False+isAttribute :: SchemaItem -> Bool+isAttribute (SchemaAttribute e) = True+isAttribute _ = False ++subset :: Eq a => [a] -> [a] -> Bool+subset [] l = True+subset (x:xs) l = elem x l && subset xs l++depends :: Deps -> [(Name,a,b)] -> [Name] -> ([(Name,a,b)],[(Name,a,b)])+depends deps [] vars = ([],[])+depends deps (x:xs) vars = let (l1,r1) = depend deps x vars+ (l2,r2) = depends deps xs vars+ in (l1++l2,r1++r2)+depend :: Deps -> (Name,a,b) -> [Name] -> ([(Name,a,b)],[(Name,a,b)])+depend deps (n,t,x) vars | depGraph deps n `subset` vars = ([(n,t,x)],[])+ | otherwise = ([],[(n,t,x)])+depGraph :: Deps -> Name -> [Name]+depGraph deps name = case Map.lookup name deps of { Nothing -> []; Just (t,ns,x) -> ns }++dependencies :: MonadPlus m => Deps -> [(Name,DynType,SchemaItem)] -> StateT TopMap m ()+dependencies deps [] = return ()+dependencies deps l = do+ processed <- ST.get+ let vars = Map.keys processed+ (now,after) = depends deps l vars+ if (null now) then error $ "unsupported mutual recursion or reference to undefined top-level type" ++ show (map (\(x,_,_)->x) after)+ else do+ mapM (dependency deps) now+ dependencies deps after +dependency :: MonadPlus m => Deps -> (Name,DynType,SchemaItem) -> StateT TopMap m ()+dependency deps (n,DynT t,item) = do+ vars <- ST.get+ t' <- replacevar t vars+ ST.put (Map.insert n (DynT t') vars)++topitems2type :: MonadPlus m => [SchemaItem] -> StateT Deps m ()+topitems2type [] = return ()+topitems2type (x:xs) = do+ mb <- topitem2type x+ case mb of+ Just (n,t,deps) -> do+ top <- ST.get+ ST.put $ Map.insert n (t,deps,x) top+ topitems2type xs+ otherwise -> topitems2type xs++topitem2type :: MonadPlus m => SchemaItem -> m (Maybe (Name,DynType,[Name]))+topitem2type item = do+ let name = itemName item+ case name of+ Nothing -> return Nothing+ Just n -> do+ mb <- item2type (Self n) item+ case mb of+ Nothing -> return Nothing+ Just (DynT t) -> do+ return $ Just (n,DynT t,collectVars t)++type Deps = Map Name (DynType,[Name],SchemaItem)+type TopMap = Map Name DynType+data TopItems = Self Name | TopItems TopMap++findTopItem :: Map Name DynType -> Name -> Maybe DynType+findTopItem top name = Map.lookup name top++itemName :: SchemaItem -> Maybe Name+itemName (Include _ _) = Nothing+itemName (Import _ _ _) = Nothing+itemName (Redefine _ _) = Nothing+itemName (Annotation _) = Nothing+itemName (Simple s) = Nothing+itemName (Complex (ComplexType _ name _ _ _ _ _)) = name+itemName (SchemaElement (ElementDecl _ (Left (NT name _)) _ _ _ _ _ _ _ _ _)) = Just name+itemName (SchemaElement (ElementDecl _ (Right ref) _ _ _ _ _ _ _ _ _)) = Nothing+itemName (SchemaAttribute (AttributeDecl _ (Left (NT name _)) _ _ _ _)) = Just name+itemName (SchemaAttribute (AttributeDecl _ (Right ref) _ _ _ _)) = Nothing+itemName (AttributeGroup (AttrGroup _ (Left name) _)) = Just name+itemName (AttributeGroup (AttrGroup _ (Right ref) _)) = Nothing+itemName (SchemaGroup (Group _ (Left name) _ _)) = Just name+itemName (SchemaGroup (Group _ (Right ref) _ _)) = Nothing++item2type :: MonadPlus m => TopItems -> SchemaItem -> m (Maybe DynType)+item2type top (Include _ _) = error "xsd:include unsupported"+item2type top (Import _ _ _) = error "xsd:import unsupported"+item2type top (Redefine _ _) = error "xsd:import unsupported"+item2type top (Annotation _) = return Nothing+item2type top (Simple s) = simple2type top s >>= return . Just+item2type top (Complex c) = complex2type top c >>= return . Just+item2type top (SchemaElement e) = element2type top e >>= return . Just+item2type top (SchemaAttribute a) = attribute2type top a >>= return . Just+item2type top (AttributeGroup as) = attrgroup2type top as >>= return . Just+item2type top (SchemaGroup g) = group2type top g++simple2type :: MonadPlus m => TopItems -> SimpleType -> m DynType+simple2type top (Primitive p) = primitive2type p+simple2type top (Restricted _ _ _ _) = error "xsd:restriction unsupported"+simple2type top (ListOf _ _ _ stype) = do+ DynT s <- (simple2type top \/ qname2type) stype+ return $ DynT $ List s+simple2type top (UnionOf _ _ _ union members) = do+ u <- mapM (simple2type top) union+ m <- mapM qname2type members+ return $ nestedEither (u ++ m)++complex2type :: MonadPlus m => TopItems -> ComplexType -> m DynType+complex2type top (ComplexType _ name _ _ _ _ (SimpleContent _ _)) = error "simpleContent unsupported"+complex2type top (ComplexType _ name _ _ _ _ (ComplexContent _ _ _)) = error "complexContent unsupported"+complex2type top (ComplexType _ name _ _ _ _ (ThisType pas)) = particleattrs2type top pas++particleattrs2type :: MonadPlus m => TopItems -> ParticleAttrs -> m DynType+particleattrs2type top (PA pa atts _) = do+ el <- particle2type top pa+ ats <- mapM (attribute2type top \/ attrgroup2type top) atts+ return $ nestedProd $ filterJust (el:map Just ats)+ +particle2type :: MonadPlus m => TopItems -> Particle -> m (Maybe DynType)+particle2type top Nothing = return Nothing+particle2type top (Just (Left acs)) = acs2type top acs >>= return . Just+particle2type top (Just (Right group)) = group2type top group++group2type :: MonadPlus m => TopItems -> Group -> m (Maybe DynType)+group2type top (Group _ (Right ref) occurs _) = liftM (occurs2type occurs) (ref2type top ref) >>= return . Just+group2type top (Group _ (Left name) occurs Nothing) = return Nothing+group2type top (Group _ (Left name) occurs (Just acs)) = liftM (occurs2type occurs) (acs2type top acs) >>= return . Just++acs2type :: MonadPlus m => TopItems -> ChoiceOrSeq -> m DynType+acs2type top (All _ els) = error "xsd:all unsupported"+acs2type top (Choice _ occurs els) = liftM (occurs2type occurs) $ choice2type top els+acs2type top (Sequence _ occurs els) = liftM (occurs2type occurs) $ sequence2type top els++choice2type :: MonadPlus m => TopItems -> [ElementEtc] -> m DynType+choice2type top l = do+ cl <- mapM (elementetc2type top) l+ return $ nestedEither $ filterJust cl++sequence2type :: MonadPlus m => TopItems -> [ElementEtc] -> m DynType+sequence2type top l = do+ sl <- mapM (elementetc2type top) l+ return $ nestedProd $ filterJust sl++filterJust :: [Maybe a] -> [a]+filterJust = map fromJust . filter isJust++elementetc2type :: MonadPlus m => TopItems -> ElementEtc -> m (Maybe DynType)+elementetc2type top (HasElement e) = element2type top e >>= return . Just+elementetc2type top (HasGroup g) = group2type top g+elementetc2type top (HasCS acs) = acs2type top acs >>= return . Just+elementetc2type top (HasAny a) = any2type a >>= return . Just++any2type :: MonadPlus m => T.Any -> m DynType+any2type (T.Any _ _ _ occurs) = return $ occurs2type occurs $ DynT Dynamic++element2type :: MonadPlus m => TopItems -> ElementDecl -> m DynType+element2type top (ElementDecl _ (Right ref) occurs _ _ _ _ _ _ _ _) = liftM (occurs2type occurs) $ ref2type top ref+element2type top (ElementDecl _ (Left (NT name Nothing)) occurs _ _ _ _ _ _ Nothing _) = do+ liftM (occurs2type occurs) $ newElement top name (DynT Dynamic)+element2type top@(Self n) (ElementDecl _ (Left (NT name t)) occurs _ _ _ _ _ _ Nothing _) = do+ -- references to the same type are considered recursive invocations, even if the name does not match+ dynt <- typeref2type top t+ case dynt of+ DynT (Id Any) -> return $ occurs2type occurs dynt+ otherwise -> liftM (occurs2type occurs) $ newElement top name dynt+element2type top (ElementDecl _ (Left (NT name t)) occurs _ _ _ _ _ _ Nothing _) = do+ dynt <- typeref2type top t+ liftM (occurs2type occurs) $ newElement top name dynt+element2type top (ElementDecl _ (Left (NT name Nothing)) occurs _ _ _ _ _ _ (Just content) _) = do+ dynt <- (simple2type top \/ complex2type top) content+ liftM (occurs2type occurs) $ newElement top name dynt+element2type top (ElementDecl _ (Left (NT name t)) occurs _ _ _ _ _ _ content _) = error "element has two types?"+ +attribute2type :: MonadPlus m => TopItems -> AttributeDecl -> m DynType+attribute2type top (AttributeDecl _ (Right ref) use _ _ _) = do+ att <- ref2type top ref+ return (use2type use att)+attribute2type top (AttributeDecl _ (Left (NT name t)) use _ _ _) = do+ dynt <- typeref2type top t+ att <- newAttribute top name dynt+ return (use2type use att)++occurs2type :: Occurs -> DynType -> DynType+occurs2type (Occurs (Just 0) (Just 9223372036854775807)) (DynT t) = DynT $ List t+occurs2type (Occurs (Just 0) (Just 1)) (DynT t) = DynT (Either t One)+occurs2type (Occurs (Just 1) (Just 1)) t = t+occurs2type (Occurs Nothing max) t = occurs2type (Occurs (Just 1) max) t+occurs2type (Occurs min Nothing) t = occurs2type (Occurs min (Just 1)) t+occurs2type (Occurs min max) t = error $ "occurs unsupported: " ++ show min ++ "-" ++ show max++use2type :: Use -> DynType -> DynType+use2type Prohibited t = DynT One+use2type Required t = t+use2type Optional (DynT t) = DynT (Either t One)++attrgroup2type :: MonadPlus m => TopItems -> AttrGroup -> m DynType+attrgroup2type top (AttrGroup _ (Right ref) _) = ref2type top ref+attrgroup2type top (AttrGroup _ (Left name) atts) = do+ ats <- mapM (attribute2type top \/ attrgroup2type top) atts+ return $ nestedProd ats++basicTypes :: Map Name DynType+basicTypes = Map.fromList+ [("integer",DynT Int),("positiveInteger",DynT Int),("int",DynT Int)+ ,("decimal",DynT (List Char)),("float",DynT (List Char)),("double",DynT (List Char))+ ,("string",DynT (List Char)),("byte",DynT Int),("boolean",DynT Bool),("date",DynT (List Char))+ ,("NMTOKEN",DynT (List Char)),("NMTOKENS",DynT (List Char)),("ID",DynT (List Char))+ ,("anyUri",DynT (List Char)),("language",DynT (List Char)),("NCName",DynT (List Char))+ ,("NCName",DynT (List Char)),("dateTime",DynT (List Char)),("nonNegativeInteger",DynT nat)+ ,("short",DynT Int),("long",DynT Int),("token",DynT (List Char)),("duration",DynT (List Char))+ ,("normalizedString",DynT (List Char)),("Name",DynT (List Char))]++isBasicType :: QName -> Bool+isBasicType (QN (Namespace "xs" _) n) = Map.member n basicTypes+isBasicType (QN (Namespace "xsd" _) n) = Map.member n basicTypes+isBasicType _ = False++-- A simple type as a qualified name+qname2type :: MonadPlus m => QName -> m DynType+qname2type qn@(isBasicType -> True) = return $ fromJust $ Map.lookup (fromQName qn) basicTypes+qname2type qn = error $ show qn ++ " is not a basic type"++typeref2type :: MonadPlus m => TopItems -> Maybe QName -> m DynType+typeref2type top Nothing = return $ DynT Dynamic+typeref2type top (Just qn@(isBasicType -> True)) = return $ fromJust $ Map.lookup (fromQName qn) basicTypes+typeref2type top (Just qn) = ref2type top qn++ref2type :: MonadPlus m => TopItems -> QName -> m DynType+ref2type (Self name) (qname -> n) = if name == n+ then return $ DynT $ Id Any+ else return $ DynT $ Var n+ref2type (TopItems top) (qname -> n) = case findTopItem top n of+ Just t -> return t+ Nothing -> error $ "reference to undefined top-level type " ++ show n++fromQName :: QName -> Name+fromQName (QN _ name) = name++qname :: QName -> Name+qname (N name) = name+qname (QN (Namespace ns _) name) = name++primitive2type :: MonadPlus m => PrimitiveType -> m DynType+primitive2type Boolean = return $ DynT Bool+primitive2type _ = return $ DynT (List Char)++nestedEither,nestedProd :: [DynType] -> DynType+nestedEither [] = DynT $ One+nestedEither [t] = t+nestedEither (DynT x:xs) = applyDynT (\y -> DynT $ Either x y) (nestedEither xs)+nestedProd [] = DynT $ One+nestedProd [t] = t+nestedProd (DynT x:xs) = applyDynT (\y -> DynT $ Prod x y) (nestedProd xs)++newElement :: MonadPlus m => TopItems -> Name -> DynType -> m DynType+newElement top name (DynT t) = do+ FRep f <- inferFctr (Id Any) t+ return $ DynT $ NewData name f++newAttribute :: MonadPlus m => TopItems -> Name -> DynType -> m DynType+newAttribute top name (DynT t) = do+ FRep f <- inferFctr (Id Any) t+ return $ DynT $ NewData ("@"++name) f+
+ src/Language/XPath/HXTAliases.hs view
@@ -0,0 +1,33 @@+-----------------------------------------------------------------------------+-- |+-- Module : Language.XPath.HXTAliases+-- Copyright : (c) 2011 University of Minho+-- License : BSD3+--+-- Maintainer : hpacheco@di.uminho.pt+-- Stability : experimental+-- Portability : non-portable+--+-- Multifocal:+-- Bidirectional Two-level Transformation of XML Schemas+-- +-- Aliases for HXT library.+--+-----------------------------------------------------------------------------++module Language.XPath.HXTAliases where++import qualified Text.XML.HXT.XPath as HXT+import Text.XML.HXT.XPath.XPathDataTypes+import Text.XML.HXT.Parser.XmlCharParser( withNormNewline )+import Text.ParserCombinators.Parsec ( runParser )+import Text.XML.HXT.XPath.XPathToString+import Text.XML.HXT.DOM.QualifiedName+++type XPath = Expr++parseXPath :: String -> Maybe XPath+parseXPath path = case runParser HXT.parseXPath (withNormNewline []) "" path of+ Left err -> Nothing+ Right xp -> Just xp
+ src/Language/XPath/XPath2Pf.hs view
@@ -0,0 +1,215 @@+-----------------------------------------------------------------------------+-- |+-- Module : Language.XPath.XPath2Pf+-- Copyright : (c) 2011 University of Minho+-- License : BSD3+--+-- Maintainer : hpacheco@di.uminho.pt+-- Stability : experimental+-- Portability : non-portable+--+-- Multifocal:+-- Bidirectional Two-level Transformation of XML Schemas+-- +-- Translation from XPath expressions into point-free function representations.+--+-----------------------------------------------------------------------------++module Language.XPath.XPath2Pf where++import Data.Type+import Data.Pf+import Data.Spine+import Generics.Pointless.Functors hiding (fmap)+import Language.XPath.HXTAliases++import Text.XML.HXT.XPath as HXT hiding (parseXPath)+import Text.XML.HXT.XPath.XPathDataTypes as XPath+import Text.XML.HXT.DOM.QualifiedName+import Control.Monad+import Data.Monoid++type XPathQ = Q [Dynamic]++xpath2pf :: MonadPlus m => XPath -> m (Pf XPathQ)+xpath2pf = expr2pf . relativeExpr++-- | Converts top-level absolute paths to relative paths+relativeExpr :: XPath -> XPath+relativeExpr (GenExpr op exprs) = GenExpr op (map relativeExpr exprs)+relativeExpr (PathExpr expr path) = PathExpr (fmap relativeExpr expr) (fmap relativeLocPath path)+relativeExpr (FilterExpr exprs) = FilterExpr (map relativeExpr exprs)+relativeExpr (FctExpr name exprs) = FctExpr name (map relativeExpr exprs)+relativeExpr xp = xp+relativeLocPath (LocPath Abs steps) = LocPath Rel steps+relativeLocPath (LocPath Rel steps) = LocPath Rel steps++expr2pf :: MonadPlus m => XPath -> m (Pf XPathQ)+expr2pf e@(GenExpr op lexp) | isBoolOp op = do+ pf <- xpath2boolpf e+ return $ mkXPathQ Bool pf+expr2pf e@(GenExpr op lexp) | isNumOp op = do+ pf <- xpath2numpf e+ return $ mkXPathQ Int pf+expr2pf (GenExpr Union lexp) = do+ pfs <- mapM expr2pf lexp+ return $ nestedUnion pfs+expr2pf (PathExpr Nothing (Just path)) = locpath2pf path+expr2pf (PathExpr (Just pred) Nothing) = expr2pf (FilterExpr [pred])+expr2pf (PathExpr (Just pred) (Just path)) = do+ pf <- locpath2pf path+ filter2pf pf pred+expr2pf (FilterExpr (xpath:preds)) = do+ xp <- expr2pf xpath+ filters2pf xp preds+expr2pf (VarExpr var) = error "no variables supported"+expr2pf (LiteralExpr str) = return $ constantpf (List Char) str+expr2pf (NumberExpr i) = return $ constantpf Int (xpathnum2int i)+expr2pf (FctExpr "count" [arg]) = do+ pf <- expr2pf arg+ return $ mkXPathQ nat $ SEQQ pf LENGTH+expr2pf (FctExpr "sum" args) = do+ pfs <- mapM expr2pf args+ let pf = nestedUnion $ map (`SEQQ` MAP (CAST nat)) pfs+ return $ mkXPathQ nat $ pf `SEQQ` FOLD+expr2pf (FctExpr name args) = error $ "function unsupported :" ++ name++locpath2pf :: MonadPlus m => LocationPath -> m (Pf XPathQ)+locpath2pf (LocPath Rel xsteps) = xsteps2pf xsteps+locpath2pf (LocPath Abs _) = error "absolute paths not supported"++xsteps2pf :: MonadPlus m => [XStep] -> m (Pf XPathQ)+xsteps2pf xsteps = do+ xs <- mapM xstep2pf xsteps+ return $ nestedXComp xs++nestedXComp :: [Pf XPathQ] -> Pf XPathQ+nestedXComp [] = EMPTYQ+nestedXComp [x] = x+nestedXComp (x:xs) = x :/: nestedXComp xs++xstep2pf :: MonadPlus m => XStep -> m (Pf XPathQ)+xstep2pf (Step axis node preds) =+ do { nd <- node2pf node; filters2pf (axis2pf axis :/: nd) preds }+ `mplus`+ do { filters2pf (axis2pf axis) preds }++node2pf :: MonadPlus m => NodeTest -> m (Pf XPathQ)+node2pf (NameTest n) = return $ NAME (qname n)+node2pf (TypeTest XPNode) = mzero+node2pf node = error $ "node " ++ show node ++ " unsupported"++qname :: QName -> String+qname n = localPart n++axis2pf :: AxisSpec -> Pf XPathQ+axis2pf Child = CHILD+axis2pf Descendant = DESCENDANT+axis2pf DescendantOrSelf = DESCSELF+axis2pf XPath.Self = SELF+axis2pf Attribute = ATTRIBUTE+axis2pf x = error $ "axisSpec2PF: axis " ++ show x ++ " not supported"++filters2pf :: MonadPlus m => Pf XPathQ -> [XPath] -> m (Pf XPathQ)+filters2pf pf = foldM filter2pf pf++filter2pf :: MonadPlus m => Pf XPathQ -> XPath -> m (Pf XPathQ)+filter2pf pf (NumberExpr i) = return $ filternatpf pf (intNat $ xpathnum2int i)+filter2pf pf pred = do+ p <- xpath2boolpf pred+ return $ pf :?: p++filternatpf :: Pf XPathQ -> Nat -> Pf XPathQ+filternatpf pf (Nat 0) = EMPTYQ+filternatpf pf (Nat 1) = pf `SEQQ` LHEAD+filternatpf pf (Nat (pred -> n)) = filternatpf (SEQQ pf LTAIL) (Nat n)++mkXPathQ :: Typeable a => Type a -> Pf (Q a) -> Pf XPathQ+mkXPathQ a pf = pf `SEQQ` (MKDYN a) `SEQQ` WRAP++constantpf :: Typeable a => Type a -> a -> Pf XPathQ+constantpf a x = mkXPathQ a $ SEQQ EMPTYQ (PNT x)++xpathnum2int :: XPNumber -> Int+xpathnum2int (XPath.Float f) = fromEnum f+xpathnum2int (XPath.NaN) = error "xpnumber NaN"+xpathnum2int (XPath.NegInf) = -2147483648+xpathnum2int (XPath.PosInf) = 2147483647+xpathnum2int (XPath.Neg0) = 0+xpathnum2int (XPath.Pos0) = 0++xpath2boolpf :: MonadPlus m => XPath -> m (Pf (Q Bool))+xpath2boolpf (GenExpr op ps) | isBoolOp op = do+ xs <- mapM xpath2boolpf ps+ return $ nestedOp (boolop2pf op) xs+xpath2boolpf exp = do+ pf <- expr2pf exp+ return $ boolean pf+ where boolean :: Pf XPathQ -> Pf (Q Bool)+ boolean pf = pf `SEQQ` NONEMPTY++boolop2pf :: Op -> Pf ((Bool,Bool) -> Bool)+boolop2pf Or = FUN "or" $ uncurry (||)+boolop2pf And = FUN "and" $ uncurry (&&)+boolop2pf Eq = FUN "eq" $ uncurry (==)+boolop2pf NEq = FUN "neq" $ uncurry (/=)+boolop2pf Less = FUN "less" $ uncurry (<)+boolop2pf Greater = FUN "greater" $ uncurry (>)+boolop2pf LessEq = FUN "lesseq" $ uncurry (<=)+boolop2pf GreaterEq = FUN "greatereq" $ uncurry (>=)++xpath2numpf :: MonadPlus m => XPath -> m (Pf (Q Int))+xpath2numpf (GenExpr op is) | isNumOp op = do+ xs <- mapM xpath2numpf is+ return $ nestedOp (numop2pf op) xs+xpath2numpf (NumberExpr i) = return $ SEQQ EMPTYQ (PNT (xpathnum2int i))+xpath2numpf exp = do+ pf <- expr2pf exp+ return $ number pf+ where number :: Pf XPathQ -> Pf (Q Int)+ number (SEQQ pf WRAP) = SEQQ pf (UNDYN Int)+ number pf = error $ "expression not a number: " ++ show pf++numop2pf :: Op -> Pf ((Int,Int) -> Int)+numop2pf Plus = FUN "plus" (uncurry (+))+numop2pf Minus = FUN "plus" (uncurry (-))+numop2pf Div = FUN "plus" (uncurry div)+numop2pf Mod = FUN "mod" (uncurry mod)+numop2pf Mult = FUN "mult" (uncurry (*))+numop2pf Unary = error "unary?"++xpath2natpf :: MonadPlus m => XPath -> m (Pf (Q Nat))+xpath2natpf (GenExpr op is) | isNumOp op = do+ xs <- mapM xpath2natpf is+ return $ nestedOp (natop2pf op) xs+xpath2natpf exp = do+ pf <- expr2pf exp+ return $ number pf+ where number :: Pf XPathQ -> Pf (Q Nat)+ number (SEQQ pf WRAP) = SEQQ pf (UNDYN nat)+ number pf = error $ "expression not a natural: " ++ show pf++natop2pf :: Op -> Pf ((Nat,Nat) -> Nat)+natop2pf Plus = PLUS+natop2pf Minus = error "minus undefined for naturals"+natop2pf Div = error "div undefined for naturals"+natop2pf Mod = error "mod undefined for naturals"+natop2pf Mult = error "mult undefined for naturals"+natop2pf Unary = error "unary?"++nestedOp :: (Monoid a,Typeable a) => Pf ((a,a) -> a) -> [Pf (Q a)] -> Pf (Q a)+nestedOp op [] = EMPTYQ+nestedOp op [p] = p+nestedOp op (p:ps) = SEQQ (p :/\: nestedOp op ps) op++isBoolOp :: Op -> Bool+isBoolOp x = or $ map (x==) $ [Or,And,XPath.Eq,NEq,Less,Greater,LessEq,GreaterEq]++isNumOp :: Op -> Bool+isNumOp x = or $ map (x==) $ [Plus,Minus,Div,Mod,Mult,Unary]++nestedUnion :: [Pf (Q [a])] -> Pf (Q [a])+nestedUnion [] = EMPTYQ+nestedUnion [x] = x+nestedUnion (x:xs) = x `UNION` (nestedUnion xs)+
+ src/UI/CmdLine.hs view
@@ -0,0 +1,119 @@+-----------------------------------------------------------------------------+-- |+-- Module : UI.CmdLine+-- Copyright : (c) 2011 University of Minho+-- License : BSD3+--+-- Maintainer : hpacheco@di.uminho.pt+-- Stability : experimental+-- Portability : non-portable+--+-- Multifocal:+-- Bidirectional Two-level Transformation of XML Schemas+-- +-- Main file for the multifocal tool.+--+-----------------------------------------------------------------------------++module Main where++import Data.Type+import Data.Equal+import Data.Transform.TwoLevel+import UI.GenHaskell+import Language.TLT.Tlt2Strat+import Language.XML.Type2Xsd+import Language.XML.Xsd2Type+import Transform.Rules.Lenses+import Language.XML.HaXmlAliases+import Language.TLT.TltParser+import Transform.Rewriting as R+import UI.Menu++import System.IO+import System.Environment+import System.Console.GetOpt+import System.Exit+import Control.Monad.State as ST++-----------------------------------------------------------------------------+-- * Command line options++-- | Record type to hold all program options.+data Options = Options+ {+ optInputXsdFile :: Maybe FilePath+ , optInput2LTFile :: Maybe FilePath+ , optOutputXsdFile :: Maybe FilePath+ , optOutputHsFile :: Maybe FilePath+ , optOptimize :: Bool+ }++-- | Default options.+startOpt :: Options+startOpt = Options+ { optInputXsdFile = Nothing+ , optInput2LTFile = Nothing+ , optOutputXsdFile = Nothing+ , optOutputHsFile = Nothing+ , optOptimize = False+ }++-- | Description of all available program options.+options :: Opts Options+options =+ [ Option "h" ["help"]+ (NoArg (\opt -> exitHelp options))+ "Show usage info"+ , Option "i" ["input"]+ (ReqArg (\arg opt -> return opt { optInputXsdFile = Just arg }) "FILE")+ "Input XML Schema"+ , Option "t" ["2lt"]+ (ReqArg (\arg opt -> return opt { optInput2LTFile = Just arg }) "FILE")+ "Input 2LT Transformation File"+ , Option "o" ["output"]+ (ReqArg (\arg opt -> return opt { optOutputXsdFile = Just arg }) "FILE")+ "Output XML Schema (default: stdout)"+ , Option "c" ["haskell"]+ (ReqArg (\arg opt -> do return opt { optOutputHsFile = Just arg }) "FILE")+ "Output Haskell program with the corresponding bidirectional transformation."+ , Option "e" ["optimize"]+ (NoArg (\opt -> do return opt { optOptimize = True }))+ "Optimize the resulting bidirectional transformation."+ ]++main = menu+menu :: IO ()+menu = do+ argv <- getArgs+ opts <- parseOptions startOpt options argv+ i <- run "input XML Schema missing" $ optInputXsdFile opts+ -- parse Xml Schema+ xml <- readFile i+ schema <- run "Error parsing input XML Schema" $ parseXsd i xml+ -- parse input XSD into a type+ (DynT a,tops) <- run "error translating input XML Schema" $ xsd2toptype schema+ --putStrLn $ showDatas a+ t <- run "input Multifocal Transformation missing" $ optInput2LTFile opts+ -- parse 2LT transformation file+ tfile <- readFile t+ let tlt = parseTLT tfile+ --putStrLn $ show tlt+ -- translate the parsed 2LT transformation into Haskell+ RuleTRep rule <- run "Error translating 2LT transformation" $ evalStateT (tlt2strat tlt) tops+ -- evaluate the 2LT transformation+ (View lns b,news) <- run "Failed to apply 2LT transformation" $ transform a rule+ -- print output XML Schema+ --putStrLn $ showDatas b+ outputHandle <- maybe (return stdout) (\f -> openFile f WriteMode) (optOutputXsdFile opts)+ doc <- run "Error generating output XML Schema file" $ type2doc b+ hPutStrLn outputHandle $ renderXml doc+ hClose outputHandle+ -- generate output Haskell Lens File+ let srcSchema = maybe "" id (optInputXsdFile opts)+ tgtSchema = maybe "" id (optOutputXsdFile opts)+ rule :: Rule+ rule = if optOptimize opts then optimise_all_lns else R.nop+ case optOutputHsFile opts of+ Nothing -> return ()+ Just hs -> generateHaskell' srcSchema tgtSchema [] hs a (View lns b) news rule
+ src/UI/GenHaskell.hs view
@@ -0,0 +1,322 @@+-----------------------------------------------------------------------------+-- |+-- Module : UI.GenHaskell+-- Copyright : (c) 2011 University of Minho+-- License : BSD3+--+-- Maintainer : hpacheco@di.uminho.pt+-- Stability : experimental+-- Portability : non-portable+--+-- Multifocal:+-- Bidirectional Two-level Transformation of XML Schemas+-- +-- Generation of Haskell code for the source and input schemas and the corresponding lens transformation.+--+-----------------------------------------------------------------------------++module UI.GenHaskell (generateHaskell,generateHaskell') where+ +import Data.Equal+import Data.Transform.TwoLevel hiding (showType)+import Transform.Rules.Lenses+import Transform.Rewriting++import Data.Type as T hiding (Var)+import Data.Pf+import Data.Spine hiding (Con)+import Generics.Pointless.Functors hiding (rep)+import Generics.Pointless.Combinators++import Data.Map as Map hiding (map)+import Control.Monad.State as ST+import Language.Haskell.Exts.Syntax as Ext hiding (Rule)+import Language.Haskell.Exts.Pretty+import Data.List+import Data.Char++generateHaskell :: FilePath -> FilePath -> [FilePath] -> FilePath -> T.Type a -> RuleT -> IO ()+generateHaskell srcSchema tgtSchema sources output a r = case transform a r of+ Just (v,news) -> generateHaskell' srcSchema tgtSchema sources output a v news optimise_all_lns+ otherwise -> putStrLn "Failed to apply transformation, no output generated."++generateHaskell' :: FilePath -> FilePath -> [FilePath] -> FilePath -> T.Type a -> View a -> Map String DynFctr -> Rule -> IO ()+generateHaskell' srcSchema tgtSchema sources output a (View lns b) news pfrule = do+ let newnames = (collectNewNames a ++ collectNewNames b)+ newdatas = Map.toList $ Map.filterWithKey (\k a -> k `elem` newnames) news+ lns' <- reduceIO pfrule (Lns a b) lns+ let ast = topModule srcSchema tgtSchema sources newdatas a (View lns' b)+ writeFile output (prettyPrint ast)++-- | standard location of the code+loc :: SrcLoc+loc = SrcLoc "" 0 0++topModule :: FilePath -> FilePath -> [FilePath] -> [(String,DynFctr)] -> T.Type a -> View a -> Module+topModule srcSchema tgtSchema sources newdatas a (View lns b) = Module loc filename pragmas Nothing Nothing imports code+ where news = map fst newdatas+ pragmas :: [ModulePragma]+ pragmas = [LanguagePragma loc [Ident "TypeOperators",Ident "TypeFamilies"]]+ imports :: [ImportDecl]+ imports = [ importMAs "Ori" "Generics.Pointless.Lenses", importMAs "Ori" "Generics.Pointless.Lenses.RecursionPatterns"+ , importMAs "Ori" "Generics.Pointless.Functors", importMAs "Ori" "Generics.Pointless.RecursionPatterns"+ , importMAs "Ori" "Generics.Pointless.Combinators", importMAs "Ori" "Generics.Pointless.Lenses.Combinators"+ , importMAs "Ori" "Generics.Pointless.Lenses.Examples.Examples", importMAs "Ori" "Data.Type", importMAs "Ori" "Prelude"+ , importMAs "Ori" "UI.LensMenu"]+ ++ map (importMAs "Ori") sources+ code = decls ++ instances ++ typeables ++ mus ++ sig ++ exp+ ++ [typeSignature news "srcType" a,typeExpression news "srcType"]+ ++ [typeSignature news "tgtType" b,typeExpression news "tgtType"]+ ++ [schemaExpression "srcSchema" srcSchema,schemaExpression "tgtSchema" tgtSchema]+ ++ [mainExpression]+ decls, instances, typeables, mus, sig :: [Decl]+ decls = map (\(s,DynF f) -> typeDecl news s f) newdatas+ instances = map (\(s,DynF f) -> typeInstance news s f) newdatas+ typeables = map (\(s,DynF f) -> typeTypeable news s) newdatas+ mus = map (\(s,DynF f) -> typeMu news s f) newdatas+ sig = [signature news "transformation" a b]+ exp = [expression news "transformation" (Pf $ Lns a b) lns]++filename :: ModuleName+filename = (ModuleName "Main")+ +importM :: String -> ImportDecl+importM name = ImportDecl { importLoc = loc, importModule = ModuleName name, importQualified = False+ , importSrc = False , importPkg = Nothing, importAs = Nothing, importSpecs = Nothing }+ +importMAs :: String -> String -> ImportDecl+importMAs ref name = (importM name) { importQualified = False, importAs = Just $ ModuleName ref }+++typeConstructors :: [String] -> String -> Fctr f -> State Int [QualConDecl]+typeConstructors news name (f :+!: g) = do+ x <- typeConstructors news name f+ y <- typeConstructors news name g+ return (x ++ y)+typeConstructors news name f = do+ i <- ST.get+ ST.put (succ i)+ return [typeConstructor news name i f]++typeConstructor :: [String ] -> String -> Int -> Fctr f -> QualConDecl+typeConstructor news name i fctr = QualConDecl loc [] [] (ConDecl (Ident $ hsname name ++ "C" ++ show i) (typeConstructorProd news name fctr))+typeConstructorProd :: [String] -> String -> Fctr f -> [BangType]+typeConstructorProd news name (f :*!: g) = typeConstructorProd news name f ++ typeConstructorProd news name g+typeConstructorProd news name f = [UnBangedTy $ typeConstructor' news name (rep f (NewData name I))]+typeConstructor' :: [String] -> String -> T.Type a -> Ext.Type+typeConstructor' news name (T.List a) = TyList $ typeConstructor' news name a+typeConstructor' news name (Prod a b) = TyTuple Boxed [typeConstructor' news name a,typeConstructor' news name b]+typeConstructor' news name (Either a b) = TyApp (TyApp (TyCon (UnQual (Ident "Either"))) (typeConstructor' news name a)) (typeConstructor' news name b)+typeConstructor' news name a = showType news a++typeDecl :: [String] -> String -> Fctr f -> Decl+typeDecl news name fctr = DataDecl+ loc DataType [] (Ident $ hsname name) [] (evalState (typeConstructors news name fctr) 1) [(UnQual (Ident "Show"),[])]++typeInstance :: [String] -> String -> Fctr f -> Decl+typeInstance news name fctr = TypeInsDecl loc (TyApp (TyCon (UnQual (Ident "PF"))) (showType news (NewData name I))) (typeInstance' news fctr)+typeInstance' :: [String] -> Fctr f -> Ext.Type+typeInstance' news I = (TyCon (UnQual (Ident "Id")))+typeInstance' news L = (TyCon (Special ListCon))+typeInstance' news (K c) = TyApp (TyCon (UnQual (Ident "Const"))) $ showType news c+typeInstance' news (f :*!: g) = TyParen $ TyInfix (typeInstance' news f) (UnQual (Symbol ":*:")) (typeInstance' news g)+typeInstance' news (f :+!: g) = TyParen $ TyInfix (typeInstance' news f) (UnQual (Symbol ":+:")) (typeInstance' news g)+typeInstance' news (f :@!: g) = TyParen $ TyInfix (typeInstance' news f) (UnQual (Symbol ":@:")) (typeInstance' news g)++typeTypeable :: [String] -> String -> Decl+typeTypeable news name = InstDecl loc [] (UnQual (Ident "Typeable")) [showType news (NewData name I)] [InsDecl (PatBind loc (PVar (Ident "typeof")) Nothing (UnGuardedRhs (App (App (Con (UnQual (Ident "Data"))) (Lit (String name))) (Var (UnQual (Ident "fctrof"))))) (BDecls []))]++typeMu :: [String] -> String -> Fctr f -> Decl+typeMu news name fctr = InstDecl loc [] (UnQual (Ident "Mu")) [showType news (NewData name I)] (evalState (outMu name fctr) 1 ++ evalState (innMu name fctr) 1)++outMu :: String -> Fctr f -> State Int [InstDecl]+outMu name (f :+!: g) = do+ x <- outMu name f+ y <- outMu name g+ return (x ++ y)+outMu name f = do+ i <- ST.get+ ST.put (succ i)+ return [outMu' name i f]+outMu' :: String -> Int -> Fctr f -> InstDecl+outMu' name i fctr = InsDecl $ FunBind [Match loc (Ident "out")+ [PParen (PApp (UnQual (Ident $ hsname name ++ "C" ++ show i)) (evalState (outPat fctr) 'a'))]+ Nothing (UnGuardedRhs $ evalState (outRhs (rep fctr T.Int)) 'a') (BDecls [])]++innMu :: String -> Fctr f -> State Int [InstDecl]+innMu name (f :+!: g) = do+ x <- innMu name f+ y <- innMu name g+ return (x ++ y)+innMu name f = do+ i <- ST.get+ ST.put (succ i)+ return [innMu' name i f]+innMu' :: String -> Int -> Fctr f -> InstDecl+innMu' name i fctr = InsDecl $ FunBind [Match loc (Ident "inn") [evalState (innPat (rep fctr T.Int)) 'a']+ Nothing (UnGuardedRhs $ evalState (innRhs (name ++ "C" ++ show i) fctr) 'a') (BDecls [])]++innRhs :: String -> Fctr f -> State Char Exp+innRhs cname f = do+ exps <- innRhs' f+ return $ foldl App (Con (UnQual (Ident $ hsname cname))) exps ++innRhs' :: Fctr f -> State Char [Exp]+innRhs' (f :*!: g) = do+ x <- innRhs' f+ y <- innRhs' g+ return (x ++ y)+innRhs' f = do+ c <- ST.get+ ST.put (succ c)+ return [Var (UnQual (Ident [c]))]++innPat :: T.Type a -> State Char Pat+innPat (Prod a b) = do+ x <- innPat a+ y <- innPat b+ return $ PTuple [x,y]+innPat a = do+ c <- ST.get+ ST.put (succ c)+ return $ PVar $ Ident [c]++outPat :: Fctr f -> State Char [Pat]+outPat (f :*!: g) = do+ x <- outPat f+ y <- outPat g+ return (x ++ y)+outPat f = do+ c <- ST.get+ ST.put (succ c)+ return $ [PVar $ Ident [c]]++outRhs :: T.Type a -> State Char Exp+outRhs (Prod a b) = do+ x <- outRhs a+ y <- outRhs b+ return $ Tuple [x,y]+outRhs a = do+ c <- ST.get+ ST.put (succ c)+ return $ Var (UnQual (Ident [c]))++-- ** XML types++typeSignature :: [String] -> String -> T.Type a -> Decl+typeSignature news name t = TypeSig loc [Ident name] (TyApp typ (showType news t))+ where typ = TyCon $ Qual (ModuleName "Ori") $ Ident "Type"+typeExpression :: [String] -> String -> Decl+typeExpression news name = PatBind loc (PVar $ Ident name) Nothing (UnGuardedRhs $ Var (UnQual (Ident "typeof"))) (BDecls [])++schemaExpression :: String -> FilePath -> Decl+schemaExpression name s = PatBind loc (PVar $ Ident name) Nothing (UnGuardedRhs $ Lit $ String s) (BDecls [])++mainExpression :: Decl+mainExpression = PatBind loc (PVar $ Ident "main") Nothing (UnGuardedRhs rhs) (BDecls [])+ where rhs = App (App (App (App (App lensmenu srcSchema) tgtSchema) srcType) tgtType) transformation+ lensmenu = Var (UnQual (Ident "lensmenu"))+ srcSchema = Var (UnQual (Ident "srcSchema"))+ tgtSchema = Var (UnQual (Ident "tgtSchema"))+ srcType = Var (UnQual (Ident "srcType"))+ tgtType = Var (UnQual (Ident "tgtType"))+ transformation = Var (UnQual (Ident "transformation"))++-- ** point-free expressions++signature :: [String] -> String -> T.Type a -> T.Type b -> Decl+signature news name a b = TypeSig loc [Ident name] (TyApp (TyApp lens src) tgt)+ where lens = TyCon $ UnQual $ Ident "Lens"+ src = showType news a+ tgt = showType news b++expression :: [String] -> String -> T.Type a -> a -> Decl+expression news n t v = PatBind loc name Nothing (UnGuardedRhs $ showExp news t v) (BDecls [])+ where name = PVar $ Ident n++showType :: [String] -> T.Type a -> Ext.Type+showType news (NewData n f)+ | n `elem` news = TyCon $ Qual filename $ Ident $ hsname n+ | otherwise = TyParen $ TyApp (TyCon $ UnQual $ Ident "Fix") (showFctr news f)+showType news (Data "Maybe" (K One :+!: K a)) = TyParen $ TyApp (TyCon $ Qual (ModuleName "Ori") (Ident "Maybe")) (showType news a)+showType news d@(Data n f) = TyCon $ Qual (ModuleName "Ori") (Ident n)+showType news (T.List a) = TyList $ showType news a+showType news a = TyCon $ UnQual $ Ident $ show a++showFctr :: [String] -> Fctr f -> Ext.Type+showFctr news I = TyCon $ UnQual $ Ident "Id"+showFctr news L = TyCon $ Special ListCon+showFctr news (K c) = TyParen $ TyApp (TyCon $ UnQual $ Ident "Const") (showType news c)+showFctr news (f :*!: g) = TyParen $ TyInfix (showFctr news f) (UnQual (Symbol ":*:")) (showFctr news g)+showFctr news (f :+!: g) = TyParen $ TyInfix (showFctr news f) (UnQual (Symbol ":+:")) (showFctr news g)+showFctr news (f :@!: g) = TyParen $ TyInfix (showFctr news f) (UnQual (Symbol ":@:")) (showFctr news g)++showAnn :: [String] -> T.Type a -> Exp+showAnn news a = Paren $ ExpTypeSig loc name (TyApp tann $ showType news a)+ where name = Var $ UnQual $ Ident "ann"+ tann = TyCon $ UnQual $ Ident "Ann"++showAnnFix :: [String] -> Fctr f -> Exp+showAnnFix news fctr = Paren $ ExpTypeSig loc name (TyApp tann $ TyApp tfix $ showFctr news fctr)+ where name = Var $ UnQual $ Ident "ann"+ tann = TyCon $ UnQual $ Ident "Ann"+ tfix = TyCon $ UnQual $ Ident "Fix"++showExp :: [String] -> T.Type a -> a -> Exp+showExp news (Pf _) (FMAP_LNS fctr (Fun x y) f) = Paren $ App (App name (showAnnFix news fctr)) arg + where name = Var $ UnQual $ Ident "fmap_lns"+ arg = showExp news (Pf $ Lns x y) f+showExp news (Pf _) (FMAP fctr (Fun x y) f) = Paren $ App (App name (showAnnFix news fctr)) arg + where name = Var $ UnQual $ Ident "fmap"+ arg = showExp news (Pf $ Fun x y) f+showExp news t@(Pf _) v@(COMP _ _ _) = Paren $ showCompExp news t v+showExp news t@(Pf _) v@(COMP_LNS _ _ _) = Paren $ showCompExp news t v+showExp news (Pf (Lns _ a)) INN_LNS = Paren $ App name (showAnn news a)+ where name = Var $ UnQual $ Ident "inn_lns'"+showExp news (Pf (Fun _ a)) INN = Paren $ App name (showAnn news a)+ where name = Var $ UnQual $ Ident "inn'"+showExp news (Pf (Lns a _)) OUT_LNS = Paren $ App name (showAnn news a)+ where name = Var $ UnQual $ Ident "out_lns'"+showExp news (Pf (Fun a _)) OUT = Paren $ App name (showAnn news a)+ where name = Var $ UnQual $ Ident "out'"+showExp news (Pf _) TOP = Var $ UnQual $ Ident "undefined"+showExp news (Pf (Fun a@(dataFctr -> Just f) b)) (CATA g) = Paren $ App (App name (showAnn news a)) gen + where name = Var $ UnQual $ Ident "cata"+ gen = showExp news (Pf $ Fun (rep f b) b) g+showExp news (Pf (Fun a@(dataFctr -> Just f) b)) (PARA g) = Paren $ App (App name (showAnn news a)) gen+ where name = Var $ UnQual $ Ident "para"+ gen = showExp news (Pf $ Fun (rep f (Prod b a)) b) g+showExp news (Pf (Fun a b@(dataFctr -> Just f))) (ANA g) = Paren $ App (App name (showAnn news b)) gen+ where name = Var $ UnQual $ Ident "ana"+ gen = showExp news (Pf $ Fun a (rep f a)) g+showExp news (Pf (Lns a@(dataFctr -> Just f) b)) (CATA_LNS g) = Paren $ App (App name (showAnn news a)) gen+ where name = Var $ UnQual $ Ident "cata_lns"+ gen = showExp news (Pf $ Lns (rep f b) b) g+showExp news (Pf (Lns a b@(dataFctr -> Just f))) (ANA_LNS g) = Paren $ App (App name (showAnn news b)) gen+ where name = Var $ UnQual $ Ident "ana_lns"+ gen = showExp news (Pf $ Lns a (rep f a)) g+showExp news a@(Data s f) v = Paren $ App (App name (showAnn news a)) (showExp news (rep f a) (out v))+ where name = Var $ UnQual $ Ident "inn'"+showExp news a@(NewData s f) v+ | s `elem`news = Paren $ App (App (Var $ UnQual $ Ident "inn'") (showAnn news a)) (showExp news (rep f a) (out v))+ | otherwise = Paren $ App (Var $ UnQual $ Ident "Inn") (showExp news (rep f a) (out v))+showExp news t x = showExpSpine news (toSpine t x)++showCompExp :: [String] -> T.Type a -> a -> Exp+showCompExp news (Pf (Fun a c)) (COMP b f g) = InfixApp (showCompExp news (Pf $ Fun b c) f) comp (showCompExp news (Pf $ Fun a b) g)+ where comp = QVarOp (UnQual (Symbol "."))+showCompExp news (Pf (Lns a c)) (COMP_LNS b f g) = InfixApp (showCompExp news (Pf $ Lns b c) f) comp (showCompExp news (Pf $ Lns a b) g)+ where comp = QVarOp (UnQual (Symbol ".<"))+showCompExp news t f = showExp news t f++showExpSpine :: [String] -> Spine a -> Exp+showExpSpine news (Ap f@(Ap (_ `As` c) (a :| x)) (b :| y))+ | fixity c == Infix = Paren $ InfixApp (showExp news a x) (QVarOp (UnQual (Symbol $ name c))) (showExp news b y)+ | otherwise = Paren $ App (showExpSpine news f) (showExp news b y)+showExpSpine news (_ `As` c) = Var $ UnQual $ Ident $ name c+showExpSpine news (Ap f (a :| x)) = Paren $ App (showExpSpine news f) (showExp news a x)++hsname :: String -> String+hsname "" = ""+hsname ('@':x:xs) = "Att" ++ toUpper x : xs+hsname (x:xs) = toUpper x : xs
+ src/UI/LensMenu.hs view
@@ -0,0 +1,116 @@+-----------------------------------------------------------------------------+-- |+-- Module : UI.LensMenu+-- Copyright : (c) 2011 University of Minho+-- License : BSD3+--+-- Maintainer : hpacheco@di.uminho.pt+-- Stability : experimental+-- Portability : non-portable+--+-- Multifocal:+-- Bidirectional Two-level Transformation of XML Schemas+-- +-- Menu functions for generated lens executables.+--+-----------------------------------------------------------------------------++module UI.LensMenu where++import Data.Type+import Data.Spine+import Data.Equal+import Generics.Pointless.Lenses+import Language.XML.HaXmlAliases+import Language.XML.Type2Xml+import Language.XML.Xml2Type+import System.IO+import System.Environment+import System.Console.GetOpt+import UI.Menu++data Options = Options+ {+ optInputSourceFile :: Maybe FilePath+ , optInputTargetFile :: Maybe FilePath+ , optOutputFile :: Maybe FilePath+ , optDirection :: Bool+ }++startOpt :: Options+startOpt = Options+ { optInputSourceFile = Nothing+ , optInputTargetFile = Nothing+ , optOutputFile = Nothing+ , optDirection = False+ }++options :: Opts Options+options =+ [ Option "h" ["help"]+ (NoArg (\opt -> exitHelp options))+ "Show usage info"+ , Option "s" ["source"]+ (ReqArg (\arg opt -> return opt { optInputSourceFile = Just arg }) "FILE")+ "Input XML Source File"+ , Option "t" ["target"]+ (ReqArg (\arg opt -> return opt { optInputTargetFile = Just arg }) "FILE")+ "Input XML Target File"+ , Option "o" ["output"]+ (ReqArg (\arg opt -> return opt { optOutputFile = Just arg }) "FILE")+ "Output XML File (default: stdout)"+ , Option "f" ["forward"]+ (NoArg (\opt -> return opt { optDirection = True }))+ "Run the bidirectional transformation in the forward direction (requires an source file)"+ , Option "b" ["backward"]+ (NoArg (\opt -> return opt { optDirection = False }))+ "Run the bidirectional transformation in the backward direction (requires a source file and a modified target file)"+ ]++lensmenu :: FilePath -> FilePath -> Type a -> Type b -> Lens a b -> IO ()+lensmenu srcSchema tgtSchema srcType tgtType lns = do+ argv <- getArgs+ opts <- parseOptions startOpt options argv+ if optDirection opts+ then forward opts srcSchema tgtSchema srcType tgtType lns+ else backward opts srcSchema tgtSchema srcType tgtType lns++forward :: Options -> FilePath -> FilePath -> Type a -> Type b -> Lens a b -> IO ()+forward opts srcSchema tgtSchema srcType tgtType lns = do+ putStrLn "Running forward transformation..."+ -- parse XML Source File+ s <- run "input XML source file missing" $ optInputSourceFile opts+ srcFile <- readFile s+ let srcDoc = parseXml s srcFile+ -- translate XML source into an Haskell value+ src <- run "Error translating XML source file" $ xml2value srcType srcDoc+ -- run forward transformation+ let tgt = get lns src+ -- print output XML target+ outputHandle <- maybe (return stdout) (\f -> openFile f WriteMode) (optOutputFile opts)+ tgtDoc <- run "Error printing XML target file" $ value2xml tgtSchema tgtType tgt+ hPutStrLn outputHandle $ renderXml tgtDoc+ hClose outputHandle++backward :: Options -> FilePath -> FilePath -> Type a -> Type b -> Lens a b -> IO ()+backward opts srcSchema tgtSchema srcType tgtType lns = do+ putStrLn "Running backward transformation..."+ -- parse XML Source File+ s <- run "input XML source file missing" $ optInputSourceFile opts+ srcFile <- readFile s+ let srcDoc = parseXml s srcFile+ -- translate XML source into an Haskell value+ src <- run "Error translating XML source file" $ xml2value srcType srcDoc+ -- parse XML Target File+ t <- run "input XML target file missing" $ optInputTargetFile opts+ tgtFile <- readFile t+ let tgtDoc = parseXml t tgtFile+ -- translate XML target into an Haskell value+ tgt <- run "Error translating XML target file" $ xml2value tgtType tgtDoc+ -- run backward transformation+ let src' = put lns (tgt,src)+ -- print output XML target+ outputHandle <- maybe (return stdout) (\f -> openFile f WriteMode) (optOutputFile opts)+ srcDoc' <- run "Error printing XML modified source file" $ value2xml srcSchema srcType src'+ hPutStrLn outputHandle $ renderXml srcDoc'+ hClose outputHandle
+ src/UI/Menu.hs view
@@ -0,0 +1,50 @@+-----------------------------------------------------------------------------+-- |+-- Module : UI.Menu+-- Copyright : (c) 2011 University of Minho+-- License : BSD3+--+-- Maintainer : hpacheco@di.uminho.pt+-- Stability : experimental+-- Portability : non-portable+--+-- Multifocal:+-- Bidirectional Two-level Transformation of XML Schemas+-- +-- General ui menu configuration functions.+--+-----------------------------------------------------------------------------++module UI.Menu where++import System.IO+import System.Environment+import System.Console.GetOpt+import System.Exit++type Opts a = [OptDescr (a -> IO a)]++parseOptions :: a -> Opts a -> [String] -> IO a+parseOptions start opts argv = case getOpt RequireOrder opts argv of+ (optsActions,rest,[]) -> foldl (>>=) (return start) optsActions+ (_,_,errs) -> do+ prg <- getProgName+ ioError (userError (concat errs ++ usageInfo ("Usage: "++prg++" [OPTION...] files...") opts))++run :: String -> Maybe a -> IO a+run err = maybe (error err) return+ +-- | Function that prints the help usage and returns with a success code (used+-- when the help program option is specified.+exitHelp :: Opts a -> IO a+exitHelp opts = do+ showHelp opts+ exitWith ExitSuccess++-- | Function that prints the program usage to the sdtderr using the standard+-- 'usageInfo' function.+showHelp :: Opts a -> IO ()+showHelp opts = do+ prg <- getProgName+ hPutStrLn stderr (usageInfo ("Usage: "++prg++" [OPTION...]") opts)+ hFlush stderr