diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,6 @@ +import Distribution.Simple (defaultMainWithHooks) +import Distribution.Simple.UUAGC (uuagcLibUserHook) +import UU.UUAGC (uuagc) + +main :: IO () +main = defaultMainWithHooks (uuagcLibUserHook uuagc) diff --git a/shuffle.cabal b/shuffle.cabal new file mode 100644 --- /dev/null +++ b/shuffle.cabal @@ -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 diff --git a/src/Shuffle.hs b/src/Shuffle.hs new file mode 100644 --- /dev/null +++ b/src/Shuffle.hs @@ -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||( *) (to be obsolete, renamed to --gen-reqm)") + "generate for version, default=none" + , Option "g" ["gen-reqm"] (ReqArg oGenReqm "all||( *)") + "generate for version, default=none" + , Option "" ["compiler"] (ReqArg oCompiler "") + "Version of the GHC compiler, i.e. 6.6" + , Option "" ["hidedest"] (ReqArg oHideDest "here|appx=") + "destination of text marked as 'hide', default=here" + , Option "" ["order"] (ReqArg oVariantOrder " (to be obsolete, renamed to --variant-order)") + "variant order" + , Option "" ["variant-order"] (ReqArg oVariantOrder "") + "variant order" + , Option "b" ["base"] (ReqArg oBase "") + "base name, default=derived from filename" + , Option "" ["xref-except"] (ReqArg oXRefExcept "") + "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 "") + "Prefix of generated makefile vars." + , Option "" ["depsrcvar"] (OptArg oDepSrcVar "") + "Source base-directory" + , Option "" ["depdstvar"] (OptArg oDepDstVar "") + "Destination base-directory" + , Option "" ["depmainvar"] (OptArg oDepMainVar "") + "Varname for the list of main files" + , Option "" ["depdpdsvar"] (OptArg oDepDpdsVar "") + "Varname for the list of dependencies" + , Option "" ["deporigdpdsvar"] (OptArg oDepOrigDpdsVar "") + "Varname for the list of original dependencies" + , Option "" ["depderivdpdsvar"] (OptArg oDepDerivDpdsVar "") + "Varname for the list of derived dependencies" + , Option "" ["depbase"] (OptArg oDepBaseDir "") + "Root directory for the dependency generation" + , Option "" ["depign"] (OptArg oDepIgn "( )*") + "Totally ignored dependencies" + , Option "" ["depterm"] (OptArg oDepTerm "( => + ,)*") + "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) diff --git a/src/UHC/Shuffle/AspectExpr.ag b/src/UHC/Shuffle/AspectExpr.ag new file mode 100644 --- /dev/null +++ b/src/UHC/Shuffle/AspectExpr.ag @@ -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 +} diff --git a/src/UHC/Shuffle/AspectExprAbsSyn.ag b/src/UHC/Shuffle/AspectExprAbsSyn.ag new file mode 100644 --- /dev/null +++ b/src/UHC/Shuffle/AspectExprAbsSyn.ag @@ -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 diff --git a/src/UHC/Shuffle/AspectExprEval.ag b/src/UHC/Shuffle/AspectExprEval.ag new file mode 100644 --- /dev/null +++ b/src/UHC/Shuffle/AspectExprEval.ag @@ -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 + diff --git a/src/UHC/Shuffle/CDoc.ag b/src/UHC/Shuffle/CDoc.ag new file mode 100644 --- /dev/null +++ b/src/UHC/Shuffle/CDoc.ag @@ -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 .|. "%" +} diff --git a/src/UHC/Shuffle/CDocAbsSyn.ag b/src/UHC/Shuffle/CDocAbsSyn.ag new file mode 100644 --- /dev/null +++ b/src/UHC/Shuffle/CDocAbsSyn.ag @@ -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 diff --git a/src/UHC/Shuffle/CDocCommon.hs b/src/UHC/Shuffle/CDocCommon.hs new file mode 100644 --- /dev/null +++ b/src/UHC/Shuffle/CDocCommon.hs @@ -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 + diff --git a/src/UHC/Shuffle/CDocCommonAG.ag b/src/UHC/Shuffle/CDocCommonAG.ag new file mode 100644 --- /dev/null +++ b/src/UHC/Shuffle/CDocCommonAG.ag @@ -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 | | ] diff --git a/src/UHC/Shuffle/CDocInline.ag b/src/UHC/Shuffle/CDocInline.ag new file mode 100644 --- /dev/null +++ b/src/UHC/Shuffle/CDocInline.ag @@ -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 + diff --git a/src/UHC/Shuffle/CDocSubst.ag b/src/UHC/Shuffle/CDocSubst.ag new file mode 100644 --- /dev/null +++ b/src/UHC/Shuffle/CDocSubst.ag @@ -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])) + diff --git a/src/UHC/Shuffle/ChunkAbsSyn.ag b/src/UHC/Shuffle/ChunkAbsSyn.ag new file mode 100644 --- /dev/null +++ b/src/UHC/Shuffle/ChunkAbsSyn.ag @@ -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 diff --git a/src/UHC/Shuffle/ChunkParser.hs b/src/UHC/Shuffle/ChunkParser.hs new file mode 100644 --- /dev/null +++ b/src/UHC/Shuffle/ChunkParser.hs @@ -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 "" "" 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 "" "" infpNone ScSkip) + +pText :: (IsParser p Tok) => p Tok +pText = pSym (Tok TkText "" "" 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 + diff --git a/src/UHC/Shuffle/Common.hs b/src/UHC/Shuffle/Common.hs new file mode 100644 --- /dev/null +++ b/src/UHC/Shuffle/Common.hs @@ -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 diff --git a/src/UHC/Shuffle/MainAG.ag b/src/UHC/Shuffle/MainAG.ag new file mode 100644 --- /dev/null +++ b/src/UHC/Shuffle/MainAG.ag @@ -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 diff --git a/uuagc_options b/uuagc_options new file mode 100644 --- /dev/null +++ b/uuagc_options @@ -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"