shuffle (empty) → 0.1.0.0
raw patch · 18 files changed
+2768/−0 lines, 18 filesdep +arraydep +basedep +containersbuild-type:Customsetup-changed
Dependencies added: array, base, containers, directory, network, process, uhc-util, uuagc, uuagc-cabal, uulib
Files
- LICENSE +41/−0
- Setup.hs +6/−0
- shuffle.cabal +47/−0
- src/Shuffle.hs +356/−0
- src/UHC/Shuffle/AspectExpr.ag +20/−0
- src/UHC/Shuffle/AspectExprAbsSyn.ag +17/−0
- src/UHC/Shuffle/AspectExprEval.ag +44/−0
- src/UHC/Shuffle/CDoc.ag +186/−0
- src/UHC/Shuffle/CDocAbsSyn.ag +23/−0
- src/UHC/Shuffle/CDocCommon.hs +29/−0
- src/UHC/Shuffle/CDocCommonAG.ag +21/−0
- src/UHC/Shuffle/CDocInline.ag +96/−0
- src/UHC/Shuffle/CDocSubst.ag +53/−0
- src/UHC/Shuffle/ChunkAbsSyn.ag +95/−0
- src/UHC/Shuffle/ChunkParser.hs +449/−0
- src/UHC/Shuffle/Common.hs +429/−0
- src/UHC/Shuffle/MainAG.ag +839/−0
- uuagc_options +17/−0
+ LICENSE view
@@ -0,0 +1,41 @@+The Utrecht Haskell Compiler (UHC) License+==========================================++UHC follows the advertisement free BSD license, of which the basic+template can be found here:++ http://www.opensource.org/licenses/bsd-license.php++UHC uses the following libraries with their own license:+- Library code from the GHC distribution, see comment in the modules in ehclib++License text+============++Copyright (c) 2009-2010, Utrecht University, Department of Information+and Computing Sciences, Software Technology group++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.++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+HOLDER 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.
+ Setup.hs view
@@ -0,0 +1,6 @@+import Distribution.Simple (defaultMainWithHooks)+import Distribution.Simple.UUAGC (uuagcLibUserHook)+import UU.UUAGC (uuagc)++main :: IO ()+main = defaultMainWithHooks (uuagcLibUserHook uuagc)
+ shuffle.cabal view
@@ -0,0 +1,47 @@+Name: shuffle+Version: 0.1.0.0+Copyright: Utrecht University, Department of Information and Computing Sciences, Software Technology group+Description: Shuffle tool used by UHC (Utrecht Haskell Compiler)+Synopsis: Shuffle tool for UHC+Homepage: https://github.com/UU-ComputerScience/shuffle+Bug-Reports: https://github.com/UU-ComputerScience/shuffle/issues+License: BSD3+License-file: LICENSE+Author: UHC Team+Maintainer: uhc-developers@lists.science.uu.nl+Category: Development+Build-Type: Custom+Cabal-Version: >= 1.8+Extra-Source-Files: uuagc_options,+ src/UHC/Shuffle/AspectExprAbsSyn.ag,+ src/UHC/Shuffle/CDocAbsSyn.ag,+ src/UHC/Shuffle/CDocCommonAG.ag,+ src/UHC/Shuffle/ChunkAbsSyn.ag++Source-Repository head+ Type: git+ Location: https://github.com/UU-ComputerScience/shuffle.git++Executable shuffle+ Hs-Source-Dirs: src+ Main-Is: Shuffle.hs+ Extensions: RankNTypes, TypeSynonymInstances, FlexibleInstances, FlexibleContexts+ Other-Modules: UHC.Shuffle.AspectExpr,+ UHC.Shuffle.AspectExprEval,+ UHC.Shuffle.Common,+ UHC.Shuffle.CDoc,+ UHC.Shuffle.CDocCommon,+ UHC.Shuffle.CDocSubst,+ UHC.Shuffle.CDocInline,+ UHC.Shuffle.ChunkParser,+ UHC.Shuffle.MainAG+ Build-Depends: base >= 4 && < 5,+ containers >= 0.4,+ directory >= 1.2,+ network >= 2.3,+ process >= 1.1,+ array >= 0.4,+ uulib >= 0.9,+ uuagc >= 0.9.40.3,+ uuagc-cabal >= 1.0.3.0,+ uhc-util >= 0.1.0.1
+ src/Shuffle.hs view
@@ -0,0 +1,356 @@+-------------------------------------------------------------------------+-- Main+-------------------------------------------------------------------------++module Main where++import qualified Data.Set as Set+import qualified Data.Map as Map+import Data.Map(Map)+import Data.Set(Set)+import System.Exit+import System.Environment+import System.IO+import System.Console.GetOpt+import UHC.Util.ParseUtils+import UHC.Util.DependencyGraph+import UHC.Util.FPath+import UHC.Util.Pretty+import UHC.Shuffle.Common+import UHC.Shuffle.MainAG+import UHC.Shuffle.ChunkParser+import UHC.Shuffle.CDoc+import UHC.Shuffle.CDocSubst+import Data.Char++-------------------------------------------------------------------------+-- main+-------------------------------------------------------------------------++type FPathWithAlias = (Maybe String,FPath)++main :: IO ()+main+ = do { args <- getArgs+ ; let oo@(o,n,errs) = getOpt Permute cmdLineOpts args+ opts = foldr ($) defaultOpts o+ ; if optHelp opts+ then putStrLn (usageInfo "Usage shuffle [options] [file ([alias=]file)*|-]\n\noptions:" cmdLineOpts)+ else if null errs+ then let (f,frest) = if null n then (emptyFPath,[]) else if head n == "-" then (emptyFPath,tail n) else (mkFPath (head n),tail n)+ in if optGenDeps opts+ then genDeps f opts+ else doCompile (Nothing,f) (map mkFPathAlias frest) opts+ else putStr (head errs)+ }+ where mkFPathAlias s+ = case break (=='=') s of+ (a,('=':f)) -> (Just a ,mkFPath f)+ _ -> (Nothing,mkFPath s)++readShFile :: FPathWithAlias -> Opts -> IO (FPathWithAlias,T_AGItf)+readShFile (a,fp) opts+ = do { (fp,fh) <- fpathOpenOrStdin fp+ ; txt <- hGetContents fh+ ; let toks = scan shuffleScanOpts ScSkip txt+ ; let (pres,perrs) = parseToResMsgs pAGItf toks+ ; if null perrs+ then return ((a,fp),pres)+ else do { mapM_ (hPutStrLn stderr . show) perrs+ ; exitFailure+ }+ }++doCompile' :: FPath -> Opts -> IO Syn_AGItf+doCompile' f opts+ = do { ((_, fp), pres) <- readShFile (Nothing,f) opts+ ; return (wrapAG_T opts fp Set.empty Map.empty pres)+ }++doCompile :: FPathWithAlias -> [FPathWithAlias] -> Opts -> IO ()+doCompile fpa fpaRest opts+ = do { xrefExceptFileContent+ <- case optMbXRefExcept opts of+ Just f -> do c <- readFile f+ return (Set.unions . map (Set.fromList . words) . lines $ c)+ Nothing -> return Set.empty+ ; allPRes@(((_,fp'),pres):restPRes) <- mapM (\f -> readShFile f opts) (fpa:fpaRest)+ ; let (nmChMp,hdL) = allNmChMpOf allPRes+ fb = fpathBase fp'+ res = wrapSem fp' xrefExceptFileContent Map.empty pres+ bld = selBld opts res+ topChNmS = Set.unions [ Set.map (mkFullNm fb) . Map.keysSet . bldNmChMp $ b | b <- bld ]+ ; subsChNmS <- putBld nmChMp bld+ ; let allChNmS = subsChNmS `Set.union` topChNmS+ hdL' = [ h | (n,h) <- hdL, n `Set.member` allChNmS ]+ ; putHideBld opts fb nmChMp hdL'+ }+ where mkFullNm b n = mkNm b `nmApd` n+ selBld opts res+ = if optAG opts then bldAG_Syn_AGItf res+ else if optHS opts || optPlain opts then bldHS_Syn_AGItf res+ else bldLaTeX_Syn_AGItf res+ putErrs em+ = if Map.null em+ then return ()+ else do { mapM_ (\e -> hPutPPFile stderr (pp e) 80) . Map.elems $ em+ ; exitFailure+ }+ putBld nmChMp b+ = if not (null b)+ then do { b' <- mapM (cdocSubstInline nmChMp . bldCD) $ b+ ; let (bs,nms,errml) = unzip3 b'+ errm = Map.unions errml+ ; putErrs errm+ ; mapM_ (cdPut stdout) bs+ ; return (Set.unions nms)+ }+ else return Set.empty+ putHideBld opts fb nmChMp hdL+ = case optChDest opts of+ (ChHere,_) -> return ()+ (ChHide,f) -> do { let (d,_,es) = cdocSubst nmChMp . cdVer $ hdL+ ; putErrs es+ ; h <- openFile f' WriteMode+ ; cdPut h d+ ; hClose h+ }+ where f' = if null f then (fb ++ ".hide") else f+ wrapSem fp xr nmChMp pres = wrapAG_T opts fp xr nmChMp pres+ allNmChMpOf pres+ = (Map.unions m1,concat m2)+ where (m1,m2)+ = unzip+ [ (Map.mapKeys mkN (Map.unions (nMp:bMpL)) `Map.union` nMp,concat hdLL)+ | ((ma,fp),pr) <- pres+ , let nmPre = maybe (fpathBase fp) id ma+ mkN = mkFullNm (mkNm nmPre)+ r = wrapSem fp Set.empty Map.empty pr+ nMp = gathNmChMp_Syn_AGItf r+ (bMpL,hdLL) = unzip [ (bldNmChMp b,[ (mkN n,h) | (n,h) <- bldHideCD b]) | b <- selBld opts r ]+ ]++trans :: Monad m => (String -> m [String]) -> [String] -> m (Map String [String])+trans f+ = trans' Map.empty+ where+ trans' mp []+ = return mp+ trans' mp keys+ = do rs <- mapM f keys+ let mp' = Map.fromList (zip keys rs) `Map.union` mp+ let keys' = filter (\k -> not (Map.member k mp')) (concat rs)+ trans' mp' keys'++genDeps :: FPath -> Opts -> IO ()+genDeps f opts+ = do filenames <- do c <- readFile (fpathToStr f)+ return $ filter (not . null) (lines c)+ depMap <- trans getDeps filenames+ let depGraph = mkDpdGrFromEdgesMpPadMissing depMap+ let depL = [(r, filter (not . (`elem` filenames)) . stripIgn . Set.toList $ dgReachableFrom depGraph r) | r <- filenames ]+ genDepsMakefile depL opts+ return ()+ where+ mp = optDepTerm opts+ ignSet = optDepIgn opts+ stripIgn = filter (not . flip Set.member ignSet . stripDir)++ getDeps fname+ = Map.findWithDefault+ ( do let baseDir = optDepBaseDir opts+ let baseDir' = if last baseDir /= '/' then baseDir ++ "/" else baseDir+ let fpath = fpathSetSuff "cag" $ mkFPath (baseDir' ++ fname)+ res <- doCompile' fpath opts+ return (deps_Syn_AGItf res)+ ) name (Map.map return mp)+ where+ name = fpathBase . mkFPath $ fname++stripDir :: String -> String+stripDir = fpathToStr . fpathRemoveDir . mkFPath++genDepsMakefile :: [(String, [String])] -> Opts -> IO ()+genDepsMakefile deps opts+ = do mapM_ (putStrLn . mkDep) deps+ putStrLn ""+ putStrLn mkOrigDepList+ putStrLn ""+ putStrLn mkDerivDepList+ putStrLn ""+ putStrLn mkDepList+ putStrLn ""+ putStrLn mkMainList+ where+ -- from options+ namePrefix = optDepNamePrefix opts+ srcPrefix = optDepSrcVar opts+ dstPrefix = optDepDstVar opts+ depListVar = optDepDpdsVar opts+ mainListVar = optDepMainVar opts+ origListVar = optDepOrigDpdsVar opts+ derivListVar = optDepDerivDpdsVar opts+ + -- shared suffixes+ suffMainSrcCag = "_MAIN_SRC_CAG"+ suffDpdsSrcCag = "_DPDS_SRC_CAG"+ suffDpdsOrigCag = "_DPDS_ORIG_CAG"+ suffDpdsDerivAg = "_DPDS_DERIV_AG"++ -- making dependency+ mkDep (file, deps)+ = let name = encode file+ fileWithoutExt = stripExt file+ deps' = map stripExt deps+ ignSet = optDepIgn opts+ in unlines+ [ name ++ suffMainSrcCag ++ " := $(patsubst %,$(" ++ srcPrefix ++ ")%.cag," ++ fileWithoutExt ++ ")"+ , name ++ suffDpdsSrcCag ++ " := $(patsubst %,$(" ++ srcPrefix ++ ")%.cag," ++ unwords deps' ++ ")"+ , name ++ suffDpdsOrigCag ++ " := $(patsubst %,$(" ++ srcPrefix ++ ")%.cag," ++ unwords (filter (not . flip Set.member ignSet . stripDir) deps') ++ ")"+ , name ++ suffDpdsDerivAg ++ " := $(patsubst %,$(" ++ dstPrefix ++ ")%.ag," ++ unwords deps' ++ ")"+ , "$(patsubst $(" ++ srcPrefix ++ ")%.cag,$(" ++ dstPrefix ++ ")%.hs,$(" ++ name ++ suffMainSrcCag ++ ")) : $(" ++ name ++ suffDpdsDerivAg ++ ")"+ ]++ -- making lists+ mkL doSort var suff deps+ = var ++ " := " ++ s (unwords (map ((\n -> "$(" ++ n ++ suff ++ ")") . encode . fst) deps))+ where s x | doSort = "$(sort " ++ x ++ ")"+ | otherwise = x++ mkDerivDepList = mkL True derivListVar suffDpdsDerivAg deps+ mkOrigDepList = mkL True origListVar suffDpdsOrigCag deps+ mkDepList = mkL True depListVar suffDpdsSrcCag deps+ mkMainList = mkL False mainListVar suffMainSrcCag deps++ encode n = namePrefix ++ map (toUnder . toUpper) (stripExt n)++ stripExt n+ | '.' `elem` n = reverse $ tail $ dropWhile (/= '.') $ reverse n+ | otherwise = n++ toUnder c+ | isAlphaNum c = c+ | otherwise = '_'++-------------------------------------------------------------------------+-- Cmdline opts+-------------------------------------------------------------------------++cmdLineOpts+ = [ Option "a" ["ag"] (NoArg oAG)+ "generate code for ag, default=no"+ , Option "h" ["hs"] (NoArg oHS)+ "generate code for haskell, default=no"+ , Option "l" ["latex"] (NoArg oLaTeX)+ "generate code for latex, default=no"+ , Option "" ["preamble"] (OptArg oPreamble "yes|no")+ "include preamble (marked by version=0), default=yes"+ , Option "" ["line"] (OptArg oLinePragmas "yes|no")+ "insert #LINE pragmas, default=no"+ , Option "p" ["plain"] (NoArg oPlain)+ "generate plain code, default=no"+ , Option "" ["text2text"] (NoArg oGenT2T)+ "generate code for haskell, default=no"+ , Option "" ["index"] (NoArg oIndex)+ "combined with latex, generate index entries, default=no"+ , Option "" ["gen"] (ReqArg oGenReqm "all|<nr>|(<nr> <aspect>*) (to be obsolete, renamed to --gen-reqm)")+ "generate for version, default=none"+ , Option "g" ["gen-reqm"] (ReqArg oGenReqm "all|<nr>|(<nr> <aspect>*)")+ "generate for version, default=none"+ , Option "" ["compiler"] (ReqArg oCompiler "<compiler version>")+ "Version of the GHC compiler, i.e. 6.6"+ , Option "" ["hidedest"] (ReqArg oHideDest "here|appx=<file>")+ "destination of text marked as 'hide', default=here"+ , Option "" ["order"] (ReqArg oVariantOrder "<order-spec> (to be obsolete, renamed to --variant-order)")+ "variant order"+ , Option "" ["variant-order"] (ReqArg oVariantOrder "<order-spec>")+ "variant order"+ , Option "b" ["base"] (ReqArg oBase "<name>")+ "base name, default=derived from filename"+ , Option "" ["xref-except"] (ReqArg oXRefExcept "<filename>")+ "file with list of strings not to be cross ref'd"+ , Option "" ["help"] (NoArg oHelp)+ "output this help"+ , Option "" ["dep"] (NoArg oDep)+ "output dependencies"+ , Option "" ["depnameprefix"] (OptArg oDepNamePrefix "<name>")+ "Prefix of generated makefile vars."+ , Option "" ["depsrcvar"] (OptArg oDepSrcVar "<name>")+ "Source base-directory"+ , Option "" ["depdstvar"] (OptArg oDepDstVar "<name>")+ "Destination base-directory"+ , Option "" ["depmainvar"] (OptArg oDepMainVar "<name>")+ "Varname for the list of main files"+ , Option "" ["depdpdsvar"] (OptArg oDepDpdsVar "<name>")+ "Varname for the list of dependencies"+ , Option "" ["deporigdpdsvar"] (OptArg oDepOrigDpdsVar "<name>")+ "Varname for the list of original dependencies"+ , Option "" ["depderivdpdsvar"] (OptArg oDepDerivDpdsVar "<name>")+ "Varname for the list of derived dependencies"+ , Option "" ["depbase"] (OptArg oDepBaseDir "<dir>")+ "Root directory for the dependency generation"+ , Option "" ["depign"] (OptArg oDepIgn "(<file> )*")+ "Totally ignored dependencies"+ , Option "" ["depterm"] (OptArg oDepTerm "(<file> => <dep>+ ,)*")+ "Dependency ignore list (or terminals)"+ , Option "" ["lhs2tex"] (OptArg oLhs2tex "yes|no")+ "wrap chunks in lhs2tex's code environment, default=yes"+ , Option "" ["agmodheader"] (OptArg oAGModHeader "yes|no")+ "generate AG MODULE headers instead of Haskell module headers"+ , Option "" ["def"] (ReqArg oDef "key:value")+ "define key/value pair, alternate form: key=value"+ ]+ where oAG o = o {optAG = True}+ oHS o = o {optHS = True}+ oPreamble ms o = yesno (\f o -> o {optPreamble = f}) ms o+ oLinePragmas ms o = yesno (\f o -> o {optLinePragmas = f}) ms o+ oLaTeX o = o {optLaTeX = True}+ oPlain o = o {optPlain = True}+ oGenT2T o = o {optGenText2Text = True}+ oIndex o = o {optIndex = True}+ oCompiler s o = o {optCompiler = map read (words (map (\c -> if c == '.' then ' ' else c) s))}+ oLhs2tex ms o = yesno' ChWrapCode ChWrapPlain (\f o -> o {optWrapLhs2tex = f}) ms o+ oBase s o = o {optBaseName = Just s}+ oVariantOrder s o = o {optVariantRefOrder = parseAndGetRes pVariantRefOrder s}+ oXRefExcept s o = o {optMbXRefExcept = Just s}+ oGenReqm s o = case dropWhile isSpace s of+ "all" -> o {optGenReqm = VReqmAll}+ (c:_) | isDigit c -> o {optGenReqm = parseAndGetRes pVariantReqmRef s}+ | c == '(' -> o {optGenReqm = parseAndGetRes pVariantReqm s}+ _ -> o {optGenReqm = VReqmAll}+ oHideDest s o = case s of+ "here" -> o+ ('a':'p':'p':'x':'=':f) -> o {optChDest = (ChHide,f)}+ _ -> o+ oHelp o = o {optHelp = True}+ oDep o = o {optGenDeps = True}+ oDepNamePrefix ms o = o { optDepNamePrefix = maybe "FILE_" id ms }+ oDepSrcVar ms o = o { optDepSrcVar = maybe "SRC_VAR" id ms }+ oDepDstVar ms o = o { optDepDstVar = maybe "DST_VAR" id ms }+ oDepMainVar ms o = o { optDepMainVar = maybe "FILES" id ms }+ oDepDpdsVar ms o = o { optDepDpdsVar = maybe "DPDS" id ms }+ oDepOrigDpdsVar ms o = o { optDepOrigDpdsVar = maybe "ORIG_DPDS" id ms }+ oDepDerivDpdsVar ms o = o { optDepDerivDpdsVar = maybe "DERIV_DPDS" id ms }+ oDepBaseDir ms o = o { optDepBaseDir = maybe "./" id ms }+ oDepTerm ms o = o { optDepTerm = maybe Map.empty (Map.fromList . parseDeps) ms }+ oDepIgn ms o = o { optDepIgn = maybe Set.empty (Set.fromList . words) ms }+ oAGModHeader ms o = yesno (\f o -> o {optAGModHeader = f}) ms o+ oDef s o = case break (\c -> c == ':' || c == '=') s of+ (k,(_:v)) -> o {optDefs = Map.insert k v (optDefs o)}+ _ -> o+ yesno' y n updO ms o+ = case ms of+ Just "yes" -> updO y o+ Just "no" -> updO n o+ _ -> o+ yesno = yesno' True False++ parseDeps "" = []+ parseDeps (',' : rest) = parseDeps rest+ parseDeps s+ = let (s',rest) = break (==',') s+ in parseDep s' : parseDeps rest++ parseDep s+ = let (term,_:deps) = break (=='>') s+ in (term, words deps)
+ src/UHC/Shuffle/AspectExpr.ag view
@@ -0,0 +1,20 @@+-------------------------------------------------------------------------+-- AspectExpr AST interface to Haskell+-------------------------------------------------------------------------++MODULE {UHC.Shuffle.AspectExpr} {}+{+import System.IO+import qualified Data.Set as Set+}++INCLUDE "AspectExprAbsSyn.ag"++-------------------------------------------------------------------------+-- Used defs+-------------------------------------------------------------------------++{+type AspectRef = String+type AspectRefReqd = Set.Set AspectRef+}
+ src/UHC/Shuffle/AspectExprAbsSyn.ag view
@@ -0,0 +1,17 @@+-------------------------------------------------------------------------+-- Aspect expr AST+-------------------------------------------------------------------------++-- Outside itf+DATA AGAspectExprItf+ | AGItf aexp : AspectExpr++DATA AspectExpr+ | True+ | Requires asp : {String}+ | Or asp1 : AspectExpr+ asp2 : AspectExpr+ | And asp1 : AspectExpr+ asp2 : AspectExpr++DERIVING * : Show, Eq, Ord
+ src/UHC/Shuffle/AspectExprEval.ag view
@@ -0,0 +1,44 @@+-------------------------------------------------------------------------+-- Evaluation of AspectExpr, given a set of AspectRef+-------------------------------------------------------------------------++MODULE {UHC.Shuffle.AspectExprEval} {aspexpIsAccepted}+{+import qualified Data.Set as Set+import qualified Data.Map as Map+import UHC.Shuffle.AspectExpr+}++INCLUDE "AspectExprAbsSyn.ag"++WRAPPER AGAspectExprItf++{+wrapAGAspectExpr_T :: AspectRefReqd -> T_AGAspectExprItf -> Syn_AGAspectExprItf+wrapAGAspectExpr_T givenRefs d+ = wrap_AGAspectExprItf d+ (Inh_AGAspectExprItf+ { givenRefs_Inh_AGAspectExprItf = givenRefs+ })++wrapAspectExpr :: AspectRefReqd -> AspectExpr -> Syn_AGAspectExprItf+wrapAspectExpr givenRefs d = wrapAGAspectExpr_T givenRefs (sem_AGAspectExprItf (AGAspectExprItf_AGItf d))++aspexpIsAccepted :: AspectRefReqd -> AspectExpr -> Bool+aspexpIsAccepted givenRefs d+ = (isAccepted_Syn_AGAspectExprItf r)+ where r = wrapAspectExpr givenRefs d+}++-------------------------------------------------------------------------+-- CRef subst in AspectExpr+-------------------------------------------------------------------------++ATTR AspectExpr AGAspectExprItf [ givenRefs: AspectRefReqd | | isAccepted: Bool ]++SEM AspectExpr+ | True lhs . isAccepted = True+ | Requires lhs . isAccepted = @asp `Set.member` @lhs.givenRefs+ | Or lhs . isAccepted = @asp1.isAccepted || @asp2.isAccepted+ | And lhs . isAccepted = @asp1.isAccepted && @asp2.isAccepted+
+ src/UHC/Shuffle/CDoc.ag view
@@ -0,0 +1,186 @@+-------------------------------------------------------------------------+-- CDoc AST interface to Haskell+-------------------------------------------------------------------------++MODULE {UHC.Shuffle.CDoc} {}+{+import UHC.Shuffle.Common+import System.IO+import qualified Data.Map as Map+}++INCLUDE "CDocAbsSyn.ag"++-------------------------------------------------------------------------+-- Make CDoc+-------------------------------------------------------------------------++{+type FromVariantReqm a = VariantReqm -> a+type MkCDoc = FromVariantReqm (Maybe CDoc)++instance Show MkCDoc where+ show _ = "MkCDoc"+}++-------------------------------------------------------------------------+-- Chunk doc utils+-------------------------------------------------------------------------++{+cdHor :: CD a => [a] -> CDoc+cdHor = foldr CDoc_Hor CDoc_Emp . map cd++cdVer :: CD a => [a] -> CDoc+cdVer = foldr CDoc_Ver CDoc_Emp . map cd++{-+cdLines :: CDoc -> [String]+cdLines d+ = lns d+ where ln l CDoc_Emp = (l,CDoc_Emp)+ ln l (CDoc_Str s) = (s:l,CDoc_Emp)+ ln l (CDoc_Hor d1 d2)+ = case ln l d1 of+ (l1,CDoc_Emp) -> ln l1 d2+ r -> r+ ln l (CDoc_Ver d1 d2)+ = case ln l d1 of+ (l1,CDoc_Emp) -> (l1,d2)+ (l1,dr) -> (l1,CDoc_Ver dr d2)+ lns CDoc_Emp = []+ lns d = let (l,d') = ln [] d in concat (reverse l) : lns d'++cdPut' :: Handle -> CDoc -> IO ()+cdPut' h = mapM_ (hPutStrLn h) . cdLines+-}++cdPut :: Handle -> CDoc -> IO ()+cdPut h d+ = do p d+ hPutStrLn h ""+ where p d = case d of+ CDoc_Emp -> return ()+ CDoc_Str s -> hPutStr h s+ CDoc_Ref r s d -> hPutStr h (showUndef r)+ CDoc_Hor d1 d2 -> do p d1+ p d2+ CDoc_Ver CDoc_Emp d2 -> p d2+ CDoc_Ver d1 CDoc_Emp -> p d1+ CDoc_Ver d1 d2 -> do p d1+ hPutStrLn h ""+ p d2+ CDoc_Pos _ d -> p d++class CD a where+ cd :: a -> CDoc++instance CD String where+ cd "" = CDoc_Emp+ cd s = CDoc_Str s++instance CD Int where+ cd = CDoc_Str . show++instance CD CDoc where+ cd = id++instance CD Nm where+ cd = cdDots . nmToL++instance CD a => CD (Maybe a) where+ cd = maybe CDoc_Emp cd++cdIsEmpty :: CDoc -> Bool+cdIsEmpty d+ = case d of+ CDoc_Emp -> True+ _ -> False++cdToMaybe :: CDoc -> Maybe CDoc+cdToMaybe d+ = case d of+ CDoc_Emp -> Nothing+ _ -> Just d++infixr 2 .-.+infixr 3 .|. , .#.++(.|.) :: (CD a, CD b) => a -> b -> CDoc+(.|.) a b = cd a `CDoc_Hor` cd b++(.-.) :: (CD a, CD b) => a -> b -> CDoc+(.-.) a b = cd a `CDoc_Ver` cd b++(.#.) :: (CD a, CD b) => a -> b -> CDoc+(.#.) a b = cd a .|. " " .|. cd b++cdListSep' :: (CD s, CD c, CD o, CD a) => (forall x . CD x => [x] -> CDoc) -> (forall x y . (CD x, CD y) => x -> y -> CDoc) -> o -> c -> s -> [a] -> CDoc+cdListSep' list aside o c s pps+ = l pps+ where l [] = o `aside` c+ l [p] = o `aside` p `aside` c+ l (p:ps) = list ([o `aside` p] ++ map (s `aside`) (init ps) ++ [s `aside` last ps `aside` c])++cdListSep :: (CD s, CD c, CD o, CD a) => o -> c -> s -> [a] -> CDoc+cdListSep = cdListSep' cdHor (.|.)++cdListSepV :: (CD s, CD c, CD o, CD a) => o -> c -> s -> [a] -> CDoc+cdListSepV = cdListSep' cdVer (.|.)++cdDots :: CD a => [a] -> CDoc+cdDots = cdListSep "" "" "."+}++-------------------------------------------------------------------------+-- Chunk doc wrapping+-------------------------------------------------------------------------++{+chWrap :: ChWrap -> CDoc -> CDoc+chWrap w d+ = case w of+ ChWrapCode -> "\\begin{code}" .-. d .-. "\\end{code}"+ ChWrapHsBox -> "\\begin{hsbox}" .-. d .-. "\\end{hsbox}"+ ChWrapBoxCode mw -> "\\parbox{" .|. maybe "" id mw .|. "\\linewidth}{%" .-. chWrap ChWrapCode d .-. "}"+ ChWrapBeamerBlockCode title+ -> "\\begin{block}{%" .-. title .-. "}" .-. chWrap (ChWrapBoxCode Nothing) d .-. "\\end{block}"+ ChWrapVerbatim -> "\\begin{verbatim}" .-. d .-. "\\end{verbatim}"+ ChWrapVerbatimSmall -> "{\\small\n\\begin{verbatim}" .-. d .-. "\\end{verbatim}\n}"+ ChWrapTT -> "\\begin{TT}" .-. d .-. "\\end{TT}"+ ChWrapTTtiny -> "\\begin{TTtiny}" .-. d .-. "\\end{TTtiny}"+ ChWrapT2T chKind | isJust mbt2t+ -> "@@[" .|. t2t .-. d .-. "@@]"+ where mbt2t = Map.lookup chKind t2tChKinds+ t2t = fromJust mbt2t+ ChWrapComp w1 w2 -> chWrap w1 $ chWrap w2 d+ _ -> d++chWrapT2T :: Opts -> ChKind -> ChWrap+chWrapT2T opts chKind+ = if optGenText2Text opts then ChWrapT2T chKind else ChWrapNone+}++-------------------------------------------------------------------------+-- Utils+-------------------------------------------------------------------------++{+mkTexCmd1 :: CD a => String -> a -> CDoc+mkTexCmd1 cmd a1 = "\\" .|. cmd .|. "{" .|. cd a1 .|. "}"++mkTexCmd2 :: (CD a, CD b) => String -> a -> b -> CDoc+mkTexCmd2 cmd a1 a2 = "\\" .|. cmd .|. "{" .|. cd a1 .|. "}{%" .-. cd a2 .-. "}"++mkTexCmd3 :: (CD a, CD b, CD c) => String -> a -> b -> c -> CDoc+mkTexCmd3 cmd a1 a2 a3 = "\\" .|. cmd .|. "{" .|. cd a1 .|. "}{%" .-. cd a2 .-. "}{%" .-. cd a3 .-. "}"++mkTexCmdDef :: (CD a, CD b) => String -> a -> b -> CDoc+mkTexCmdDef = mkTexCmd2++mkTexCmdUse :: CD a => String -> a -> CDoc+mkTexCmdUse = mkTexCmd1++mkTexCmdUse' :: CD a => String -> a -> CDoc+mkTexCmdUse' cmd nm = mkTexCmdUse cmd nm .|. "%"+}
+ src/UHC/Shuffle/CDocAbsSyn.ag view
@@ -0,0 +1,23 @@+-------------------------------------------------------------------------+-- Chunk doc AST+-------------------------------------------------------------------------++-- Outside itf+DATA AGCDocItf+ | AGItf cdoc : CDoc++DATA CDoc+ | Emp+ | Inl uref : {URef}+ | Ref cref : {CRef}+ mbVariantReqm : {Maybe VariantReqm}+ chDest : {ChDest}+ | Str str : {String}+ | Hor ldoc : CDoc+ rdoc : CDoc+ | Ver ldoc : CDoc+ rdoc : CDoc+ | Pos cpos : CPos+ cdoc : CDoc++DERIVING * : Show
+ src/UHC/Shuffle/CDocCommon.hs view
@@ -0,0 +1,29 @@+-------------------------------------------------------------------------+-- Common stuff based on CDoc+-------------------------------------------------------------------------++module UHC.Shuffle.CDocCommon+ ( module UHC.Shuffle.Common+ , module UHC.Shuffle.CDoc+ , NmChInfo(..), NmChMp+ )+ where++import UHC.Shuffle.Common+import UHC.Shuffle.CDoc+import qualified Data.Map as Map++-------------------------------------------------------------------------+-- Named chunks+-------------------------------------------------------------------------++data NmChInfo+ = NmChInfo+ { nciNm :: CRef+ , nciChDest :: ChDest+ , nciMbCDoc :: Maybe CDoc+ , nciMkCDoc :: MkCDoc+ }++type NmChMp = Map.Map CRef NmChInfo+
+ src/UHC/Shuffle/CDocCommonAG.ag view
@@ -0,0 +1,21 @@+-------------------------------------------------------------------------+-- CDoc common stuff+-------------------------------------------------------------------------++-------------------------------------------------------------------------+-- CPos ctxt for CDoc+-------------------------------------------------------------------------++ATTR CDoc [ cpos: CPos | | ]++SEM AGCDocItf+ | AGItf cdoc . cpos = CPos emptyFPath 0++SEM CDoc+ | Pos cdoc . cpos = @cpos++-------------------------------------------------------------------------+-- nmChMp+-------------------------------------------------------------------------++ATTR AGCDocItf CDoc [ nmChMp: NmChMp | | ]
+ src/UHC/Shuffle/CDocInline.ag view
@@ -0,0 +1,96 @@+-------------------------------------------------------------------------+-- Inlining files on CDoc+-------------------------------------------------------------------------++MODULE {UHC.Shuffle.CDocInline} {cdocInlineCDocIO, InlineCDocSt, InlineCDocIO}+{+import qualified Data.Map as Map+import Network.URI+import System.Process+import System.Exit+-- import System.Posix.Temp( mkstemp )+import System.Directory( removeFile )+import System.IO+import UHC.Shuffle.CDoc+import UHC.Shuffle.CDocCommon+}++INCLUDE "CDocAbsSyn.ag"+INCLUDE "CDocCommonAG.ag"++WRAPPER AGCDocItf++{+wrapAGCDoc_T :: NmChMp -> T_AGCDocItf -> Syn_AGCDocItf+wrapAGCDoc_T nmChMp d+ = wrap_AGCDocItf d+ (Inh_AGCDocItf+ { nmChMp_Inh_AGCDocItf = nmChMp+ })++wrapCDoc :: NmChMp -> CDoc -> Syn_AGCDocItf+wrapCDoc m d = wrapAGCDoc_T m (sem_AGCDocItf (AGCDocItf_AGItf d))++cdocInlineCDocIO :: CDoc -> (CDoc,InlineCDocIO)+cdocInlineCDocIO d+ = (ilRepl_Syn_AGCDocItf r,ilIO_Syn_AGCDocItf r)+ where r = wrapCDoc Map.empty d++type InlineCDocSt = (NmChMp,ErrM)+type InlineCDocIO = InlineCDocSt -> IO InlineCDocSt++inlineCDocEmp :: InlineCDocIO+inlineCDocEmp = return++inlineCDocAdd :: InlineCDocIO -> InlineCDocIO -> InlineCDocIO+inlineCDocAdd i1 i2 s+ = do { s1@(m1,e1) <- i1 s+ ; if Map.null e1+ then i2 (m1,Map.empty)+ else i2 (Map.empty,e1)+ }+}++-------------------------------------------------------------------------+-- URef (inline) subst in CDoc+-------------------------------------------------------------------------++ATTR CDoc [ | | ilRepl: SELF ]+ATTR AGCDocItf [ | | ilRepl: CDoc ]+ATTR AGCDocItf CDoc [ | | ilIO USE {`inlineCDocAdd`} {inlineCDocEmp}: InlineCDocIO ]++SEM CDoc+ | Inl loc . ilNm = Nm @uref+ lhs . ilRepl = CDoc_Ref @ilNm Nothing ChHere+ . ilIO = \(m,e)+ -> let dflt = (m,Map.insert @lhs.cpos (Err_UndefURI @lhs.cpos @uref) e)+ mkc n c m+ = Map.insert n (NmChInfo n ChHere res (const res)) m+ where res = Just (cd c)+ in case takeWhile (/= ':') @uref of+ "file"+ -> do { let mu = parseURIReference @uref+ ; mh <- maybe (return Nothing) openURI mu+ ; case mh of+ Just h -> do { c <- hGetContents h+ ; return (mkc @ilNm c m,e)+ }+ _ -> return dflt+ }+ "exec"+ -> do { let cmd = drop 5 @uref+ -- ; (tmpF,tmpH) <- mkstemp "shuffleXXXXXX.tmp"+ -- ; hClose tmpH+ ; let tmpF = "shuffleXXXXXX.tmp"+ ; exitCode <- system (cmd ++ " > " ++ tmpF)+ ; case exitCode of+ ExitSuccess -> do { h <- openFile tmpF ReadMode+ ; c <- hGetContents h+ -- ; hClose h+ ; removeFile tmpF+ ; return (mkc @ilNm c m,e)+ }+ _ -> return (m,Map.insert @lhs.cpos (Err_Exec @lhs.cpos cmd (show exitCode)) e)+ }+ _ -> return dflt+
+ src/UHC/Shuffle/CDocSubst.ag view
@@ -0,0 +1,53 @@+-------------------------------------------------------------------------+-- Substitution on CDoc+-------------------------------------------------------------------------++MODULE {UHC.Shuffle.CDocSubst} {cdocSubst}+{+import qualified Data.Set as Set+import qualified Data.Map as Map+import UHC.Shuffle.CDoc+import UHC.Shuffle.CDocCommon+}++INCLUDE "CDocAbsSyn.ag"+INCLUDE "CDocCommonAG.ag"++WRAPPER AGCDocItf++{+wrapAGCDoc_T :: NmChMp -> T_AGCDocItf -> Syn_AGCDocItf+wrapAGCDoc_T nmChMp d+ = wrap_AGCDocItf d+ (Inh_AGCDocItf+ { nmChMp_Inh_AGCDocItf = nmChMp+ })++wrapCDoc :: NmChMp -> CDoc -> Syn_AGCDocItf+wrapCDoc m d = wrapAGCDoc_T m (sem_AGCDocItf (AGCDocItf_AGItf d))++cdocSubst :: NmChMp -> CDoc -> (CDoc,Set.Set Nm,ErrM)+cdocSubst m d+ = (sbRepl_Syn_AGCDocItf r,sbCRefS_Syn_AGCDocItf r,sbErrM_Syn_AGCDocItf r)+ where r = wrapCDoc m d+}++-------------------------------------------------------------------------+-- CRef subst in CDoc+-------------------------------------------------------------------------++ATTR CDoc [ | | sbRepl: SELF ]+ATTR AGCDocItf [ | | sbRepl: CDoc ]+ATTR CDoc AGCDocItf [ | | sbCRefS USE {`Set.union`} {Set.empty}: {Set.Set Nm} ]+ATTR CDoc AGCDocItf [ | | sbErrM USE {`Map.union`} {Map.empty}: ErrM ]++SEM CDoc+ | Ref lhs . (sbRepl,sbCRefS,sbErrM)+ = case Map.lookup (@cref) @lhs.nmChMp of+ Just i+ -> case maybe (nciMbCDoc i) (nciMkCDoc i) @mbVariantReqm of+ Just d -> (r,Set.insert @cref s,e)+ where (r,s,e) = cdocSubst (Map.delete @cref @lhs.nmChMp) d+ _ -> (CDoc_Emp,Set.empty,Map.empty)+ _ -> (@sbRepl,Set.empty,Map.singleton @lhs.cpos (Err_UndefNm @lhs.cpos "chunk reference" [@cref]))+
+ src/UHC/Shuffle/ChunkAbsSyn.ag view
@@ -0,0 +1,95 @@+-------------------------------------------------------------------------+-- Chunk files AST+-------------------------------------------------------------------------++-- Outside itf+DATA AGItf+ | AGItf dumLines : Lines+ chunks : Chunks++-- Chunk+DATA Chunk+ | Ver variantOffer : {VariantOffer}+ subNm : {Nm}+ minusL : {[ChunkRef]}+ chOptions : ChunkOptions+ compRestrict : {CompilerRestriction}+ mbModNm : MbStrExpr -- {Maybe String}+ imports : StrExprs+ exports : StrExprs+ lines : Lines+ dumLines : Lines+ | Named cref : {CRef}+ chKind : {ChKind}+ lines : Lines+ dumLines : Lines++TYPE Chunks = [Chunk]++SET AllChunk = Chunk Chunks++-- Expr (describing a string)+DATA StrExpr+ | Str str : {String}+ | Var nm : {String}+ | Concat e1 : StrExpr+ e2 : StrExpr+ | White e1 : StrExpr+ e2 : StrExpr+ | Group e : StrExpr+ | Seq es : StrExprs++TYPE StrExprs = [StrExpr]+TYPE MbStrExpr = MAYBE StrExpr++SET AllStrExpr = StrExpr MbStrExpr StrExprs++-- ChunkOption+DATA ChunkOption+ | Kind chKind : {ChKind}+ | Dest chDest : {ChDest}+ | Wrap chWrap : {ChWrap}++TYPE ChunkOptions = [ChunkOption]++SET AllChunkOption = ChunkOption ChunkOptions++-- Single line+DATA Line+ | AsIs words : Words+ | Named cref : {CRef}+ mbVariantReqm : {Maybe VariantReqm}+ | Groups extraLine : Int+ groups : Groups++TYPE Lines = [Line]++SET AllLine = Line Lines++-- Single group of lines+DATA Group+ | Group variantOffer : {VariantOffer}+ chOptions : ChunkOptions+ userRef : {Maybe (Nm,Maybe String)}+ lines : Lines++TYPE Groups = [Group]++SET AllGroup = Group Groups++-- Single word+DATA Word+ | White chars : {String}+ | Black chars : {String}+ | Inline inl : Inline+ | Expand exp : StrExpr++DATA Inline+ | URI str : {String}++TYPE Words = [Word]++SET AllWord = Word Words Inline++-- Sets+SET AllNT = AllWord AllLine AllGroup AllChunk AllStrExpr
+ src/UHC/Shuffle/ChunkParser.hs view
@@ -0,0 +1,449 @@+-------------------------------------------------------------------------+-- Chunk Parser+-------------------------------------------------------------------------++module UHC.Shuffle.ChunkParser+ where++import qualified Data.Set as Set+import qualified Data.Map as Map+import Data.List+import System.IO++import UU.Parsing+-- import UU.Parsing.CharParser+import UU.Scanner.Position( initPos, Pos )++import UHC.Util.ScanUtils+import UHC.Util.ParseUtils+import UHC.Util.Utils++import UHC.Shuffle.Common+import UHC.Shuffle.MainAG++-------------------------------------------------------------------------------------------+-- Scanning+-------------------------------------------------------------------------------------------++type ScanOptsMp = Map.Map ScState ScanOpts++chKindMp = Map.fromList+ [ ("hs",ChHS), ("ag",ChAG), ("plain",ChPlain), ("haddock",ChHaddock) ]+ `Map.union` Map.fromList [ (v,k) | (k,v) <- Map.toList t2tChKinds ]+chDestMp = Map.fromList [ ("here",ChHere), ("hide",ChHide) ]+chWrapMp = Map.fromList [ ("hsbox",ChWrapHsBox), ("code",ChWrapCode), ("safecode",ChWrapBoxCode Nothing), ("tt",ChWrapTT), ("tttiny",ChWrapTTtiny) , ("verbatim",ChWrapVerbatim), ("verbatimsmall",ChWrapVerbatimSmall) ]++kwTxtAsVarTooA+ = [ "module", "import", "export", "wrap", "ghc" ]+ ++ Map.keys chKindMp++kwTxtAsVarTooB+ = kwTxtAsVarTooA+ ++ Map.keys chDestMp+ ++ Map.keys chWrapMp+ ++ [ "beamerblockcode", "boxcode" ]++shuffleScanOpts :: ScanOptsMp+shuffleScanOpts+ = Map.fromList+ [ ( ScLexMeta 0+ , defaultScanOpts+ { scoKeywordsTxt = Set.fromList (kwTxtAsVarTooB ++ [ "_", "-", ".", "<", "=", "@", "||", "&&" ])+ , scoSpecChars = Set.fromList "(),%{}"+ , scoOpChars = Set.fromList "+-=*&^$#@!\\|><~`;:?/_."+ }+ )+ ]++data ScState+ = ScChunk Int | ScLexMeta Int | ScInline Int | ScSkip+ deriving Show++instance Eq ScState where+ ScChunk _ == ScChunk _ = True+ ScLexMeta _ == ScLexMeta _ = True+ ScInline _ == ScInline _ = True+ ScSkip == ScSkip = True+ _ == _ = False++instance Ord ScState where+ ScChunk _ < ScLexMeta _ = True+ ScChunk i < s = ScLexMeta i < s+ ScLexMeta _ < ScInline _ = True+ ScLexMeta i < s = ScInline i < s+ ScInline _ < ScSkip = True+ _ < _ = False++data TokKind+ = TkBegChunk | TkEndChunk+ | TkBegInline | TkEndInline+ | TkBegExpand | TkEndExpand+ | TkBegGroup | TkElseGroup+ | TkNameRef+ | TkReserved+ | TkNl | TkEOF+ | TkText | TkInt | TkStr+ deriving (Show,Eq,Ord)++data Tok+ = Tok { tokKind :: TokKind, tokWhite :: String, tokBlack :: String, tokPos :: InFilePos, tokState :: ScState }++instance Eq Tok where+ (Tok k1 _ b1 _ _) == (Tok k2 _ b2 _ _) = k1 == k2 && (k1 /= TkReserved || b1 == b2)++instance Ord Tok where+ (Tok k1 _ b1 _ _) `compare` (Tok k2 _ b2 _ _)+ = if ck == EQ+ then if k1 == TkReserved then b1 `compare` b2 else ck+ else ck+ where ck = k1 `compare` k2++instance Show Tok where+ show t = show (tokPos t) ++ show (tokBlack t)++instance Symbol Tok++mbTokWhite :: Tok -> Maybe String+mbTokWhite (Tok _ w _ _ _) = if null w then Nothing else Just w++scan :: ScanOptsMp -> ScState -> String -> [Tok]+scan scoMp st s+ = takeWhile ((/=TkEOF) . tokKind) (sc infpStart st s)+ where sc p st "" = [Tok TkEOF "" "" p st]+ sc p st@(ScChunk _) s@(c:_)+ | isWhite c = t {tokWhite = w} : ts+ where (w,s') = span isWhite s+ (t:ts) = sc (a w p) st s'+ sc p st@(ScLexMeta l) ('%':'%':'}':s') = Tok TkEndExpand "" "%%}" p st : sc (ai 3 p) (ScChunk l) s'+ sc p st@(ScLexMeta _) s@(c:_)+ | isWhite c = sc (a w p) st s'+ where (w,s') = span isWhite s+ sc p st s@(c:s')+ | isLF c = Tok TkNl "" [c] p st : sc (al p) st' s'+ where st' = case st of+ ScLexMeta l -> ScChunk l+ _ -> st+ sc p st@(ScLexMeta _) s@(c:s')+ | isSpec st c = Tok TkReserved "" [c] p st : sc (ai 1 p) st s'+ sc p st@(ScLexMeta _) s@(c:_)+ | isVarStart c = scKw isVarRest p st s+ sc p st@(ScLexMeta _) s@(c:_)+ | isDigit c = Tok TkInt "" w p st : sc (a w p) st s'+ where (w,s') = span isDigit s+ sc p st@(ScLexMeta _) s@(c:s')+ | isStrQuote c = Tok TkStr "" w p st : sc (a w . ai 2 $ p) st s3+ where (w,s2) = span isStr s'+ s3 = case s2 of+ (c:s) | isStrQuote c -> s+ _ -> s2+ sc p st@(ScLexMeta _) s@(c:_)+ | isOpch st c = scKw (isOpch st) p st s+ sc p@(InFilePos _ 1) st@(ScChunk l) ('%':'%':'[':'[':s')+ = Tok TkBegGroup "" "%%[[" p st : sc (ai 4 p) (ScLexMeta (l+1)) s'+ sc p@(InFilePos _ 1) st@(ScChunk l) ('%':'%':']':'[':s')+ = Tok TkElseGroup "" "%%][" p st : sc (ai 4 p) (ScLexMeta (l)) s'+ sc p@(InFilePos _ 1) ScSkip ('%':'%':'[':s')+ = Tok TkBegChunk "" "%%[" p ScSkip : sc (ai 3 p) (ScLexMeta 0) s'+ sc p@(InFilePos _ 1) st@(ScChunk l) ('%':'%':']':']':s')+ | l > 0 = Tok TkEndChunk "" "%%]]" p st : sc (ai 4 p) (ScChunk (l-1)) s'+ sc p@(InFilePos _ 1) st@(ScChunk l) ('%':'%':']':s')+ | l == 0 = Tok TkEndChunk "" "%%]" p st : sc (ai 3 p) ScSkip s'+ | l > 0 = Tok TkEndChunk "" "%%]" p st : sc (ai 3 p) (ScChunk (l-1)) s'+ sc p@(InFilePos _ _) st@(ScChunk l) ('%':'%':'@':'[':s')+ = Tok TkBegInline "" "%%@[" p st : sc (ai 4 p) (ScInline l) s'+ sc p@(InFilePos _ _) st@(ScChunk l) ('%':'%':'@':'{':s')+ = Tok TkBegExpand "" "%%@{" p st : sc (ai 4 p) (ScLexMeta l) s'+ sc p@(InFilePos _ _) st@(ScChunk l) ('%':'%':'%':s)+ = Tok TkText "" b' p st : sc (ai (1 + length b') p) (ScChunk l) s'+ where (b,s') = span isBlack s+ b' = "%%" ++ b+ sc p@(InFilePos _ 1) st@(ScChunk l) ('%':'%':'@':s')+ = Tok TkNameRef "" "%%@" p st : sc (ai 3 p) (ScLexMeta l) s'+ sc p@(InFilePos _ _) st@(ScInline l) ('%':'%':']':s')+ = Tok TkEndInline "" "%%]" p st : sc (ai 3 p) (ScChunk l) s'+ sc p@(InFilePos _ _) st@(ScInline l) s = Tok TkText "" il p st : sc (a il p) (ScInline l) s'+ where (il,s') = spanInline s+ spanInline s@('%':'%':']':_) = ("",s)+ spanInline "" = ("","")+ spanInline (c:s) = let (b,e) = spanInline s in (c:b,e)+ sc p st@(ScChunk _) s@(c:_)+ | isBlack c && not (isInline s) = Tok TkText "" b p st : sc (a b p) st s'+ where (b,s') = span' (\s@(c:_) -> isBlack c && not (isInline s)) s+ sc p st s@(c:s') = sc (ai 1 p) st s'+ scKw f p st s = Tok tk "" w p st : sc (a w p) st s'+ where (w,s') = span f s+ tk = if isKeyw st w then TkReserved else TkText+ a = infpAdvStr+ ai = infpAdvCol+ al = infpAdv1Line+ opt st p = maybe False p $ Map.lookup st scoMp+ isSpec st c = opt st (\o -> c `Set.member` scoSpecChars o)+ isOpch st c = opt st (\o -> c `Set.member` scoOpChars o)+ isKeyw st w = opt st (\o -> w `Set.member` scoKeywordsTxt o)+ isInline ('%':'%':'@':'[':_) = True+ isInline ('%':'%':'@':'{':_) = True+ isInline ('%':'%':'%': _) = True+ isInline _ = False+ span' = spanOnRest++-------------------------------------------------------------------------+-- Parsers directly related to scanning+-------------------------------------------------------------------------++pBegChunk, pEndChunk+ , pBegInline, pEndInline+ , pBegExpand, pEndExpand+ , pBegGroup, pElseGroup+ , pBegNameRef, pNl :: (IsParser p Tok) => p Tok+pBegChunk = pSym (Tok TkBegChunk "" "%%[" infpNone ScSkip)+pEndChunk = pSym (Tok TkEndChunk "" "%%]" infpNone ScSkip)+pBegInline = pSym (Tok TkBegInline "" "%%@[" infpNone ScSkip)+pEndInline = pSym (Tok TkEndInline "" "%%]" infpNone ScSkip)+pBegExpand = pSym (Tok TkBegExpand "" "%%@{" infpNone ScSkip)+pEndExpand = pSym (Tok TkEndExpand "" "%%}" infpNone ScSkip)+pBegGroup = pSym (Tok TkBegGroup "" "%%[[" infpNone ScSkip)+pElseGroup = pSym (Tok TkElseGroup "" "%%][" infpNone ScSkip)+pBegNameRef = pSym (Tok TkNameRef "" "%%@" infpNone ScSkip)+pNl = pSym (Tok TkNl "" "LF" infpNone ScSkip)++pKey :: (IsParser p Tok) => String -> p String+pKey k = tokBlack <$> pSym (Tok TkReserved "" k infpNone ScSkip)++pVar :: (IsParser p Tok) => p String+pVar = tokBlack <$> pSym (Tok TkText "" "<ident>" infpNone ScSkip)++pInt :: (IsParser p Tok) => p String+pInt = tokBlack <$> pSym (Tok TkInt "" "0" infpNone ScSkip)++pFrac :: (IsParser p Tok) => p String+pFrac+ = (++) <$> (pMaybe "" id pInt)+ <*> (pMaybe "" ("."++) (pKey "." *> pInt))++pInt' :: (IsParser p Tok) => p Int+pInt' = strToInt <$> pInt++pStr :: (IsParser p Tok) => p String+pStr = tokBlack <$> pSym (Tok TkStr "" "<string>" infpNone ScSkip)++pText :: (IsParser p Tok) => p Tok+pText = pSym (Tok TkText "" "<text>" infpNone ScSkip)++pWhiteBlack :: (IsParser p Tok) => p (Maybe String,String)+pWhiteBlack = (\t -> (mbTokWhite t,tokBlack t)) <$> pText++-------------------------------------------------------------------------+-- Shuffle chunk parser+-------------------------------------------------------------------------++type ShPr c = (IsParser p Tok) => p c+type ShPr2 c = (IsParser p Tok) => p c -> p c+type ShPr3 c = (IsParser p Tok) => p c -> p c -> p c++mkNmForP :: String -> [String] -> Nm+mkNmForP h t = nmFromL . concat . map (wordsBy (=='.')) $ (h : t)++pAGItf :: ShPr T_AGItf+pAGItf = sem_AGItf_AGItf <$> (pFoldr (sem_Lines_Cons,sem_Lines_Nil) (sem_Line_AsIs sem_Words_Nil <$ pNl)) <*> pChunks++pAspectExprBase :: ShPr AspectExpr+pAspectExprBase = AspectExpr_Requires <$> pVar+ <|> pParens pAspectExpr++pAspectExprAnd :: ShPr AspectExpr+pAspectExprAnd = pChainr (AspectExpr_And <$ pKey "&&") (foldr1 AspectExpr_And <$> pList1 pAspectExprBase)++pAspectExprOr :: ShPr AspectExpr+pAspectExprOr = pChainr (AspectExpr_Or <$ pKey "||") pAspectExprAnd++pAspectExpr :: ShPr AspectExpr+pAspectExpr = pAspectExprOr++pVariantRef :: ShPr VariantRef+pVariantRef = VarRef <$> pList1Sep (pKey "_") pInt'++pVariantOfferRef :: ShPr VariantOffer+pVariantOfferRef = variantOfferFromRef <$> pVariantRef++pVariantOffer :: ShPr VariantOffer+pVariantOffer = pVariantOfferRef+ <|> pParens (VOfferRef <$> pVariantRef <*> pAspectRefsExpr)++pVariantReqmRef :: ShPr VariantReqm+pVariantReqmRef = variantReqmFromRef <$> pVariantRef++pAspectRefs :: ShPr AspectRefs+pAspectRefs = pMaybe AspectAll (AspectRefs . Set.fromList) (pList1 pVar)++pAspectRefsExpr :: ShPr AspectRefs+pAspectRefsExpr = pMaybe AspectAll AspectOfferExpr pAspectExpr++pVariantReqm :: ShPr VariantReqm+pVariantReqm = pVariantReqmRef+ <|> pParens (VReqmRef <$> pVariantRef <*> pAspectRefs)++pOptVariantOffer :: ShPr VariantOffer+pOptVariantOffer = pMaybe VOfferAll id pVariantOffer++pVariantRefOrder :: ShPr VariantRefOrder+pVariantRefOrder = pListSep (pKey ",") (pList1Sep (pKey "<") pVariantRef)++pNm2 :: ShPr Nm+pNm2 = mkNmForP <$> p <*> pList (pKey "." *> (p <|> pInt))+ where p = foldl1 (<|>) (map pKey kwTxtAsVarTooA) <|> pVar++pNm :: ShPr Nm+pNm = mkNmForP <$> pVar <*> pList (pKey "." *> (pVar <|> pInt))++pStrStr1 :: ShPr String+pStrStr1 = pVar <|> pInt <|> pStr++pStrStr2 :: ShPr String+pStrStr2 = pStrStr1 <|> foldl1 (<|>) (map pKey kwTxtAsVarTooB)++pStrExpr :: (IsParser p Tok) => p String -> p T_StrExpr -> p T_StrExpr+pStrExpr pS pPar = pStrExpr pStrExprBase+ where pStrExpr = pChainr+ ((\s l r -> sem_StrExpr_Concat l (sem_StrExpr_Concat (sem_StrExpr_Str s) r)) <$> pKey ".")+ pStrExprConc = foldr1 sem_StrExpr_Concat <$> pList1 pStrExprBase+ pStrExprBase = sem_StrExpr_Str <$> pS+ <|> sem_StrExpr_Var <$ pKey "%" <*> pCurly pVar+ <|> sem_StrExpr_Group <$> pCurly (pStrExpr pStrExprConc)+ <|> pParens pPar++pStrExprOne :: (IsParser p Tok) => p String -> p T_StrExpr+pStrExprOne pS = pStrExprOne+ where pStrExprOne = pStrExpr pS pStrExprOne++pStrExprSeq :: (IsParser p Tok) => p String -> p T_StrExprs+pStrExprSeq pS = pStrExprPar+ where pStrExprWhite = foldr1 sem_StrExpr_White <$> pList1 (pStrExpr pS (sem_StrExpr_Seq <$> pStrExprPar))+ pStrExprPar = pFoldrSep (sem_StrExprs_Cons,sem_StrExprs_Nil) (pKey ",") pStrExprWhite++pChunkRef :: ShPr ChunkRef+pChunkRef = ChunkRef <$> pVariantRef <* pKey "." <*> pNm++pStrPacked :: (IsParser p Tok) => String -> String -> p a -> p a+pStrPacked o c p = pKey o *> p <* pKey c++pParens :: ShPr2 p+pParens = pStrPacked "(" ")"++pCurly :: ShPr2 p+pCurly = pStrPacked "{" "}"++pChunks :: ShPr T_Chunks+pChunks = pFoldr (sem_Chunks_Cons,sem_Chunks_Nil) pChunk++pChunk :: ShPr T_Chunk +pChunk = pBegChunk+ *> (( sem_Chunk_Ver+ <$> pVariantOffer+ <*> pMaybe NmEmp id (pKey "." *> pNm)+ <*> (pKey "-" *> ((:[]) <$> pChunkRef <|> pParens (pList1 pChunkRef)) <|> pSucceed [])+ <*> pChunkOptions+ <*> pCompilerRestrictions+ <*> pMod+ <*> pImpExp "import"+ <*> pImpExp "export"+ <|> sem_Chunk_Named+ <$> pNm+ <*> pMbChKind'+ )+ <* pNl+ <*> pLines+ <* pEndChunk+ -- <* pNl+ <*> pLines+ )+ <?> "a chunk"+ where pImpExp k = pKey k *> pParens (pStrExprSeq pStrStr2) <|> pSucceed sem_StrExprs_Nil+ pMod = sem_MbStrExpr_Just <$ pKey "module" <*> pStrExprOne pStrStr1 <|> pSucceed sem_MbStrExpr_Nothing++pCompilerRestrictions :: ShPr CompilerRestriction+pCompilerRestrictions+ = pMaybe (Restricted Nothing Nothing) id (pKey "ghc" *> pParens (Restricted <$> pCompilerVersion <* pKey "," <*> pCompilerVersion))++pCompilerVersion :: ShPr (Maybe [Int])+pCompilerVersion+ = Just <$> pList1Sep (pKey ".") pInt'+ <|> Nothing <$ pKey "_"++pChKind :: ShPr ChKind+pChKind = pAnyFromMap pKey chKindMp++pMbChKind :: ShPr ChKind+pMbChKind = pMaybe ChAG id pChKind++pMbChKind' :: ShPr ChKind+pMbChKind' = pMaybe ChPlain id pChKind++pChDest :: ShPr ChDest+pChDest = pAnyFromMap pKey chDestMp++pMbChDest :: ShPr ChDest+pMbChDest = pMaybe ChHere id pChDest++pChWrap :: ShPr ChWrap+pChWrap = pKey "wrap" *> pKey "="+ *> ( pAnyFromMap pKey chWrapMp+ <|> ChWrapBeamerBlockCode <$ pKey "beamerblockcode" <*> pStr+ <|> ChWrapBoxCode <$ pKey "boxcode" <*> pMb (pCurly pFrac)+ )++pMbChWrap :: ShPr ChWrap+pMbChWrap = pMaybe ChWrapPlain id pChWrap++pChunkOption :: ShPr T_ChunkOption+pChunkOption = sem_ChunkOption_Kind <$> pChKind+ <|> sem_ChunkOption_Dest <$> pChDest+ <|> sem_ChunkOption_Wrap <$> pChWrap++pChunkOptions :: ShPr T_ChunkOptions+pChunkOptions = pFoldr (sem_ChunkOptions_Cons,sem_ChunkOptions_Nil) pChunkOption++pLines :: ShPr T_Lines+pLines = pFoldr (sem_Lines_Cons,sem_Lines_Nil) pLine++pLine :: ShPr T_Line+pLine = sem_Line_AsIs <$> pLineChars <* pNl+ <|> (\n iv (o,r)+ -> sem_Line_Groups 0 (sem_Groups_Cons (sem_Group_Group VOfferAll o r (sem_Lines_Cons (sem_Line_Named n iv) sem_Lines_Nil)) sem_Groups_Nil))+ <$ pBegNameRef <*> pN <*> pMb (pKey "@" *> pVariantReqm) <*> pD <* pNl+ <|> sem_Line_Groups 1+ <$ pBegGroup <*> pFoldr1Sep (sem_Groups_Cons,sem_Groups_Nil) pElseGroup pG <* pEndChunk <* pNl+ <?> "a line"+ where pN = pNm+ <|> (\v n -> mkNm v `nmApd` n) <$> pVariantRef <*> pMaybe NmEmp id (pKey "." *> pNm)+ pD = pChunkOptions+ <+> pMaybe Nothing Just ((pNm2 <|> mkNm <$> pStr) <+> pMaybe Nothing Just (pKey "=" *> pMaybe "" id pStr))+ pG = (\v (o,r) ls -> sem_Group_Group v o r ls) <$> pOptVariantOffer <*> pD <* pNl <*> pLines++pLineChars :: ShPr T_Words+pLineChars = (foldr sem_Words_Cons sem_Words_Nil . concat)+ <$> pList ( bwToWords1 sem_Word_Black+ <$> pWhiteBlack+ <|> bwToWords2 (\s -> sem_Word_Inline (sem_Inline_URI (tokBlack s)))+ <$> pBegInline <*> pText <* pEndInline+ <|> bwToWords2 (\s -> sem_Word_Expand s)+ <$> pBegExpand <*> pStrExprOne pStrStr2 <* pEndExpand+ )+ where bwToWords1 sem (mw,b) = maybe [] (\w -> [sem_Word_White w]) mw ++ [sem b]+ bwToWords2 sem tk t = (maybe [] (\w -> [sem_Word_White w]) $ mbTokWhite $ tk) ++ [sem t]++-------------------------------------------------------------------------+-- Parsing+-------------------------------------------------------------------------++parseHandle :: ShPr a -> FilePath -> Handle -> IO a+parseHandle p fn fh+ = do { txt <- hGetContents fh+ ; let toks = scan shuffleScanOpts ScSkip txt+ ; parseIOMessage show p toks+ }++parseAndGetRes :: ShPr a -> String -> a+parseAndGetRes p s+ = case evalSteps (parse p toks) of {Pair v _ -> v}+ where toks = scan shuffleScanOpts (ScLexMeta 0) s+
+ src/UHC/Shuffle/Common.hs view
@@ -0,0 +1,429 @@+-------------------------------------------------------------------------+-- Common stuff+-------------------------------------------------------------------------++module UHC.Shuffle.Common+ ( module Data.Maybe+ , module Data.Char+ , module UHC.Util.Nm+ , module UHC.Util.FPath+ , module UHC.Util.Pretty+ , module UHC.Shuffle.AspectExpr++ , Err(..), ErrM, ppErr, showUndef++ , openURI++ , Opts(..), defaultOpts, optsHasNoVariantRefOrder++ , URef+ , CRef, CPos(..)++ , ChKind(..), ChDest(..), ChWrap(..)++ , VariantRef(..)+ , AspectRefs(..)+ , variantReqmRef, mbVariantReqmRef+ , variantRefFromTop+ , variantReqmUpdRef+ , VariantOffer(..), VariantReqm(..)+ , variantOfferFromRef, variantReqmFromRef+ , variantOfferFromTop+ , variantOfferRef, variantOfferRefTop+ , VariantRefOrder++ , ChunkRef(..)+ , chunkRefFromOfferNm++ , variantReqmMatchOffer+ , VariantRefOrderMp, sortOnVariantRefOrderMp, sortOnVariantRefOrderMp'++ , KVMap++ , CompilerRestriction(..)+ + , t2tChKinds+ )+ where++import Data.Maybe+import Data.Char+import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.Map(Map)+import Data.Set(Set)+import Network.URI+import System.IO+import System.Directory+import System.Console.GetOpt+import UHC.Util.Pretty+import UHC.Util.FPath+import UHC.Util.Utils+import UHC.Util.Nm+import UHC.Shuffle.AspectExpr+import UHC.Shuffle.AspectExprEval++-------------------------------------------------------------------------+-- Errors+-------------------------------------------------------------------------++data Err+ = Err_UndefNm CPos String [Nm]+ | Err_UndefURI CPos String+ | Err_Exec CPos String String+ deriving Show++type ErrM = Map.Map CPos Err++ppErr :: CPos -> PP_Doc -> PP_Doc+ppErr pos p+ = "*** ERROR ***"+ >-< show pos >|< ":"+ >-< indent 4 p++instance PP Err where+ pp (Err_UndefNm pos knd nmL)+ = ppErr pos (knd >|< "(s) are undefined:" >#< ppCommas' nmL)+ pp (Err_UndefURI pos u)+ = ppErr pos ("could not open:" >#< u)+ pp (Err_Exec pos f e)+ = ppErr pos ( "execution of:" >#< f+ >-< "failed :" >#< e+ )++showUndef :: Show r => r -> String+showUndef r = "<<<<" ++ show r ++ ">>>>"++-------------------------------------------------------------------------+-- URI handling+-------------------------------------------------------------------------++openURI :: URI -> IO (Maybe Handle)+openURI u+ = case uriScheme u of+ "file:" -> do { ex <- doesFileExist p+ ; if ex+ then do { h <- openFile p ReadMode+ ; return (Just h)+ }+ else return Nothing+ }+ _ -> return Nothing+ where p = uriPath u++-------------------------------------------------------------------------+-- Key/value pair handling+-------------------------------------------------------------------------++type KVMap = Map.Map String String++-------------------------------------------------------------------------+-- Options+-------------------------------------------------------------------------++data Opts + = Opts+ { optAG :: Bool -- generate AG+ , optHS :: Bool -- generate Haskell+ , optPlain :: Bool -- leave as is+ , optLaTeX :: Bool -- generate latex+ , optPreamble :: Bool -- include preamble+ , optLinePragmas :: Bool -- include line pragmas+ , optIndex :: Bool+ , optCompiler :: [Int]+ , optHelp :: Bool+ , optGenDeps :: Bool+ , optGenText2Text :: Bool -- include text2text text type annotation+ , optChDest :: (ChDest,String)+ , optGenReqm :: VariantReqm+ , optBaseName :: Maybe String+ , optBaseFPath :: FPath+ , optWrapLhs2tex :: ChWrap+ , optMbXRefExcept :: Maybe String+ , optVariantRefOrder :: VariantRefOrder+ , optDefs :: KVMap+ , optDepNamePrefix :: String+ , optDepSrcVar :: String+ , optDepDstVar :: String+ , optDepMainVar :: String+ , optDepDpdsVar :: String+ , optDepOrigDpdsVar :: String+ , optDepDerivDpdsVar :: String+ , optDepBaseDir :: String+ , optDepTerm :: Map String [String]+ , optDepIgn :: Set String+ , optAGModHeader :: Bool+ } deriving (Show)++defaultOpts+ = Opts+ { optAG = False+ , optHS = False+ , optLaTeX = False+ , optPreamble = True+ , optLinePragmas = False+ , optPlain = False+ , optIndex = False+ , optCompiler = []+ , optHelp = False+ , optGenDeps = False+ , optGenText2Text = False+ , optChDest = (ChHere,"")+ , optGenReqm = VReqmNone+ , optBaseName = Nothing+ , optBaseFPath = emptyFPath+ , optWrapLhs2tex = ChWrapCode+ , optMbXRefExcept = Nothing+ , optVariantRefOrder = [[]]+ , optDefs = Map.empty+ , optDepNamePrefix = error "optDepNamePrefix not set"+ , optDepSrcVar = error "optDepSrcVar not set"+ , optDepDstVar = error "optDepDstVar not set"+ , optDepMainVar = error "optDepMainVar not set"+ , optDepDpdsVar = error "optDepDpdsVar not set"+ , optDepOrigDpdsVar = error "optDepOrigDpdsVar not set"+ , optDepDerivDpdsVar = error "optDepDerivDpdsVar not set"+ , optDepBaseDir = error "optDepBaseDir not set"+ , optDepTerm = Map.empty+ , optDepIgn = Set.empty+ , optAGModHeader = True+ }++optsHasNoVariantRefOrder :: Opts -> Bool+optsHasNoVariantRefOrder = null . head . optVariantRefOrder++-------------------------------------------------------------------------+-- URI ref+-------------------------------------------------------------------------++type URef = String++-------------------------------------------------------------------------+-- Chunk ref, position (in file)+-------------------------------------------------------------------------++type CRef = Nm+data CPos = CPos FPath Int+ deriving (Eq,Ord)++instance Show CPos where+ show (CPos fp l) = fpathToStr fp ++ ":" ++ show l++-------------------------------------------------------------------------+-- Chunk kind, purpose/destination+-------------------------------------------------------------------------++data ChKind+ = ChAG+ | ChHS+ | ChPlain+ | ChDocLaTeX -- restricted LaTeX for documentation+ -- | ChTexInfo+ -- | ChHtml+ -- | ChTwiki+ | ChHaddock+ deriving (Show,Eq,Ord)++data ChDest+ = ChHere | ChHide+ deriving (Show,Eq,Ord)++data ChWrap+ = ChWrapCode+ | ChWrapHsBox+ | ChWrapBoxCode (Maybe String)+ | ChWrapBeamerBlockCode String+ | ChWrapTT+ | ChWrapTTtiny+ | ChWrapVerbatim+ | ChWrapVerbatimSmall+ | ChWrapPlain+ | ChWrapT2T ChKind -- wrap for text2text+ | ChWrapComp ChWrap ChWrap -- compose+ | ChWrapNone+ deriving (Show,Eq,Ord)++-------------------------------------------------------------------------+-- For which ChKind's are text2text annotation generated, if requested+-------------------------------------------------------------------------++t2tChKinds :: Map.Map ChKind String+t2tChKinds+ = Map.fromList+ [ ( ChDocLaTeX, "doclatex" )+ ]++-------------------------------------------------------------------------+-- Variant reference+-------------------------------------------------------------------------++data VariantRef+ = VarRef {vrefRefs :: ![Int]}+ deriving (Show,Eq,Ord)++instance NM VariantRef where+ mkNm (VarRef l) = nmApdL $ map mkNm l++variantRefFromTop :: Int -> VariantRef+variantRefFromTop i = VarRef [i]++-------------------------------------------------------------------------+-- Aspect reference+-------------------------------------------------------------------------++data AspectRefs+ = AspectAll+ | AspectRefs !AspectRefReqd+ | AspectOfferExpr !AspectExpr+ deriving (Show,Eq,Ord)++aspectRefsMatch :: AspectRefs -> AspectRefs -> Bool+aspectRefsMatch AspectAll _ = True+aspectRefsMatch _ AspectAll = True+aspectRefsMatch (AspectRefs r1) (AspectRefs r2) = Set.isSubsetOf r1 r2 -- not (Set.null (Set.intersection r1 r2))+aspectRefsMatch (AspectOfferExpr r1) (AspectRefs r2) = aspexpIsAccepted r2 r1++-------------------------------------------------------------------------+-- Variant offering, ordering+-------------------------------------------------------------------------++data VariantOfferForCompare+ = VariantOfferForCompare !Int !AspectRefs+ deriving (Eq,Ord)++-------------------------------------------------------------------------+-- Variant offering, available version+-------------------------------------------------------------------------++data VariantOffer+ = VOfferAll+ | VOfferPre+ | VOfferRef {vofferVariant :: !VariantRef, vofferAspect :: !AspectRefs}+ deriving (Show,Eq,Ord)++{-+instance Ord VariantOffer where+ VOfferAll `compare` VOfferAll = EQ+ VOfferAll `compare` _ = LT+ VOfferPre `compare` VOfferPre = EQ+ VOfferPre `compare` _ = LT+ _ `compare` VOfferAll = GT+ _ `compare` VOfferPre = GT+ (VOfferRef r1 a1) `compare` (VOfferRef r2 a2) = case r1 `compare` r2 of+ EQ -> case (a1,a2) of+ (AspectAll,AspectAll) -> EQ+ (_ ,AspectAll) ->+-}++type VariantRefOrder = [[VariantRef]]+type VariantRefOrderMp = Map.Map VariantRef Int++variantOfferFromRef :: VariantRef -> VariantOffer+variantOfferFromRef (VarRef (0:_ )) = VOfferPre+variantOfferFromRef r@(VarRef (i:is)) = VOfferRef r AspectAll++variantOfferFromTop :: Int -> VariantOffer+variantOfferFromTop i = variantOfferFromRef (variantRefFromTop i)++variantOfferRef :: VariantOffer -> VariantRef+variantOfferRef VOfferPre = VarRef [0]+variantOfferRef (VOfferRef r _) = r++variantOfferAsp :: VariantOffer -> AspectRefs+variantOfferAsp VOfferPre = AspectAll+variantOfferAsp (VOfferRef _ a) = a++variantOfferRefTop :: VariantOffer -> Int+variantOfferRefTop (VOfferRef (VarRef (i:_)) _) = i++{-+variantOfferIsOffered :: VariantOffer -> VariantRefOrderMp -> Bool+variantOfferIsOffered VOfferAll _ = True+variantOfferIsOffered v s = Map.member (variantOfferRef v) s+-}++sortOnVariantRefOrderMp' :: VariantRefOrderMp -> [(VariantOffer,x)] -> [((VariantOffer,Bool),x)]+sortOnVariantRefOrderMp' m l+ = map snd+ $ sortOn fst+ $ [ ( VariantOfferForCompare (maybe 0 id o) (variantOfferAsp v)+ , ((v,isJust o || v == VOfferAll),x)+ )+ | (v,x) <- l, let o = Map.lookup (variantOfferRef v) m+ ]++sortOnVariantRefOrderMp :: VariantRefOrderMp -> [(VariantOffer,x)] -> [x]+-- sortOnVariantRefOrderMp m = map snd . sortOn fst . map (\(v,x) -> (Map.findWithDefault 0 (variantOfferRef v) m,x))+sortOnVariantRefOrderMp m vo+ = map snd+ $ sortOn fst+ $ [ ( VariantOfferForCompare o (variantOfferAsp v)+ , x+ )+ | (v,x) <- vo, let o = Map.findWithDefault 0 (variantOfferRef v) m+ ]++instance NM VariantOffer where+ mkNm VOfferPre = mkNm "pre"+ mkNm VOfferAll = mkNm "*"+ mkNm (VOfferRef r _) = mkNm r++-------------------------------------------------------------------------+-- Variant selection, required version+-------------------------------------------------------------------------++data VariantReqm+ = VReqmAll+ | VReqmNone+ | VReqmRef { vreqmVariant :: !VariantRef, vreqmAspects :: !AspectRefs }+ deriving (Show,Eq,Ord)++-- type VariantReqm = VariantOffer++variantReqmFromRef :: VariantRef -> VariantReqm+variantReqmFromRef r = VReqmRef r AspectAll++mbVariantReqmRef :: VariantReqm -> Maybe VariantRef+mbVariantReqmRef (VReqmRef r _) = Just r+mbVariantReqmRef _ = Nothing++variantReqmRef :: VariantReqm -> VariantRef+variantReqmRef = maybe (error "variantReqmRef") id . mbVariantReqmRef++variantReqmUpdRef :: VariantReqm -> VariantRef-> VariantReqm+variantReqmUpdRef v@(VReqmRef _ _) r = v {vreqmVariant = r}+variantReqmUpdRef v _ = v++variantReqmMatchOffer :: Maybe VariantRefOrderMp -> VariantReqm -> VariantOffer -> Bool+variantReqmMatchOffer _ VReqmAll _ = True+variantReqmMatchOffer _ VReqmNone _ = False+variantReqmMatchOffer _ _ VOfferAll = True+variantReqmMatchOffer Nothing (VReqmRef rr ra) (VOfferRef or oa) = rr == or && aspectRefsMatch oa ra+variantReqmMatchOffer (Just m) (VReqmRef rr ra) (VOfferRef or oa) = Map.member or m && aspectRefsMatch oa ra++instance NM VariantReqm where+ mkNm VReqmAll = mkNm "*"+ mkNm VReqmNone = mkNm "-"+ mkNm (VReqmRef r _) = mkNm r++-------------------------------------------------------------------------+-- Chunk reference+-------------------------------------------------------------------------++data ChunkRef+ = ChunkRef {chunkRefVar :: !VariantRef, chunkRefNm :: !Nm}+ deriving (Show,Eq,Ord)++chunkRefFromOfferNm :: VariantOffer -> Nm -> ChunkRef+chunkRefFromOfferNm o n = ChunkRef (variantOfferRef o) n++instance NM ChunkRef where+ mkNm (ChunkRef v n) = mkNm v `nmApd` n++-------------------------------------------------------------------------+-- Compiler restrictions+-------------------------------------------------------------------------++data CompilerRestriction+ = Restricted (Maybe [Int]) (Maybe [Int])+ deriving Show
+ src/UHC/Shuffle/MainAG.ag view
@@ -0,0 +1,839 @@+MODULE {UHC.Shuffle.MainAG} {}+{+import Network.URI+import System.IO+import Control.Monad+import Data.Array+import Data.List+import qualified Data.Map as Map+import UHC.Shuffle.Common+import UHC.Shuffle.CDoc+import UHC.Shuffle.CDocCommon+import UHC.Shuffle.CDocSubst+import UHC.Shuffle.CDocInline+import qualified Data.Set as Set+import qualified UHC.Util.FastSeq as Seq+import UHC.Util.Utils(initlast)++-- for debugging:+-- import UHC.Util.Utils (tr, trp, wordsBy)+-- import UHC.Util.Pretty+}++-------------------------------------------------------------------------+-- Inferfacing+-------------------------------------------------------------------------++WRAPPER AGItf++{+wrapAG_T :: Opts -> FPath -> XRefExcept -> NmChMp -> T_AGItf -> Syn_AGItf+wrapAG_T opts fp xr nmChMp pres+ = wrap_AGItf pres+ (Inh_AGItf+ { opts_Inh_AGItf = opts {optBaseName = mbBaseName, optBaseFPath = fp, optDefs = mbDefs `Map.union` optDefs opts}+ , xrefExcept_Inh_AGItf = xr+ , nmChMp_Inh_AGItf = nmChMp+ })+ where mbBaseName = maybe (Just (fpathBase fp)) Just (optBaseName opts)+ mbDefs = maybe Map.empty (\n -> Map.fromList [("basename",n),("base",n)]) mbBaseName+}++{+cdocSubstInline :: NmChMp -> CDoc -> IO (CDoc,Set.Set Nm,ErrM)+cdocSubstInline m d+ = do { let (d2,s,e) = cdocSubst m d+ ; if Map.null e+ then do { let (d3,il) = cdocInlineCDocIO d2+ ; (im,ie) <- il (Map.empty,Map.empty)+ ; if Map.null ie+ then do { let (d4,_,es) = cdocSubst im d3+ ; return (d4,s,es)+ }+ else return (d3,s,ie)+ }+ else return (d2,s,e)+ }+}++INCLUDE "ChunkAbsSyn.ag"++-------------------------------------------------------------------------+-- Global info+-------------------------------------------------------------------------++ATTR AGItf AllChunk AllLine AllWord AllGroup AllStrExpr [ opts: Opts | | ]++-------------------------------------------------------------------------+-- Common. Variant+-------------------------------------------------------------------------++{+instance CD VariantOffer where+ cd = cd . mkNm++cmpByVariantRefOrder :: VariantRefOrder -> VariantRef -> VariantRef -> Ordering+cmpByVariantRefOrder vo v1 v2+ = maybe EQ id $ listToMaybe $ catMaybes $ map c vo+ where c o = do { i1 <- elemIndex v1 o+ ; i2 <- elemIndex v2 o+ ; return (compare i1 i2)+ }++variantOfferAllLE_3 :: VariantRefOrder -> VariantReqm -> [VariantRef]+variantOfferAllLE_3 vo v+ = let allN = nub $ sort $ concat vo+ nrN = length allN+ nsN = [(0::Int) .. nrN-1]+ ixOf' v = elemIndex v allN+ ixOfV v = maybe Nothing ixOf' (mbVariantReqmRef v)+ ixOf v = maybe 0 id (ixOf' v)+ voPrefixes+ = map (\p@((v,_):_) -> (ixOf v,map ixOf $ nub $ sort $ (v:) $ concat $ map snd p))+ $ groupBy (\(v1,_) (v2,_) -> v1 == v2)+ $ sortBy (\(v1,_) (v2,_) -> compare v1 v2)+ $ concat+ $ map (\o -> zip o (inits o))+ $ vo+ m1 = map+ (\(n,ns)+ -> map snd . sort $ (zip (ns) (repeat True) ++ zip (nsN \\ ns) (repeat False))+ )+ voPrefixes+ m2 = array (0,nrN-1) (zip nsN (map (\r -> array (0,nrN-1) (zip nsN r)) m1))+ m3 = foldr+ (\n m+ -> foldr+ (\i m -> m // [(i,m ! i // [ (j,m ! i ! n && m ! n ! j || m ! i ! j) | j <- nsN ])])+ m nsN+ )+ m2 nsN+ nsV = maybe [] (\i -> assocs (m3 ! i)) (ixOfV v)+ allN' = case v of+ VReqmAll -> allN+ _ -> [ allN !! i | (i,b) <- nsV, b ]+ in sortBy (cmpByVariantRefOrder vo) $ nub $ sort allN'++variantOfferAllLE_4 :: Opts -> VariantRefOrderMp+variantOfferAllLE_4 opts+ = vm+ where vo = if optsHasNoVariantRefOrder opts then variantRefOrderDefault else optVariantRefOrder opts+ vs = variantOfferAllLE_3 vo (optGenReqm opts)+ vm = Map.fromList $ zip (sortBy (cmpByVariantRefOrder vo) vs) [1..]++variantRefOrderDefault :: VariantRefOrder+variantRefOrderDefault = [take 1 (map variantRefFromTop [1..])]++isAllowedCompilerVariant :: CompilerRestriction -> [Int] -> Bool+isAllowedCompilerVariant (Restricted mLower mUpper) v+ = mLower `leq` (Just v) && (Just v) `leq` mUpper+ where+ leq Nothing _ = True+ leq _ Nothing = True+ leq (Just p) (Just q) = p <= q+}++-------------------------------------------------------------------------+-- Allowed versions+-------------------------------------------------------------------------++ATTR AllChunk AllLine AllGroup [ allowedVariants: VariantRefOrderMp | | ]++SEM AGItf+ | AGItf loc . allowedVariants+ = variantOfferAllLE_4 @lhs.opts+ . allowedLaTeXVariants+ = variantOfferAllLE_4 (@lhs.opts {optGenReqm=VReqmAll})++-------------------------------------------------------------------------+-- Sequence nr (for ordering when printing)+-------------------------------------------------------------------------++ATTR AllChunk AllLine AllGroup [ | seqNr: Int | ]++SEM AGItf+ | AGItf dumLines . seqNr = 1++SEM Chunks+ | Cons hd . seqNr = @lhs.seqNr + 1++SEM Group+ | Group lines . seqNr = @lhs.seqNr + 1++-------------------------------------------------------------------------+-- Line counting, column counting+-------------------------------------------------------------------------++ATTR AllChunk AllLine AllGroup [ | lineNr: Int | ]+ATTR AllWord [ | colNr: Int | ]++SEM AGItf+ | AGItf dumLines . lineNr = 1++SEM Chunk+ | Ver Named loc . chunkLineNr+ = @lhs.lineNr+ lines . lineNr = @chunkLineNr + 1+ dumLines . lineNr = @lines.lineNr {- + 1 -}++SEM Chunk+ | Ver loc . dumIsOnlyNl+ = @lines.lineNr + 1 == @dumLines.lineNr++SEM Line+ | AsIs words . colNr = 1+ lhs . lineNr = @lhs.lineNr + 1+ | Named lhs . lineNr = @lhs.lineNr + 1+ | Groups loc . groupsLineNr+ = @lhs.lineNr+ groups . lineNr = @groupsLineNr + @extraLine+ lhs . lineNr = @groups.lineNr + @extraLine++SEM Groups+ | Cons tl . lineNr = @hd.lineNr + 1+ | Nil lhs . lineNr = @lhs.lineNr - 1++SEM Word+ | White Black loc . wordColNr = @lhs.colNr+ lhs . colNr = @lhs.colNr + length @chars++-------------------------------------------------------------------------+-- String of StrExpr+-------------------------------------------------------------------------++ATTR StrExpr [ | | str: String ]++SEM StrExpr+ | Str lhs . str = @str+ | Var lhs . str = Map.findWithDefault "" @nm (optDefs @lhs.opts)+ | Concat lhs . str = @e1.str ++ @e2.str+ | White lhs . str = @e1.str ++ " " ++ @e2.str+ | Seq lhs . str = "(" ++ concat (intersperse "," @es.strL) ++ ")"++ATTR StrExprs [ | | strL: {[String]} ]++SEM StrExprs+ | Nil lhs . strL = []+ | Cons lhs . strL = @hd.str : @tl.strL++ATTR MbStrExpr [ | | mbStr: {Maybe String} ]++SEM MbStrExpr+ | Just lhs . mbStr = Just @just.str+ | Nothing lhs . mbStr = Nothing++-------------------------------------------------------------------------+-- Left + right context+-------------------------------------------------------------------------++ATTR Words [ lCtxt: {[String]} lAllCtxt: {[String]} | | rCtxt: {[String]} ]+ATTR Word [ | lCtxt: {[String]} lAllCtxt: {[String]} rCtxt: {[String]} | ]++SEM Line+ | AsIs words . lCtxt = []+ . lAllCtxt = []++SEM Words+ | Nil lhs . rCtxt = []+ | Cons hd . rCtxt = @tl.rCtxt+ lhs . rCtxt = @hd.rCtxt++SEM Word+ | Black lhs . rCtxt = @chars : @lhs.rCtxt+ . lCtxt = @chars : @lhs.lCtxt+ . lAllCtxt = @chars : @lhs.lAllCtxt+ | White lhs . lAllCtxt = @chars : @lhs.lAllCtxt++-------------------------------------------------------------------------+-- Cross ref+-------------------------------------------------------------------------++{+data XRefKind = XRHsDef | XRAgAttrDef | XRAgAltDef | XRAgSemDef | XRHsUse | XRAgAttrUse deriving Show+data XRef = XRef { xrKind :: XRefKind, xrKeyL :: [String] } deriving Show++xrMainKey :: XRef -> String+xrMainKey = head . xrKeyL++xrKindIsDefining :: XRefKind -> Bool+xrKindIsDefining XRHsDef = True+xrKindIsDefining XRAgAttrDef = True+xrKindIsDefining XRAgAltDef = True+xrKindIsDefining XRAgSemDef = True+xrKindIsDefining _ = False++xrIsDefining :: XRef -> Bool+xrIsDefining = xrKindIsDefining . xrKind++type XRefL = Seq.FastSeq XRef+type XRefExcept = Set.Set String++passXR :: XRefExcept -> String -> ([XRef],Int) -> ([XRef],Int)+passXR exc r xr = if Set.member r exc then ([],0) else xr+}++ATTR AGItf AllNT [ xrefExcept: XRefExcept | | ]+ATTR AllWord AllLine [ | | xrefL USE {`Seq.union`} {Seq.empty} : XRefL ]+ATTR Word [ | rCtxtUsed: Int | ]+ATTR Words [ rCtxtUsed: Int | | ]++SEM Word+ | Black (loc.xrefL,lhs.rCtxtUsed)+ = let ctxtHuge = 10000000+ loclhs = ["lhs","loc"]+ none = ([],@lhs.rCtxtUsed - 1)+ def nms k cUsed+ = if any (flip Set.member @lhs.xrefExcept) nms then ([],0) else ([XRef k nms],cUsed)+ in if @lhs.rCtxtUsed <= 0 && isAlpha (head @chars)+ then case (@lhs.lAllCtxt,@lhs.lCtxt,@chars,@lhs.rCtxt) of+ (_,("@":_),nm1,(".":nm2:_))+ | nm1 `elem` loclhs -> def [nm2] XRAgAttrUse 2+ (_,("@":_),nm1,(".":nm2:_)) -> def [nm2,nm1] XRAgAttrUse 2+ (_,("@":_),nm1,_) -> def [nm1] XRAgAttrUse 0+ (_,("|":_),nm1,_) -> def [nm1] XRAgAltDef 0+ (_,(".":ll:_),nm1,("=":_))+ | ll `elem` loclhs -> def [nm1] XRAgAttrDef 1+ (_,(".":nm2:_),nm1,("=":_)) -> def [nm1,nm2] XRAgAttrDef 1+ (_,_,nm1,([sep]:nm2:_))+ | sep `elem` "._" -> def [nm2,nm1] XRHsUse 2+ | otherwise -> none+ (_,["SEM"],nm1,_) -> def [nm1] XRAgSemDef ctxtHuge+ (_,["data"],nm1,_) -> def [nm1] XRHsDef 0+ (_,["type"],nm1,_) -> def [nm1] XRHsDef 0+ ([],_,nm1,_) -> def [nm1] XRHsDef ctxtHuge+ (_,_,nm1,_)+ | nm1 `notElem` loclhs -> def [nm1] XRHsUse 0+ _ -> none+ else none+ lhs . xrefL = Seq.fromList @xrefL+ | White lhs . rCtxtUsed = 0++SEM Line+ | AsIs words . rCtxtUsed = 0++-------------------------------------------------------------------------+-- Named chunks+-------------------------------------------------------------------------++ATTR AllChunk AllLine AllGroup AGItf [ | | gathNmChMp USE {`Map.union`} {Map.empty}: NmChMp ]+ATTR AllChunk AllLine AllGroup AGItf [ nmChMp: NmChMp | | ]++SEM Chunk+ | Ver loc . nmChInfo = NmChInfo @chFullNm ChHere @lines.mbCDoc @lines.mkCDoc+ lhs . gathNmChMp = Map.insert @chFullNm @nmChInfo @lines.gathNmChMp+ | Named loc . nmChInfo = NmChInfo @cref ChHere @lines.mbCDoc @lines.mkCDoc+ lhs . gathNmChMp = Map.insert @cref @nmChInfo @lines.gathNmChMp++SEM Group+ | Group loc . gathNmChMp = case @userRef of+ Just (r,_) -> Map.singleton r (NmChInfo r ChHere @mbCDoc @mkCDoc)+ _ -> Map.empty+ lhs . gathNmChMp = Map.union @lines.gathNmChMp @gathNmChMp++SEM AGItf+ | AGItf chunks . nmChMp = @chunks.gathNmChMp `Map.union` @lhs.nmChMp+ dumLines . nmChMp = Map.empty++-------------------------------------------------------------------------+-- Adm for hideable groups of lines+-------------------------------------------------------------------------++{+data HideInfo+ = HideInfo+ { hiNm :: Nm+ , hiDescr :: CDoc+ , hiSeqNr :: Int+ , hiChDest :: ChDest+ , hiMbCD :: Maybe CDoc+ , hiChFullNm :: Nm+ }++type HideMp = Map.Map Nm HideInfo+}++-------------------------------------------------------------------------+-- Content replica, CDoc+-------------------------------------------------------------------------++{+mbCDocCmb :: Maybe CDoc -> Maybe CDoc -> Maybe CDoc+mbCDocCmb c1 c2 = maybe c1 (Just . (maybe CDoc_Emp id c1 `CDoc_Ver`)) c2+}++ATTR AllLine AllGroup [ | | mbCDoc USE {`mbCDocCmb`} {Nothing}: {Maybe CDoc} ]+ATTR AllGroup [ | | mbCDocL USE {++} {[]}: {[(VariantOffer,Maybe CDoc)]} ]++SEM Line+ | AsIs loc . cdoc = if cdIsEmpty @words.cdoc then CDoc_Str "" else @words.cdoc+ | Named loc . cdoc = CDoc_Ref @cref @mbVariantReqm ChHere+ | AsIs Named loc . mbCDoc = Just (CDoc_Pos (CPos (optBaseFPath @lhs.opts) @lhs.lineNr) @cdoc)+ | Groups lhs . mbCDoc = maybe Nothing snd $ initlast $ sortOnVariantRefOrderMp @lhs.allowedVariants @groups.mbCDocL++SEM Group+ | Group loc . mbCDocbase = fmap (chWrap @chOptions.chWrap) @lines.mbCDoc+ . isAllowed = variantReqmMatchOffer (Just @lhs.allowedVariants) (optGenReqm @lhs.opts) @variantOffer+ (loc.mbCDoc,loc.gathHideMp) = case @chOptions.chDest of+ _ | not @isAllowed+ -> (Nothing,Map.empty)+ ChHere -> (@mbCDocbase,Map.empty)+ h -> (Just (mkHideNmRef (cd n)),Map.singleton n (HideInfo n i @lhs.seqNr @chOptions.chDest @mbCDocbase @lhs.chFullNm))+ where (n,i) = case @userRef of+ Just (r,Just i ) -> (r,cd i)+ Just (r,Nothing) -> (r,cd r)+ _ -> (mkNm (show h) `nmApd` mkNm @lhs.seqNr,CDoc_Emp)+ lhs . mbCDocL = if @isAllowed then [(@variantOffer,@mbCDoc)] else []++ATTR AllWord [ | | cdoc USE {.|.} {CDoc_Emp} : CDoc ]++SEM Word+ | White Black lhs . cdoc = cd @chars+ | Expand lhs . cdoc = cd @exp.str++SEM Inline+ | URI lhs . cdoc = CDoc_Inl @str++-------------------------------------------------------------------------+-- Content replica making, MkCDoc only, no hidden stuff+-------------------------------------------------------------------------++{+mkCDocCmb :: MkCDoc -> MkCDoc -> MkCDoc+mkCDocCmb c1 c2 = \sel -> maybe (c1 sel) (Just . (maybe CDoc_Emp id (c1 sel) `CDoc_Ver`)) (c2 sel)++mkCDocEmpty :: MkCDoc+mkCDocEmpty = const Nothing+}++ATTR AllLine AllGroup [ | | mkCDoc USE {`mkCDocCmb`} {mkCDocEmpty}: {MkCDoc} ]+ATTR AllGroup [ | | mkCDocL USE {++} {[]}: {[(VariantOffer,MkCDoc)]} ]++SEM Line+ | AsIs Named lhs . mkCDoc = const @mbCDoc+ | Groups lhs . mkCDoc = \sel -> let mkCDocSortL = sortOnVariantRefOrderMp' (variantOfferAllLE_4 (@lhs.opts {optGenReqm=sel})) @groups.mkCDocL+ in maybe Nothing (\(_,((_,valid),mk)) -> if valid then mk sel else Nothing)+ $ initlast mkCDocSortL++SEM Group+ | Group loc . mkCDoc = \sel -> case @chOptions.chDest of+ ChHere -> fmap (chWrap @chOptions.chWrap) (@lines.mkCDoc sel)+ _ -> Nothing+ lhs . mkCDocL = [(@variantOffer,@mkCDoc)]++-------------------------------------------------------------------------+-- Gathering of hidden text+-------------------------------------------------------------------------++ATTR AllChunk AllGroup AllLine [ | | gathHideMp USE {`Map.union`} {Map.empty}: HideMp ]++SEM Group+ | Group lhs . gathHideMp = @gathHideMp `Map.union` @lines.gathHideMp++-------------------------------------------------------------------------+-- Chunks+-------------------------------------------------------------------------++{+data VariantChunkInfo+ = VariantChunkInfo+ { vciLineNr :: Int+ , vciSeqNr :: Int+ , vciVariantOffer :: VariantOffer+ , vciChunkRef :: ChunkRef+ , vciMinusL :: [ChunkRef]+ , vciChKind :: ChKind+ , vciChDest :: ChDest+ , vciMbModNm :: Maybe String+ , vciImps :: [String]+ , vciExps :: [String]+ , vciMbCD :: Maybe CDoc+ , vciMkCD :: MkCDoc+ , vciXRefL :: [XRef]+ } deriving Show++type VariantChunkInfoM = [(VariantOffer,[VariantChunkInfo])]++vciMToL :: VariantChunkInfoM -> [VariantChunkInfo]+vciMToL = concat . map snd++vciFullNm :: VariantChunkInfo -> Nm+vciFullNm i = mkNm (vciChunkRef i)++instance Eq VariantChunkInfo where+ i1 == i2 = vciVariantOffer i1 == vciVariantOffer i2++instance Ord VariantChunkInfo where+ compare i1 i2 = vciVariantOffer i1 `compare` vciVariantOffer i2++vciSortBySeqNr :: [VariantChunkInfo] -> [VariantChunkInfo]+vciSortBySeqNr = sortBy (\v1 v2 -> vciSeqNr v1 `compare` vciSeqNr v2)++vciVariantOfferFilter :: (VariantOffer -> Bool) -> [VariantChunkInfo] -> [VariantChunkInfo]+vciVariantOfferFilter f = filter (f . vciVariantOffer)++vciVariantOfferGroup :: [VariantChunkInfo] -> [[VariantChunkInfo]]+vciVariantOfferGroup = groupBy (\i1 i2 -> vciVariantOffer i1 == vciVariantOffer i2)++vciHasImpExp :: VariantChunkInfo -> Bool+vciHasImpExp i = not (null (vciImps i) && null (vciExps i))++vciIsPre :: VariantChunkInfo -> Bool+vciIsPre = (==VOfferPre) . vciVariantOffer++vciIsHS :: VariantChunkInfo -> Bool+vciIsHS = (==ChHS) . vciChKind++vciCD :: VariantChunkInfo -> CDoc+vciCD = maybe CDoc_Emp id . vciMbCD++vciHasCD :: VariantChunkInfo -> Bool+vciHasCD = isJust . vciMbCD++vciSplitPre :: [VariantChunkInfo] -> ([VariantChunkInfo],[VariantChunkInfo])+vciSplitPre = partition vciIsPre++vciTakePre :: VariantChunkInfoM -> ([VariantChunkInfo],VariantChunkInfoM)+vciTakePre is+ = case is of+ ((VOfferPre,p):r) -> (p,r)+ _ -> ([],is)++selectChunks :: Bool -> VariantReqm -> VariantRefOrderMp -> [VariantChunkInfo] -> [(VariantOffer,[VariantChunkInfo])]+selectChunks appMinus variantReqm allowedVariants agl+ = let (pre,nonPre) = vciSplitPre agl+ vAndVciL = map (\v -> let vreqm = variantReqmUpdRef variantReqm (variantOfferRef v)+ in ( v+ , vciSortBySeqNr+ $ vciVariantOfferFilter+ (\offer -> variantReqmMatchOffer Nothing vreqm offer)+ nonPre+ ) )+ [variantOfferFromRef r | r <- Map.keys allowedVariants]+ isNotMinused+ = let minuses = if appMinus then [ m | (_,vciL) <- vAndVciL, ml <- map vciMinusL vciL, m <- ml ] else []+ in \i -> vciChunkRef i `notElem` minuses+ in filter+ ( not.null.snd )+ ( (VOfferPre,pre)+ : map (\(v,vciL) -> (v,filter isNotMinused vciL)) vAndVciL+ )++data Build+ = Build+ { bldBase :: String+ , bldVariantReqm :: VariantReqm+ , bldCD :: CDoc+ , bldHideCD :: [(Nm,CDoc)]+ , bldNmChMp :: NmChMp+ }+}++-------------------------------------------------------------------------+-- Chunk options+-------------------------------------------------------------------------++{+chKindCmb ChPlain o = o+chKindCmb o _ = o++chDestCmb ChHere o = o+chDestCmb o _ = o++chWrapCmb ChWrapPlain o = o+chWrapCmb o _ = o++}++ATTR AllChunkOption [ | | chKind USE {`chKindCmb`} {ChPlain} : ChKind ]+ATTR AllChunkOption [ | | chDest USE {`chDestCmb`} {ChHere} : ChDest ]+ATTR AllChunkOption [ | | chWrap USE {`chWrapCmb`} {ChWrapPlain} : ChWrap ]++SEM ChunkOption+ | Kind lhs . chKind = @chKind+ | Dest lhs . chDest = @chDest+ | Wrap lhs . chWrap = @chWrap++-------------------------------------------------------------------------+-- Additional lines between chunks collapsed to single line+-------------------------------------------------------------------------++SEM Chunk+ | Ver loc . addBlankLine= if @dumIsOnlyNl then id else (.-. CDoc_Str "")++-------------------------------------------------------------------------+-- Gathering chunk info+-------------------------------------------------------------------------++ATTR AllChunk [ | | verChInfoL USE {++} {[]} : {[VariantChunkInfo]} ]++SEM Chunk+ | Ver loc . chInfo = VariantChunkInfo+ @chunkLineNr @lhs.seqNr+ @variantOffer (chunkRefFromOfferNm @variantOffer @subNm) @minusL+ @chOptions.chKind @chOptions.chDest @mbModNm.mbStr @imports.strL @exports.strL+ (fmap (@addBlankLine . chWrap (chWrapT2T @lhs.opts @chOptions.chKind)) @lines.mbCDoc)+ @lines.mkCDoc+ (Seq.toList @lines.xrefL)+ loc . isAllowed = isAllowedCompilerVariant @compRestrict (optCompiler @lhs.opts)+ lhs . verChInfoL = if @isAllowed then [@chInfo] else []++-------------------------------------------------------------------------+-- Collect dependencies of AG chunks+-------------------------------------------------------------------------++ATTR AGItf AllChunk [ | | deps USE {++} {[]} : {[String]} ]++SEM Chunk+ | Ver lhs . deps = if @chOptions.chKind == ChAG+ then @imports.strL+ else []++-------------------------------------------------------------------------+-- Line context, in chunks+-------------------------------------------------------------------------++ATTR AllLine AllChunk AllGroup [ chFullNm: Nm | | ]++SEM Chunk+ | Ver loc . chFullNm = vciFullNm @chInfo+ | Named loc . chFullNm = nciNm @nmChInfo++SEM AGItf+ | AGItf loc . chFullNm = NmEmp++-------------------------------------------------------------------------+-- Selecting from VariantReqm and building+-------------------------------------------------------------------------++SEM AGItf+ | AGItf loc . selChunks = selectChunks True (optGenReqm @lhs.opts) @allowedVariants @chunks.verChInfoL+ . selLaTeXChunks+ = selectChunks False VReqmAll @allowedLaTeXVariants @chunks.verChInfoL+ . wrapLhs2tex+ = \doWr -> if doWr then chWrap (optWrapLhs2tex @lhs.opts) else id+ . build = \bld chunks+ -> let fileBase = fromJust (optBaseName @lhs.opts)+ v = optGenReqm @lhs.opts+ d = bld @lhs.opts @wrapLhs2tex fileBase chunks+ m = Map.fromList [ (vciFullNm i,NmChInfo (vciFullNm i) (vciChDest i) (vciMbCD i) (vciMkCD i)) | (_,l) <- chunks, i <- l ]+ h = [ (hiChFullNm h,mkHideNmDef (cd n) (hiDescr h) (cd (hiMbCD h)))+ | (n,h) <- sortBy (\(_,h1) (_,h2) -> hiSeqNr h1 `compare` hiSeqNr h2) . Map.toList $ @chunks.gathHideMp+ ]+ in [Build fileBase v d h m]+++-------------------------------------------------------------------------+-- Wrap in Haddock comments+-------------------------------------------------------------------------++{+haddockize :: CDoc -> CDoc+haddockize d+ = "{-|" .-. d .-. "-}"+}++-------------------------------------------------------------------------+-- Wrap with line pragmas+-------------------------------------------------------------------------++{+linePragma :: String -> Opts -> String -> Int -> CDoc -> CDoc+linePragma pragcmt opts filename n c+ = if not (optLinePragmas opts) || cdIsEmpty c+ then c+ else CDoc_Ver (CDoc_Str ("{-" ++ pragcmt ++ " LINE "++show (n+1)++" \"" ++ filename ++ "\" " ++ pragcmt ++ "-}")) c++hsLinePragma+ = linePragma "#"++agLinePragma+ = linePragma ""+}++-------------------------------------------------------------------------+-- Gen AG+-------------------------------------------------------------------------++{+buildAGImps :: VariantChunkInfo -> CDoc+buildAGImps = cdVer . map (\imp -> "INCLUDE \"" .|. imp .|. ".ag\"") . vciImps++buildAG :: Opts -> (Bool -> CDoc -> CDoc) -> String -> VariantChunkInfoM -> CDoc+buildAG opts wrap fileBase is+ = let (pre,noPre) = vciTakePre is+ noPre' = vciMToL noPre+ h p = "{" .-. p .-. "}"+ mk i = case vciChKind i of+ ChHaddock -> h (haddockize (vciCD i))+ ChHS -> agLinePragma opts (fpathToStr $ optBaseFPath opts) (vciLineNr i) (h (vciCD i))+ _ -> buildAGImps i .-. agLinePragma opts (fpathToStr $ optBaseFPath opts) (vciLineNr i) (vciCD i)+ ish = filter vciIsHS noPre'+ buildImpExp = if optAGModHeader opts+ then buildAGHSModImpExp fileBase ish+ else h (buildHSModImpExp fileBase ish)+ pph = if any vciHasImpExp ish+ then wrap True buildImpExp+ else CDoc_Emp+ cds = map (\i -> let vnm = vciFullNm i+ in (wrap (not (vciIsPre i)) (mk i))+ )+ $ vciSortBySeqNr+ $ noPre'+ d = (if optPreamble opts then cdVer (map (wrap False . vciCD) pre) else CDoc_Emp)+ .-. pph+ .-. (cdVer cds)+ in d++buildAGHSModImpExp :: String -> [VariantChunkInfo] -> CDoc+buildAGHSModImpExp fileBase is = buildAGHSModuleHead fileBase is .-. "{" .-. buildHSImps is .-. "}"++buildAGHSModuleHead :: String -> [VariantChunkInfo] -> CDoc+buildAGHSModuleHead fileBase is+ = let ismie = [ i | i <- is , isJust (vciMbModNm i) || not (null (vciExps i) && null (vciImps i)) ]+ isie = [ i | i <- ismie, not (null (vciExps i) && null (vciImps i)) ]+ e = [ vciExps i | i <- isie, not (null (vciExps i)) ]+ m = catMaybes . map vciMbModNm $ ismie+ exps = cdListSepV "{" "}" ", " . map (cdListSep "" "" ", ") $ e+ modNm = if null m then fileBase else head m+ in "MODULE" .#. ("{" ++ modNm ++ "}") .#. exps+}++ATTR AGItf [ | | bldAG: {[Build]} ]++SEM AGItf+ | AGItf lhs . bldAG = @build buildAG @selChunks++-------------------------------------------------------------------------+-- Gen LaTeX+-------------------------------------------------------------------------++{+mkCmdNmDef :: CDoc -> CDoc -> CDoc+mkCmdNmDef = mkTexCmdDef "chunkCmdDef"++mkHideNmDef :: CDoc -> CDoc -> CDoc -> CDoc+mkHideNmDef = mkTexCmd3 "chunkHideDef"++mkHideNmRef :: CDoc -> CDoc+mkHideNmRef = mkTexCmdUse "chunkHideRef"++mkCmdNmUse :: CDoc -> CDoc+mkCmdNmUse = mkTexCmdUse' "chunkCmdUse"++mkCmdInx :: CDoc -> CDoc+mkCmdInx = mkTexCmdUse' "chunkIndex"++mkLabel :: CDoc -> CDoc+mkLabel = mkTexCmdUse' "label"++mkMetaInfo :: CDoc -> String -> CDoc+mkMetaInfo lab fileBase = mkLabel lab -- .-. mkTexCmdDef "chunkMetaDef" lab (cd fileBase)++buildLaTeX :: Opts -> (Bool -> CDoc -> CDoc) -> String -> VariantChunkInfoM -> CDoc+buildLaTeX opts wrap fileBase is+ = let (pre,noPre) = vciTakePre is+ noPre' = vciMToL noPre+ versions = nub $ map (variantOfferRefTop.vciVariantOffer) $ noPre'+ missing = if null versions then []+ else [minimum versions .. maximum versions] \\ versions+ mkInx+ = let styleFmt = if optWrapLhs2tex opts == ChWrapCode then "||" else "|"+ in \ix+ -> let n = foldr1 (\x y -> y ++ "!" ++ x) . xrKeyL $ ix+ dfmt = CDoc_Emp -- if xrIsDefining ix then text (styleFmt ++ "emph") else CDoc_Emp+ in mkCmdInx (n .|. dfmt)+ mkContent = let mk = wrap True . vciCD+ in if optIndex opts+ then \i -> cdVer (map mkInx (vciXRefL i)) .-. mk i+ else mk+ ppNoPreL+ = map (\is -> let vnm = mkNm (vciVariantOffer (head is))+ nm = mkNm fileBase `nmApd` vnm+ cnm = cd nm+ (nms,pps)+ = unzip+ . map (\(nr,i) -> let cn = cd (nm `nmApd` mkNm nr)+ content = mkContent i+ in ( cn+ , mkCmdNmDef cn (mkMetaInfo cn fileBase .-. content)+ .-. (let cna = cd (nm `nmApd` chunkRefNm (vciChunkRef i))+ in mkCmdNmDef cna (mkMetaInfo cna fileBase .-. mkCmdNmUse cn)+ )+ )+ )+ . zip [(0::Int)..]+ $ is+ content = cdVer pps .-. mkCmdNmDef cnm (mkMetaInfo cnm fileBase .-. cdVer (map mkCmdNmUse nms))+ in (content)+ )+ . vciVariantOfferGroup+ $ noPre'+ d = (if optPreamble opts then cdVer (map (wrap False . vciCD) pre) else CDoc_Emp)+ .-. cdVer ppNoPreL+ .-. cdVer (map (\v -> mkCmdNmDef (cdDots [cd fileBase,cd v]) CDoc_Emp) missing)+ in d+}++ATTR AGItf [ | | bldLaTeX: {[Build]} ]++SEM AGItf+ | AGItf lhs . bldLaTeX = @build buildLaTeX @selLaTeXChunks++-------------------------------------------------------------------------+-- Gen Haskell+-------------------------------------------------------------------------++{+mkModNm :: [CDoc] -> CDoc+mkModNm = cdHor++buildHSImps :: [VariantChunkInfo] -> CDoc+buildHSImps = cdVer . map (cdVer . map ("import" .#.) . vciImps)++buildHSModuleHead :: String -> [VariantChunkInfo] -> CDoc+buildHSModuleHead fileBase is+ = let ismie = [ i | i <- is , isJust (vciMbModNm i) || not (null (vciExps i) && null (vciImps i)) ]+ isie = [ i | i <- ismie, not (null (vciExps i) && null (vciImps i)) ]+ -- e = filter (not.null) . map vciExps $ isie+ e = [ vciExps i | i <- isie, not (null (vciExps i)) ]+ m = catMaybes . map vciMbModNm $ ismie+ exps = if null e then CDoc_Emp+ else cdListSepV "( " " )" ", " . map (cdListSep "" "" ", ") $ e+ modNm = if null m then fileBase else head m+ in "module" .#. modNm .-. {- indent 2 -} (exps .-. "where")++buildHSModImpExp :: String -> [VariantChunkInfo] -> CDoc+buildHSModImpExp fileBase is = buildHSModuleHead fileBase is .-. buildHSImps is++buildHS :: Opts -> (Bool -> CDoc -> CDoc) -> String -> VariantChunkInfoM -> CDoc+buildHS opts wrap fileBase is+ = let mk i = case vciChKind i of+ ChHaddock -> haddockize (vciCD i)+ _ -> vciCD i+ (pre,noPre) = vciTakePre is+ noPre' = vciMToL noPre+ ppMod = buildHSModImpExp fileBase (vciMToL is)+ ppNoPreL+ = map ( cdVer+ . (map (\i+ -> hsLinePragma opts (fpathToStr $ optBaseFPath opts) (vciLineNr i)+ (wrap (vciHasCD i) (mk i))+ ) ) )+ $ vciVariantOfferGroup+ $ vciSortBySeqNr+ $ noPre'+ isEmpty = all (isNothing.vciMbCD) noPre'+ ppNoPre = cdVer ppNoPreL+ in if isEmpty+ then CDoc_Emp+ else if optPlain opts+ then ppNoPre+ else (if optPreamble opts then cdVer (map (wrap False . vciCD) pre) else CDoc_Emp)+ .-. wrap True ppMod+ .-. ppNoPre+}++ATTR AGItf [ | | bldHS: {[Build]} ]++SEM AGItf+ | AGItf lhs . bldHS = @build buildHS @selChunks
+ uuagc_options view
@@ -0,0 +1,17 @@+file : "src/UHC/Shuffle/AspectExpr.ag"+options : data, rename, module "UHC.Shuffle.AspectExpr"++file: "src/UHC/Shuffle/AspectExprEval.ag"+options : catas, semfuns, signatures, pretty, rename++file : "src/UHC/Shuffle/CDoc.ag"+options : data, rename, module "UHC.Shuffle.CDoc"++file : "src/UHC/Shuffle/CDocSubst.ag"+options : catas, semfuns, signatures, pretty, rename++file : "src/UHC/Shuffle/CDocInline.ag"+options : catas, semfuns, signatures, pretty, rename++file : "src/UHC/Shuffle/MainAG.ag"+options : data, catas, semfuns, signatures, pretty, rename, module "UHC.Shuffle.MainAG"