diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -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 + + + diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/dist/build/Language/TLT/TltLexer.hs b/dist/build/Language/TLT/TltLexer.hs new file mode 100644 --- /dev/null +++ b/dist/build/Language/TLT/TltLexer.hs @@ -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 "" #-} +{-# LINE 1 "" #-} +{-# 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 "" #-} +{-# LINE 1 "" #-} +{-# 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 diff --git a/dist/build/Language/TLT/TltParser.hs b/dist/build/Language/TLT/TltParser.hs new file mode 100644 --- /dev/null +++ b/dist/build/Language/TLT/TltParser.hs @@ -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 "" #-} +{-# LINE 1 "" #-} +{-# 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. diff --git a/examples/company.2lt b/examples/company.2lt new file mode 100644 --- /dev/null +++ b/examples/company.2lt @@ -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" +)) diff --git a/examples/company.xml b/examples/company.xml new file mode 100644 --- /dev/null +++ b/examples/company.xml @@ -0,0 +1,41 @@ + + + + Research + + + + Ralf +
Amesterdam
+ + 8000 + + + + + Joost +
Amesterdam
+ + 1000 + + + + Marlow +
Cambridge
+ + 2000 + + + Strategy + + + + Blair +
London
+ + 10000 + + + + + diff --git a/examples/company.xsd b/examples/company.xsd new file mode 100644 --- /dev/null +++ b/examples/company.xsd @@ -0,0 +1,44 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/examples/imdb.2lt b/examples/imdb.2lt new file mode 100644 --- /dev/null +++ b/examples/imdb.2lt @@ -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"))) +))) diff --git a/examples/imdb.xml b/examples/imdb.xml new file mode 100644 --- /dev/null +++ b/examples/imdb.xml @@ -0,0 +1,33 @@ + + + + 1994 + Pulp Fiction + + Quentin Tarantino + + + + + 2003 + Kill Bill: Vol. 1 + + Quentin Tarantino + + + + + 2004 + The Punisher + Jonathan Hensleigh + + + Uma Thurman + + 2003 + Kill Bill: Vol. 1 + The Bride + + + + diff --git a/examples/imdb.xsd b/examples/imdb.xsd new file mode 100644 --- /dev/null +++ b/examples/imdb.xsd @@ -0,0 +1,76 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/examples/imdb2mod.xml b/examples/imdb2mod.xml new file mode 100644 --- /dev/null +++ b/examples/imdb2mod.xml @@ -0,0 +1,37 @@ + +1994Pulp FictionQuentin Tarantino2003Kill Bill: Vol. 1Quentin Tarantino2004The PunisherJonathan Hensleigh + 2012Sherlock Holmes: Game of ShadowsGuy RitchieUma ThurmanSaturn Award - Best Actress diff --git a/multifocal.cabal b/multifocal.cabal new file mode 100644 --- /dev/null +++ b/multifocal.cabal @@ -0,0 +1,49 @@ +Name: multifocal +Version: 0.0.1 +License: BSD3 +License-file: LICENSE +Author: Hugo Pacheco , Alcino Cunha +Maintainer: Hugo Pacheco +Synopsis: Bidirectional Two-level Transformation of XML Schemas +Description: Library that implements a two-level transformation () 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 diff --git a/src/Data/Transform/TwoLevel.hs b/src/Data/Transform/TwoLevel.hs new file mode 100644 --- /dev/null +++ b/src/Data/Transform/TwoLevel.hs @@ -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 + diff --git a/src/Language/TLT/Tlt2Strat.hs b/src/Language/TLT/Tlt2Strat.hs new file mode 100644 --- /dev/null +++ b/src/Language/TLT/Tlt2Strat.hs @@ -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) diff --git a/src/Language/TLT/TltLexer.x b/src/Language/TLT/TltLexer.x new file mode 100644 --- /dev/null +++ b/src/Language/TLT/TltLexer.x @@ -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 + +} diff --git a/src/Language/TLT/TltParser.y b/src/Language/TLT/TltParser.y new file mode 100644 --- /dev/null +++ b/src/Language/TLT/TltParser.y @@ -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 +} diff --git a/src/Language/TLT/TltSyntax.hs b/src/Language/TLT/TltSyntax.hs new file mode 100644 --- /dev/null +++ b/src/Language/TLT/TltSyntax.hs @@ -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 diff --git a/src/Language/XML/HaXmlAliases.hs b/src/Language/XML/HaXmlAliases.hs new file mode 100644 --- /dev/null +++ b/src/Language/XML/HaXmlAliases.hs @@ -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 + diff --git a/src/Language/XML/Type2Xml.hs b/src/Language/XML/Type2Xml.hs new file mode 100644 --- /dev/null +++ b/src/Language/XML/Type2Xml.hs @@ -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]) diff --git a/src/Language/XML/Type2Xsd.hs b/src/Language/XML/Type2Xsd.hs new file mode 100644 --- /dev/null +++ b/src/Language/XML/Type2Xsd.hs @@ -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) diff --git a/src/Language/XML/Xml2Type.hs b/src/Language/XML/Xml2Type.hs new file mode 100644 --- /dev/null +++ b/src/Language/XML/Xml2Type.hs @@ -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 diff --git a/src/Language/XML/Xsd2Type.hs b/src/Language/XML/Xsd2Type.hs new file mode 100644 --- /dev/null +++ b/src/Language/XML/Xsd2Type.hs @@ -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 + diff --git a/src/Language/XPath/HXTAliases.hs b/src/Language/XPath/HXTAliases.hs new file mode 100644 --- /dev/null +++ b/src/Language/XPath/HXTAliases.hs @@ -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 diff --git a/src/Language/XPath/XPath2Pf.hs b/src/Language/XPath/XPath2Pf.hs new file mode 100644 --- /dev/null +++ b/src/Language/XPath/XPath2Pf.hs @@ -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) + diff --git a/src/UI/CmdLine.hs b/src/UI/CmdLine.hs new file mode 100644 --- /dev/null +++ b/src/UI/CmdLine.hs @@ -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 diff --git a/src/UI/GenHaskell.hs b/src/UI/GenHaskell.hs new file mode 100644 --- /dev/null +++ b/src/UI/GenHaskell.hs @@ -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 diff --git a/src/UI/LensMenu.hs b/src/UI/LensMenu.hs new file mode 100644 --- /dev/null +++ b/src/UI/LensMenu.hs @@ -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 diff --git a/src/UI/Menu.hs b/src/UI/Menu.hs new file mode 100644 --- /dev/null +++ b/src/UI/Menu.hs @@ -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