optpragmas { {-# LANGUAGE CPP #-} } 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) #if __GLASGOW_HASKELL__ >= 710 import Prelude hiding (Word) #endif -- 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 = variantOfferIsPre . 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 -- | 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) -} selectChunks :: Bool -> VariantReqm -> VariantRefOrderMp -> [VariantChunkInfo] -> [(VariantOffer,[VariantChunkInfo])] selectChunks appMinus variantReqm allowedVariants agl = 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 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 (\_ -> id) 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 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) 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 :: (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 = let mk i = case vciChKind i of ChHaddock -> haddockize (vciCD i) _ -> vciCD i (pre,noPre) = vciTakePre is (preHS, preOther) = partition vciIsHS pre noPre' = vciMToL noPre ppMod = buildHSModImpExp wrap fileBase preHS (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 buildHSPre wrap preOther else CDoc_Emp) .-. wrap True ppMod .-. ppNoPre } ATTR AGItf [ | | bldHS: {[Build]} ] SEM AGItf | AGItf lhs . bldHS = @build buildHS @selChunks