diff --git a/shuffle.cabal b/shuffle.cabal --- a/shuffle.cabal +++ b/shuffle.cabal @@ -1,5 +1,5 @@ Name: shuffle -Version: 0.1.2.0 +Version: 0.1.3.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 diff --git a/src/UHC/Shuffle/ChunkParser.hs b/src/UHC/Shuffle/ChunkParser.hs --- a/src/UHC/Shuffle/ChunkParser.hs +++ b/src/UHC/Shuffle/ChunkParser.hs @@ -28,7 +28,7 @@ type ScanOptsMp = Map.Map ScState ScanOpts chKindMp = Map.fromList - [ ("hs",ChHS), ("ag",ChAG), ("plain",ChPlain), ("haddock",ChHaddock) ] + [ ("hs",ChHS), ("ag",ChAG), ("plain",ChPlain), ("haddock",ChHaddock), ("lhs2tex",ChLhs2TeX) ] `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) ] diff --git a/src/UHC/Shuffle/Common.hs b/src/UHC/Shuffle/Common.hs --- a/src/UHC/Shuffle/Common.hs +++ b/src/UHC/Shuffle/Common.hs @@ -22,11 +22,15 @@ , ChKind(..), ChDest(..), ChWrap(..) , VariantRef(..) + , variantRefIsPre , AspectRefs(..) , variantReqmRef, mbVariantReqmRef , variantRefFromTop , variantReqmUpdRef - , VariantOffer(..), VariantReqm(..) + , VariantOffer(..) + , variantOfferIsPre + , VariantReqm(..) + , variantReqmIsPre , variantOfferFromRef, variantReqmFromRef , variantOfferFromTop , variantOfferRef, variantOfferRefTop @@ -220,6 +224,7 @@ | ChHS | ChPlain | ChDocLaTeX -- restricted LaTeX for documentation + | ChLhs2TeX -- lhs2tex -- | ChTexInfo -- | ChHtml -- | ChTwiki @@ -263,6 +268,11 @@ = VarRef {vrefRefs :: ![Int]} deriving (Show,Eq,Ord) +variantRefIsPre :: VariantRef -> Bool +variantRefIsPre (VarRef (0:_)) = True +variantRefIsPre _ = False + + instance NM VariantRef where mkNm (VarRef l) = nmApdL $ map mkNm l @@ -299,10 +309,15 @@ data VariantOffer = VOfferAll - | VOfferPre + | VOfferPre { vofferAspect :: !AspectRefs} | VOfferRef {vofferVariant :: !VariantRef, vofferAspect :: !AspectRefs} deriving (Show,Eq,Ord) +variantOfferIsPre :: VariantOffer -> Bool +variantOfferIsPre o = case o of + VOfferPre _ -> True + _ -> False + {- instance Ord VariantOffer where VOfferAll `compare` VOfferAll = EQ @@ -321,18 +336,19 @@ type VariantRefOrderMp = Map.Map VariantRef Int variantOfferFromRef :: VariantRef -> VariantOffer -variantOfferFromRef (VarRef (0:_ )) = VOfferPre -variantOfferFromRef r@(VarRef (i:is)) = VOfferRef r AspectAll +variantOfferFromRef r + | variantRefIsPre r = VOfferPre AspectAll + | otherwise = VOfferRef r AspectAll variantOfferFromTop :: Int -> VariantOffer variantOfferFromTop i = variantOfferFromRef (variantRefFromTop i) variantOfferRef :: VariantOffer -> VariantRef -variantOfferRef VOfferPre = VarRef [0] +variantOfferRef (VOfferPre _) = VarRef [0] variantOfferRef (VOfferRef r _) = r variantOfferAsp :: VariantOffer -> AspectRefs -variantOfferAsp VOfferPre = AspectAll +variantOfferAsp (VOfferPre a) = a variantOfferAsp (VOfferRef _ a) = a variantOfferRefTop :: VariantOffer -> Int @@ -366,8 +382,8 @@ ] instance NM VariantOffer where - mkNm VOfferPre = mkNm "pre" - mkNm VOfferAll = mkNm "*" + mkNm (VOfferPre _) = mkNm "pre" + mkNm VOfferAll = mkNm "*" mkNm (VOfferRef r _) = mkNm r ------------------------------------------------------------------------- @@ -380,6 +396,10 @@ | VReqmRef { vreqmVariant :: !VariantRef, vreqmAspects :: !AspectRefs } deriving (Show,Eq,Ord) +variantReqmIsPre :: VariantReqm -> Bool +variantReqmIsPre (VReqmRef r _) = variantRefIsPre r +variantReqmIsPre _ = False + -- type VariantReqm = VariantOffer variantReqmFromRef :: VariantRef -> VariantReqm @@ -392,7 +412,7 @@ variantReqmRef :: VariantReqm -> VariantRef variantReqmRef = maybe (error "variantReqmRef") id . mbVariantReqmRef -variantReqmUpdRef :: VariantReqm -> VariantRef-> VariantReqm +variantReqmUpdRef :: VariantReqm -> VariantRef -> VariantReqm variantReqmUpdRef v@(VReqmRef _ _) r = v {vreqmVariant = r} variantReqmUpdRef v _ = v @@ -402,6 +422,7 @@ 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 +variantReqmMatchOffer _ (VReqmRef rr ra) (VOfferPre oa) = variantRefIsPre rr && aspectRefsMatch oa ra instance NM VariantReqm where mkNm VReqmAll = mkNm "*" diff --git a/src/UHC/Shuffle/MainAG.ag b/src/UHC/Shuffle/MainAG.ag --- a/src/UHC/Shuffle/MainAG.ag +++ b/src/UHC/Shuffle/MainAG.ag @@ -478,7 +478,7 @@ vciHasImpExp i = not (null (vciImps i) && null (vciExps i)) vciIsPre :: VariantChunkInfo -> Bool -vciIsPre = (==VOfferPre) . vciVariantOffer +vciIsPre = variantOfferIsPre . vciVariantOffer vciIsHS :: VariantChunkInfo -> Bool vciIsHS = (==ChHS) . vciChKind @@ -492,31 +492,47 @@ vciSplitPre :: [VariantChunkInfo] -> ([VariantChunkInfo],[VariantChunkInfo]) vciSplitPre = partition vciIsPre +-- | Take the (possibly absent) Pre stuff, filtering the chunks +vciTakeFilterPre :: (VariantChunkInfo -> Bool) -> VariantChunkInfoM -> ([VariantChunkInfo],VariantChunkInfoM) +vciTakeFilterPre pred is + = case span (variantOfferIsPre . fst) is of + (pre,nonPre) -> (concatMap (filter pred . snd) pre, nonPre) +{- + ((VOfferPre _,p):r) -> (filter pred p,r) + _ -> ([],is) +-} + vciTakePre :: VariantChunkInfoM -> ([VariantChunkInfo],VariantChunkInfoM) +vciTakePre = vciTakeFilterPre (const True) +{- vciTakePre is = case is of ((VOfferPre,p):r) -> (p,r) - _ -> ([],is) + _ -> ([],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] + = filter + ( not . null . snd ) + ( vAndVciPreL + ++ map (\(v,vciL) -> (v,filter isNotMinused vciL)) vAndVciL + ) + where (pre,nonPre) = vciSplitPre agl + filterAllowed allowedVariants vciL + = [ ( v + , vciSortBySeqNr $ vciVariantOfferFilter + (\offer -> variantReqmMatchOffer Nothing vreqm offer) + vciL + ) + | v <- allowedVariants + , let vreqm = variantReqmUpdRef variantReqm (variantOfferRef v) + ] + vAndVciPreL = filterAllowed [VOfferPre AspectAll] pre + vAndVciL = filterAllowed (map variantOfferFromRef $ Map.keys allowedVariants) nonPre 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 @@ -670,7 +686,7 @@ ish = filter vciIsHS noPre' buildImpExp = if optAGModHeader opts then buildAGHSModImpExp fileBase ish - else h (buildHSModImpExp fileBase ish) + else h (buildHSModImpExp (\_ -> id) fileBase [] ish) pph = if any vciHasImpExp ish then wrap True buildImpExp else CDoc_Emp @@ -787,6 +803,9 @@ mkModNm :: [CDoc] -> CDoc mkModNm = cdHor +buildHSPre :: (Bool -> CDoc -> CDoc) -> [VariantChunkInfo] -> CDoc +buildHSPre wrap pre = cdVer [ wrap False $ vciCD p | p <- pre ] + buildHSImps :: [VariantChunkInfo] -> CDoc buildHSImps = cdVer . map (cdVer . map ("import" .#.) . vciImps) @@ -802,8 +821,9 @@ 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 +buildHSModImpExp :: (Bool -> CDoc -> CDoc) -> String -> [VariantChunkInfo] -> [VariantChunkInfo] -> CDoc +buildHSModImpExp wrap fileBase preHS is + = buildHSPre wrap preHS .-. buildHSModuleHead fileBase is .-. buildHSImps is buildHS :: Opts -> (Bool -> CDoc -> CDoc) -> String -> VariantChunkInfoM -> CDoc buildHS opts wrap fileBase is @@ -811,8 +831,9 @@ ChHaddock -> haddockize (vciCD i) _ -> vciCD i (pre,noPre) = vciTakePre is + (preHS, preOther) = partition vciIsHS pre noPre' = vciMToL noPre - ppMod = buildHSModImpExp fileBase (vciMToL is) + ppMod = buildHSModImpExp wrap fileBase preHS (vciMToL is) ppNoPreL = map ( cdVer . (map (\i @@ -828,7 +849,7 @@ then CDoc_Emp else if optPlain opts then ppNoPre - else (if optPreamble opts then cdVer (map (wrap False . vciCD) pre) else CDoc_Emp) + else (if optPreamble opts then buildHSPre wrap preOther else CDoc_Emp) .-. wrap True ppMod .-. ppNoPre } diff --git a/src/UHC/Shuffle/Version.hs b/src/UHC/Shuffle/Version.hs --- a/src/UHC/Shuffle/Version.hs +++ b/src/UHC/Shuffle/Version.hs @@ -1,2 +1,2 @@ module UHC.Shuffle.Version where -version = "0.1.2.0" +version = "0.1.3.0"