makedo (empty) → 0.1
raw patch · 8 files changed
+1039/−0 lines, 8 filesdep +HSHdep +basedep +directorysetup-changed
Dependencies added: HSH, base, directory, filepath, process
Files
- CorpusFiles.hs +19/−0
- Example.hs +727/−0
- LICENSE +30/−0
- Makedo.hs +2/−0
- Makedo/Contained.hs +30/−0
- Makedo/Target.hs +163/−0
- Setup.hs +2/−0
- makedo.cabal +66/−0
+ CorpusFiles.hs view
@@ -0,0 +1,19 @@+module CorpusFiles where++extCleanStructuredData :: String+extCleanStructuredData = "nlg-json"++extEnChoice :: String -- ^ @[foo]@ is selected, @bar@ is unselected+extEnChoice = "en"++extDataPerDocument :: String+extDataPerDocument = "data"++extDataPerSentence :: String+extDataPerSentence = "data-selected"++extDataFragments :: String+extDataFragments = "data-fragments"++extEnFragments :: String+extEnFragments = "en-fragments"
+ Example.hs view
@@ -0,0 +1,727 @@+{-# LANGUAGE NamedFieldPuns, RecordWildCards #-}++import Control.Applicative+import Control.Monad+import Data.List+import Data.Maybe+import System.Directory+import System.FilePath+import Makedo+import Makedo.Contained+import HSH+import System.IO.HVFS.Utils+import qualified Data.ByteString as B++import CorpusFiles++-- ----------------------------------------------------------------------+-- customise here+-- ----------------------------------------------------------------------++f_DATASET = "dev"+-- f_DATASET = "test"++d_ORIGINALS = "data"++d_SENTENCE_SELECTION = "sentence-selection"+d_SENTENCE_SELECTION_SUBSET = d_SENTENCE_SELECTION <.> "subset-" ++ x_REFERENCE+d_DATA_SELECTION = "data-selection"+d_DATA_SELECTION_SUBSET = d_DATA_SELECTION <.> "subset-" ++ x_REFERENCE+d_FRAGMENTS = "fragments-extracted"+d_SCORES = "scores"++d_WORK_DOC_ALIGNED = "doc-aligned"+d_WORK_PREPROCESSED = "preprocessed"+d_SRC = d_ORIGINALS </> "document-pairs"+d_LLR_1 = "doc-llr-1"+d_LLR_2 = "doc-llr-2"++d_REFERENCE = d_ORIGINALS </> f_DATASET ++ "-set"+x_REFERENCE = "reference-" ++ f_DATASET+d_FRAGMENTS_REFERENCE = "fragments-reference"+d_FRAGMENTS_BASELINE = "fragments-baseline"+d_PEERS = "peers"++d_SENTENCE_SELECTION_REFERENCE = d_SENTENCE_SELECTION <.> x_REFERENCE++d_CALCULATORS = "../calculators"+d_BIN = "cabal-dev/bin"+d_RASP_HOME = "/opt/rasp"++f_DATASET :: String+x_REFERENCE :: String++d_ORIGINALS :: FilePath+d_SENTENCE_SELECTION :: FilePath+d_FRAGMENTS :: FilePath+d_SENTENCE_SELECTION_REFERENCE :: FilePath+d_SENTENCE_SELECTION_SUBSET :: FilePath+d_FRAGMENTS_REFERENCE :: FilePath+d_FRAGMENTS_BASELINE :: FilePath+d_REFERENCE :: FilePath+d_DATA_SELECTION :: FilePath+d_DATA_SELECTION_SUBSET :: FilePath+d_SCORES :: FilePath+d_WORK_DOC_ALIGNED :: FilePath+d_WORK_PREPROCESSED :: FilePath+d_SRC :: FilePath+d_LLR_1 :: FilePath+d_LLR_2 :: FilePath+d_BIN :: FilePath+d_CALCULATORS :: FilePath+d_RASP_HOME :: FilePath+d_PEERS :: FilePath++ssMethods :: [ SentSelMethod ]+ssMethods = [ SentSelBaselineN 1+ , SentSelBaselineA+ ]+ ++ map SentSelThreshold sthresholds+ where+ sthresholds = [ 60 ]++dsMethods :: [ DataSelMethod ]+dsMethods = DataSelAll : [ m t | m <- tmethods, t <- dthresholds ]+ where+ tmethods = [ DataSelSingle, DataSelDisj ]+ dthresholds = [ 15 ]++llrMethods :: [ LlrMethod ]+llrMethods = [ LlrNoRecompute+ , LlrRecomputeSent+ , LlrRecomputeDoc+ ]++fbMethods :: [ FragBaselineMethod ]+fbMethods = [ FragBaselineAll+ , FragBaselineCutoff 1+ , FragBaselineCutoff 2 ]++parallelRTS :: [String]+parallelRTS = ["+RTS", "-N", "-RTS"]++-- ----------------------------------------------------------------------++main :: IO ()+main = redoMain $ concatMap allTargets pipelineTargets++pipelineTargets :: [Contained]+pipelineTargets = concat+ [ initialiseTargets+ , docTargets+ , preprocessedTargets+ , llr1Targets+ , sentenceSelectionTargets+ , dataSelectionTargets+ , llr2Targets+ , fragmentExtractionTargets+ , referenceTargets+ , scoringTargets+ ]++initialiseTargets :: [Contained]+initialiseTargets = singleton $ Contained [] [] [target initialise]++initialise :: ExactTarget+initialise = ExactTarget "init" "[0] set up initial directories" $ const+ $ mapM_ (createDirectoryIfMissing True) containerDirs++-- | See 'Contained'+containerDirs :: [FilePath]+containerDirs = concatMap containers pipelineTargets++-- ----------------------------------------------------------------------+-- STAGE setup (after doc-alignment)+-- ----------------------------------------------------------------------++x_HILL_INPUT :: String+x_GEO_INPUT :: String+x_WIKI_ORIG :: String+x_WIKI_CHOSEN :: String+x_PARA :: String+x_FRAG :: String+x_BLEU :: String+x_SENTENCE_SELECTION :: String++-- raw inputs+x_HILL_INPUT = ".json"+x_GEO_INPUT = ".geo-json"+x_WIKI_ORIG = ".wiki"+x_WIKI_CHOSEN = ".wiki.chosen"+-- refs+x_PARA = ".para"+x_FRAG = ".frag"+-- scoring+x_BLEU = ".bleu"+x_SENTENCE_SELECTION = ".sentence-selection"++docTargets :: [ Contained ]+docTargets = singleton $ Contained [] []+ [ target docAlignedDir+ , docAlignedDep x_HILL_INPUT+ , docAlignedDep x_GEO_INPUT+ , docAlignedWikiChosen+ ]++-- Annoyingly the corpus has different names for Hills DB-derived documents+-- and for Wikipedia documents (because we have to align them). So to make+-- life a bit simpler, let's assume document alignment is correct and+-- give them all the same names+docAlignedDir :: ExactTarget+docAlignedDir = ExactTarget d_WORK_DOC_ALIGNED "[1] flatten source data"+ $ \ RedoArgs{rname} -> do+ createDirectoryIfMissing False rname+ wikiFiles <- run ("find", [ d_SRC, "-name", "*" ++ x_WIKI_ORIG ])+ redoIfChange [ rname </> takeFileName (takeDirectory w) <.> x | w <- wikiFiles, x <- exts ]+ stampAll rname exts+ where+ exts = [ x_HILL_INPUT, x_GEO_INPUT, x_WIKI_CHOSEN ]++docAlignedDep :: String -> Target+docAlignedDep x = target $ WildcardTarget d_WORK_DOC_ALIGNED x ""+ $ \ RedoArgs{rname,rwrite} -> do+ createDirectoryIfMissing True (takeDirectory rname)+ let bn = basename rname+ src = d_SRC </> dropExtensions bn </> bn+ tgt = rwrite+ runIO ("cp", [src, tgt])++docAlignedWikiChosen :: Target+docAlignedWikiChosen = target $ WildcardTarget d_WORK_DOC_ALIGNED x_WIKI_CHOSEN ""+ $ \ RedoArgs{rname,rwrite} -> do+ createDirectoryIfMissing True (takeDirectory rname)+ let bn = basename (dropExtensions rname)+ tgt = rwrite+ src <- do cs <- filterExts x_WIKI_ORIG `fmap` getDirectoryContents (d_SRC </> bn)+ case cs of+ [x] -> return (d_SRC </> bn </> x)+ _ -> fail ("Was expecting *exactly* one wiki file chosen for " ++ dropExtensions rname)+ runIO ("cp", [src, tgt])++-- ----------------------------------------------------------------------+-- STAGE preprocessing+-- ----------------------------------------------------------------------++preprocessedTargets :: [Contained]+preprocessedTargets = singleton $ Contained [] []+ [ target preprocessedWorkDir+ , nlgInput+ , preprocessedData+ , preprocessedEn+ ]++preprocessedWorkDir :: ExactTarget+preprocessedWorkDir = ExactTarget d_WORK_PREPROCESSED "[2] preprocess data"+ $ \RedoArgs{rname} -> do+ redoIfChange [ d_WORK_DOC_ALIGNED ]+ createDirectoryIfMissing False rname+ cs <- filterExts x_HILL_INPUT <$> getDirectoryContents d_WORK_DOC_ALIGNED+ redoIfChange [ rname </> dropExtensions c <.> x | c <- cs, x <- exts ]+ stampAll rname exts+ where+ exts = [ extEnChoice, extDataPerDocument ]++ppTarget :: String -> String -> (RedoArgs -> IO ()) -> WildcardTarget+ppTarget = WildcardTarget d_WORK_PREPROCESSED++nlgInput :: Target+nlgInput = target $ ppTarget ext "" $ \RedoArgs{rname, rwrite} -> do+ let mkF x = d_WORK_DOC_ALIGNED </> dropExtensions (basename rname) <.> x + redoIfChange (map mkF [ x_HILL_INPUT, x_GEO_INPUT ])+ runMyCmd "create-nlg-input" [ mkF x_HILL_INPUT, "-o", rwrite ]+ where+ ext = "" <.> extCleanStructuredData++preprocessedData :: Target+preprocessedData = target $ ppTarget extDataPerDocument "" $ \RedoArgs{rname, rwrite} -> do+ let nj = dropExtensions rname <.> extCleanStructuredData + redoIfChange [ nj ]+ runMyCmd "flatten-data" [ nj, rwrite ]++preprocessedEn :: Target+preprocessedEn = target $ ppTarget extEnChoice "" $ \RedoArgs{rname, rwrite} -> do+ let mkI x = dropExtensions rname <.> x+ nchosen = d_WORK_DOC_ALIGNED </> dropExtensions (basename rname) <.> x_WIKI_CHOSEN+ nj = mkI extCleanStructuredData + nsegmented = mkI "wiki.segmented"+ -- 1. sentence segmentation+ redoIfChange [nj, nchosen]+ runMyCmd "take-sentences" [ nchosen, "-o", nsegmented ]+ -- 2. tokenisation+ -- hills db doesn't use accents in its recorded names for hills, so we translit them out+ -- while we're at it we also add spaces between punctuation+ let nsegmented2 = mkI "wiki.segmented-ascii"+ ntokenised = mkI "wiki.tokenised"+ run ("iconv", [ nsegmented+ , "-f", "utf-8"+ , "-t", "ascii//TRANSLIT"+ ]) >>= B.writeFile nsegmented2+ runMyCmd "tokenise-sentences" [ nsegmented2 , "-o", ntokenised ]+ -- 3. lemmatisation+ let nprerasp = mkI "wiki.prerasp"+ -- TODO: replace sed with just plain Haskell+ run ("sed", ["-e", "s/^\\(..*\\)$/^ \\1/", ntokenised]) >>= B.writeFile nprerasp+ let raspCmd = setenv [ ("rasp_parse", "cat"), ("rasp_sentence", "cat") ]+ $ d_RASP_HOME </> "scripts/rasp.sh"+ raspChain = ("cat",[nprerasp])+ -|- raspCmd+ -|- ("sed", [ "-e", "s/+[^_]*_/_/g"+ , "-e", "s/^\\^_\\^ //"+ , "-e", "s/^/[/"+ , "-e", "s/$/]/"+ ])+ -|- ("tr", ["[A-Z]", "[a-z]"]) -- ^ yeah I know I could juts use Haskell here+ run raspChain >>= B.writeFile rwrite++-- ----------------------------------------------------------------------+-- STAGE first stage LLR 1+-- ----------------------------------------------------------------------++llr1Targets :: [Contained]+llr1Targets = singleton $ Contained [] [] [ target docLLR_1 ]++docLLR_1 :: ExactTarget+docLLR_1 = ExactTarget d_LLR_1 "[3] G2 (aka LLR) scores on base inputs"+ $ \RedoArgs { rname } -> do+ redoIfChange [ d_WORK_PREPROCESSED ]+ runMyCmd "build-llr-lexicon" $ [ d_WORK_PREPROCESSED, d_WORK_PREPROCESSED, rname ] ++ parallelRTS+ run $ ("cat", [rname </> "lexicon"]) -|- "redo-stamp"++-- ----------------------------------------------------------------------+-- STAGE sentence selection+-- ----------------------------------------------------------------------++data SentSelMethod = SentSelBaselineN Int+ | SentSelBaselineA+ | SentSelGtm+ | SentSelThreshold Float++instance ShowPC SentSelMethod where+ showPC (SentSelBaselineN n) = "BASELINE-s" ++ show n+ showPC SentSelBaselineA = "BASELINE-sA"+ showPC SentSelGtm = "gtm"+ showPC (SentSelThreshold n) = "t" ++ showPaddedF 3 n++instance Containable SentSelMethod where+ czero = SentSelBaselineA++sentenceSelectionTargets :: [Contained]+sentenceSelectionTargets =+ allTarget "all-sentence-selection" "[4] do sentence selection"+ [mkContained [sentenceSelection, sentenceSelectionSubset] ssMethods]++sentenceSelection :: SentSelMethod -> ExactTarget+sentenceSelection m = ExactTarget path "" $ \RedoArgs { rname } -> do+ redoIfChange [ d_WORK_PREPROCESSED, d_LLR_1 ]+ createDirectoryIfMissing True rname+ let filterSentences ps =+ runMyCmd "filter-sentences" $ ps ++ [ d_WORK_PREPROCESSED, d_LLR_1 </> "lexicon", rname ]+ case m of+ SentSelBaselineN c ->+ runMyCmd "create-baseline" [ "--cutoff", show c, "-s", d_WORK_PREPROCESSED, rname ]+ SentSelBaselineA -> do+ fs <- filterExts extEnChoice `fmap` getDirectoryContents d_WORK_PREPROCESSED+ forM_ fs $ \f -> crunIO "cp" [ d_WORK_PREPROCESSED </> f, rname ]+ SentSelGtm ->+ filterSentences [ "--usemeans" ]+ SentSelThreshold t ->+ filterSentences [ "--threshold", show t ]+ -- --+ stampAll rname [ extEnChoice ]+ where+ path = d_SENTENCE_SELECTION </> showPC m++sentenceSelectionSubset :: SentSelMethod -> ExactTarget+sentenceSelectionSubset m = ExactTarget path "" $ \RedoArgs { rname } -> do+ let src = ePath (sentenceSelection m)+ tgt = rname+ redoIfChange [ src ]+ createDirectoryIfMissing True tgt+ copySubset extEnChoice src tgt+ recurseStampExt tgt [extEnChoice]+ where+ path = d_SENTENCE_SELECTION_SUBSET </> showPC m++copySubset :: String -> FilePath -> FilePath -> IO ()+copySubset x src tgt = do+ createDirectoryIfMissing True tgt+ fs <- filterExts x_FRAG <$> getDirectoryContents d_REFERENCE+ forM_ fs $ \f -> do+ let f2 z = z </> dropExtensions f <.> x+ copyFile (f2 src) (f2 tgt)++-- ----------------------------------------------------------------------+-- STAGE data selection+-- ----------------------------------------------------------------------++data DataSelMethod = DataSelAll+ | DataSelDisj Float+ | DataSelConj Float+ | DataSelSingle Float++instance ShowPC DataSelMethod where+ showPC DataSelAll = "all"+ showPC (DataSelDisj n) = "di-" ++ showPaddedF 3 n+ showPC (DataSelConj n) = "zc-" ++ showPaddedF 3 n -- z so it sorts last+ showPC (DataSelSingle n) = "sg-" ++ showPaddedF 3 n++instance Containable DataSelMethod where+ czero = DataSelAll++dataSelectionTargets :: [Contained]+dataSelectionTargets = allTarget "all-data-selection" "[5] do data selection"+ [mkContained options dsMethods]+ where+ options = [ f s | f <- [ dataSelection, dataSelectionSubset ]+ , s <- ssMethods ]++dataSelection :: SentSelMethod -> DataSelMethod -> ExactTarget+dataSelection sm dm = ExactTarget path "" $ \ RedoArgs { rname } -> do+ let sentdir = ePath (sentenceSelection sm)+ redoIfChange [ d_WORK_PREPROCESSED, sentdir, d_LLR_1 ]+ createDirectoryIfMissing True rname+ let fdt m mt =+ runMyCmd "filter-data-tokens" $+ [ "--method", m+ , sentdir+ , d_WORK_PREPROCESSED+ , d_LLR_1 </> "lexicon"+ , rname+ ] ++ maybe [] (\t -> ["--threshold", show (t :: Float)]) mt+ case dm of+ DataSelAll -> fdt "takeall" Nothing+ DataSelConj n -> fdt "conj" (Just n)+ DataSelDisj n -> fdt "disj" (Just n)+ DataSelSingle n -> fdt "single" (Just n)+ -- --+ stampAll rname [ extDataPerSentence ] + where+ path = d_DATA_SELECTION </> showPC sm </> showPC dm++dataSelectionSubset :: SentSelMethod -> DataSelMethod -> ExactTarget+dataSelectionSubset sm dm = ExactTarget path "" $ \RedoArgs { rname } -> do+ let src = ePath (dataSelection sm dm)+ tgt = rname+ redoIfChange [ src ]+ createDirectoryIfMissing True tgt+ copySubset extEnChoice src tgt+ copySubset extDataPerDocument src tgt+ copySubset extDataPerSentence src tgt+ recurseStampExt tgt [ extEnChoice, extDataPerDocument, extDataPerSentence ]+ where+ path = d_DATA_SELECTION_SUBSET </> showPC sm </> showPC dm++-- ----------------------------------------------------------------------+-- STAGE LLR/G2 recomputation+-- ----------------------------------------------------------------------++data LlrMethod = LlrNoRecompute+ | LlrRecomputeDoc+ | LlrRecomputeSent++instance ShowPC LlrMethod where+ showPC LlrNoRecompute = "old-d"+ showPC LlrRecomputeDoc = "recomp-d"+ showPC LlrRecomputeSent = "recomp-s"++instance Containable LlrMethod where+ czero = LlrRecomputeDoc -- not LlrNoRecompute because that just ponits back to llr1++llr2Targets :: [Contained]+llr2Targets = allTarget "all-new-llr" "[6] G2 (aka LLR) scores revisited" [ llr2Contained ]+ where+ llr2Contained = Contained { containers = [ takeDirectory (ePath t) | Just t <- map (\f -> f czero) fs ]+ , targets = catMaybes [ f l | f <- fs, l <- llrMethods ]+ , allTargets = map target (targets llr2Contained)+ }+ fs = [ llr2 s d | s <- ssMethods, d <- dsMethods ]++llr2 :: SentSelMethod -> DataSelMethod -> LlrMethod -> Maybe ExactTarget+llr2 sm dm lm =+ mkTarget <$> recomp+ where+ llrCmd xs s d o = runMyCmd "build-llr-lexicon" $ [ s, d, o ] ++ xs ++ parallelRTS+ recomp = case lm of+ LlrNoRecompute -> Nothing+ LlrRecomputeSent -> Just (llrCmd ["--sentencelevel"])+ LlrRecomputeDoc -> Just (llrCmd [])+ mkTarget llrBuilder =+ ExactTarget path "" $ \RedoArgs { rname } -> do+ redoIfChange [ sentDir, dataDir ]+ createDirectoryIfMissing True rname+ _ <- llrBuilder sentDir dataDir rname+ run $ (\() -> readFile (rname </> "lexicon")) -|- "redo-stamp"+ sentDir = dataDir -- yes the data dir: data selection results in+ -- recomputing the sentence selection+ dataDir = ePath (dataSelection sm dm)+ path = llr2Dir sm dm lm++llr2Dir :: SentSelMethod -> DataSelMethod -> LlrMethod -> FilePath+llr2Dir sm dm lm =+ case lm of+ LlrNoRecompute -> d_LLR_1 -- not sure if I'll regret this+ _ -> d_LLR_2 </> showPC sm </> showPC dm </> showPC lm ++-- ----------------------------------------------------------------------+-- STAGE fragment extraction+-- ----------------------------------------------------------------------++data FragBaselineMethod = FragBaselineAll+ | FragBaselineCutoff Int++instance ShowPC FragBaselineMethod where+ showPC FragBaselineAll = "BASELINE-fA"+ showPC (FragBaselineCutoff n) = "BASELINE-s" ++ show n++instance Containable FragBaselineMethod where+ czero = FragBaselineAll++fragmentExtractionTargets :: [Contained]+fragmentExtractionTargets = allTarget "all-fragment-extraction" "[7] extract fragments" $+ [ fragmentExtractionContained+ , fragmentBaselineContained+ ]++fragmentExtractionContained :: Contained+fragmentExtractionContained =+ mkContained [ fragmentExtraction s d | s <- ssMethods, d <- dsMethods ] llrMethods++fragmentBaselineContained :: Contained+fragmentBaselineContained = mkContained [ fragmentBaseline ] fbMethods++fragmentExtraction :: SentSelMethod -> DataSelMethod -> LlrMethod -> ExactTarget+fragmentExtraction sm dm lm = ExactTarget path "" $ \ RedoArgs { rname } -> do+ redoIfChange [ sentDir, dataDir, llrDir ]+ createDirectoryIfMissing True rname+ runMyCmd "detect-fragments" $ [ sentDir, dataDir, llrDir </> "lexicon", rname ] ++ parallelRTS+ recurseStampExt rname [ extEnChoice, extDataPerSentence ]+ where+ path = d_FRAGMENTS </> showPC sm </> showPC dm </> showPC lm+ sentDir = dataDir -- see llr2 sentDir+ dataDir = ePath (dataSelection sm dm)+ llrDir = llr2Dir sm dm lm++fragmentBaseline :: FragBaselineMethod -> ExactTarget+fragmentBaseline m = ExactTarget path "" $ \ RedoArgs { rname } -> do+ redoIfChange [ d_WORK_PREPROCESSED ]+ let cutoff = case m of+ FragBaselineAll -> []+ FragBaselineCutoff n -> [ "--cutoff", show n ]+ runMyCmd "create-baseline" $ cutoff ++ [ d_WORK_PREPROCESSED, rname ]+ stampAll rname [ extDataPerDocument, extEnFragments ]+ where+ path = d_FRAGMENTS_BASELINE </> showPC m++-- ----------------------------------------------------------------------+-- STAGE reference data+-- ----------------------------------------------------------------------++referenceTargets :: [Contained]+referenceTargets = [ Contained [] [] $ map target+ [ sentenceSelectionReference, fragmentsReferenceDir ]+ ]++sentenceSelectionReference :: ExactTarget+sentenceSelectionReference = ExactTarget d_SENTENCE_SELECTION_REFERENCE ""+ $ \ RedoArgs { rname } -> do+ redoIfChange [ d_WORK_PREPROCESSED ]+ runMyCmd "from-handwritten" [ d_REFERENCE, rname, "-c", "--sourcetext", d_WORK_PREPROCESSED ]+ stampAll rname [ extEnChoice ]++fragmentsReferenceDir :: ExactTarget+fragmentsReferenceDir = ExactTarget d_FRAGMENTS_REFERENCE "[8] convert reference data"+ $ \ RedoArgs { rname } -> do+ redoIfChange [ d_WORK_PREPROCESSED ]+ createDirectoryIfMissing True rname+ runMyCmd "from-handwritten" [ d_REFERENCE, rname, "--sourcetext", d_WORK_PREPROCESSED ]+ hasPara <- any (\f -> takeExtensions f == x_PARA) <$> getDirectoryContents d_REFERENCE+ when hasPara (fromPara d_REFERENCE rname)+ stampAll rname [ extEnFragments, extDataPerSentence, extDataPerDocument ]++fromPara :: FilePath -> FilePath -> IO ()+fromPara indir outdir = do+ fs <- filterExts x_PARA <$> getDirectoryContents indir+ mapM_ convert fs+ where+ convert f = do+ let ofile x = outdir </> dropExtensions f <.> x+ oselected = ofile extDataPerSentence+ osubset = ofile extDataPerDocument+ h <- doesFileExist oselected+ when h $ do+ renameFile oselected (oselected <.> "from-frag")+ renameFile osubset (osubset <.> "from-frag")+ (run $ (\() -> readFile (indir </> f))+ -|- filter ("[" `isPrefixOf`)+ -|- ("sed", ["-e", "s/^\\[\\[//"+ ,"-e", "s/\\].*//"+ ,"-e", "s/,/ /g"+ ]))+ >>= writeFile oselected+ writeFile osubset+ =<< unwords . concatMap words . sort . nub . lines <$> readFile oselected++-- ----------------------------------------------------------------------+-- STAGE scoring+-- ----------------------------------------------------------------------++scoringTargets :: [Contained]+scoringTargets =+ [ Contained [] [] (map target [ score, peersDir ])+ , peersTargets+ ] ++ sentenceSelectionScoreTargets++sentenceSelectionScoreTargets :: [Contained]+sentenceSelectionScoreTargets =+ [ mkContained [ sentenceSelectionScore ] ssMethods+ , mkContained (map sentenceSelectionScore2 ssMethods) dsMethods+ ]++peersTargets :: Contained+peersTargets =+ mkContained [ peersSubdir s d | s <- ssMethods, d <- dsMethods ] llrMethods++peersDir :: ExactTarget+peersDir = ExactTarget d_PEERS "" $ \RedoArgs { rname } -> do+ redoIfChange $ [ d_FRAGMENTS_REFERENCE ] ++ blineTargets+ runIO $ ("rm", [ "-rf", rname ])+ createDirectoryIfMissing False rname+ fs <- referenceBasenames+ -- reference data+ let peerRefDir = rname </> "REFERENCE"+ createDirectoryIfMissing False peerRefDir+ copyReferenceFiles d_FRAGMENTS_REFERENCE peerRefDir fs+ -- baseline fragments+ forM_ blineTargets $ \p ->+ copyReferenceFiles p (rname </> takeFileName p) fs+ -- extracted fragments+ redoIfChange fragTargets+ recurseStampExt rname [ extEnFragments, extDataPerDocument ]+ where+ fragTargets = map ePath (targets peersTargets)+ blineTargets = map ePath (targets fragmentBaselineContained)++peersSubdir :: SentSelMethod -> DataSelMethod -> LlrMethod -> ExactTarget+peersSubdir sm dm lm = ExactTarget (path []) "" $ const $ do+ redoIfChange [ d_FRAGMENTS_REFERENCE, frag ]+ ds <- subdirectories frag+ forM_ ds $ \d -> do+ let src = frag </> d+ tgt = path [d]+ createDirectoryIfMissing True tgt+ referenceBasenames >>= copyReferenceFiles src tgt+ -- tricky because we don't generate rname :-(+ -- recurseStamp rname [ extEnFragments, extDataPerDocument ]+ where+ frag = ePath (fragmentExtraction sm dm lm )+ path xs = squishPath . joinPath $ [ d_PEERS, showPC sm, showPC dm, showPC lm ] ++ xs++squishPath :: FilePath -> FilePath+squishPath = intercalate "_" . splitDirectories++copyReferenceFiles :: FilePath -- ^ src+ -> FilePath -- ^ tgt+ -> [FilePath] -- ^ basenames+ -> IO ()+copyReferenceFiles src tgt bns = do+ createDirectoryIfMissing False tgt+ forM_ bns $ \bn ->+ let f = bn <.> extEnFragments+ in copyFile (src </> f) (tgt </> f)++referenceBasenames :: IO [FilePath]+referenceBasenames = (map dropExtensions . filterExts extEnFragments)+ <$> getDirectoryContents d_FRAGMENTS_REFERENCE++score :: ExactTarget+score = ExactTarget d_SCORES "compute BLEU scores" $ const $ do+ let pdir = ePath peersDir+ createDirectoryIfMissing False d_SCORES+ redoIfChange $ map ePath $ concatMap targets sentenceSelectionScoreTargets+ redoIfChange [ pdir ]+ crunIO "perl" [ "-I", d_CALCULATORS, d_CALCULATORS </> "bleu-scores.pl"+ , pdir </> "REFERENCE" , pdir, d_SCORES+ ]+ stampAll d_SCORES [ x_BLEU, x_SENTENCE_SELECTION ]++sentenceSelectionScore :: SentSelMethod -> ExactTarget+sentenceSelectionScore sm =+ scoreSentenceSelection peerDir refDir path+ where+ path = d_SCORES </> showPC sm+ refDir = ePath sentenceSelectionReference+ peerDir = ePath (sentenceSelectionSubset sm)++sentenceSelectionScore2 :: SentSelMethod -> DataSelMethod -> ExactTarget+sentenceSelectionScore2 sm dm =+ scoreSentenceSelection peerDir refDir path+ where+ path = squishPath $ d_SCORES </> showPC sm </> showPC dm+ refDir = ePath sentenceSelectionReference+ peerDir = ePath (dataSelectionSubset sm dm)++scoreSentenceSelection :: FilePath -- ^ peer+ -> FilePath -- ^ ref+ -> FilePath -- ^ output+ -> ExactTarget+scoreSentenceSelection p r out_ = ExactTarget out "" $ \RedoArgs {rwrite} -> do+ redoIfChange [ p, r ]+ run (d_BIN </> "score-sentence-selection", [ "-e", extEnChoice, r, p ])+ >>= B.writeFile rwrite+ where+ out = out_ <.> x_SENTENCE_SELECTION++-- ----------------------------------------------------------------------+-- utils+-- ----------------------------------------------------------------------++allTarget :: String -> String -> [Contained] -> [Contained]+allTarget name description xs =+ header : xs+ where+ header = Contained [] [] [target headerT]+ headerT = ExactTarget name description $ const $ redoIfChange ("init" : paths)+ paths = map ePath (concatMap targets xs)++crunIO :: FilePath -> [FilePath] -> IO ()+crunIO = curry run++runMyCmd :: String -> [String] -> IO ()+runMyCmd x args = run (d_BIN </> x, args)++filterExts :: String -> [FilePath] -> [FilePath]+filterExts x = filter (\f -> takeExtensions f == ("" <.> x))++subdirectories :: FilePath -> IO [FilePath]+subdirectories f =+ filterM isSubdir =<< filter (not . junk) <$> getDirectoryContents f+ where+ isSubdir d = doesDirectoryExist (f </> d)+ junk = (`elem` [".", ".."])++recurseStamp :: (FilePath -> Bool) -> FilePath -> IO ()+recurseStamp c d =+ run $ (\() -> filter c <$> recurseDir SystemFS d)+ -|- mapM readFile+ -|- "redo-stamp"++recurseStampExt :: FilePath -> [String] -> IO ()+recurseStampExt t xs = recurseStamp (\f -> takeExtensions f `elem` xs) t++showPaddedF :: Int -> Float -> String+showPaddedF n x = if intlength x < n+ then (replicate (n - intlength x) '0') ++ showNiceF x+ else showNiceF x+ where+ intlength = length . show . floorI++showNiceF :: Float -> String+showNiceF x = if fromIntegral (floorI x) == x+ then show (floorI x)+ else show x++floorI :: Float -> Int+floorI = floor -- sigh, just making a warning go away++singleton :: a -> [a]+singleton x = [x]
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2011, Eric Kow++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.++ * Neither the name of Eric Kow nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Makedo.hs view
@@ -0,0 +1,2 @@+module Makedo ( module Makedo.Target ) where+import Makedo.Target
+ Makedo/Contained.hs view
@@ -0,0 +1,30 @@+module Makedo.Contained where++import Makedo.Target+import System.FilePath++-- | redo 0.06 and under do not like it if you try to redo something that's+-- in a directory that does not yet exist, so unfortunately, we need some way+-- to create the parent directories before invoking the targets+data Contained = Contained+ { containers :: [FilePath]+ , targets :: [ExactTarget]+ , allTargets :: [Target] -- ^ should be superset of targets+ }++-- | Just one of the possible 'a' used to generate a path component+-- which will then just be chopped off again with takeDirectory+class Containable a where+ czero :: a++mkContained :: Containable b+ => [b -> ExactTarget]+ -> [b] -- ^ possibilities+ -> Contained+mkContained fs xs =+ Contained { containers = map (\f -> takeDirectory . ePath $ f czero) fs+ , targets = ts+ , allTargets = map target ts+ }+ where+ ts = [ f x | f <- fs, x <- xs ]
+ Makedo/Target.hs view
@@ -0,0 +1,163 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE NamedFieldPuns, RecordWildCards #-}++module Makedo.Target (+ -- * your main function+ redoMain, listing+ -- * creating targets+ , Target(..), RedoArgs(..)+ , TargetLike(..)+ , ExactTarget(..), WildcardTarget(..)+ , ShowPC(..)+ -- * within target actions+ , redoIfChange, redo, stampAll+ , runVerbosely+ ) where++import HSH+import System.Directory+import System.Environment+import System.Exit+import System.FilePath+import System.Process+import System.IO++-- | A makedo script is basically just a list of 'Target'+--+-- If a target matches the input file name, its action is run+data Target = Target+ { match :: FilePath -> Bool+ , description :: (String, String) -- ^ (name, blurb) for human consumption only+ , action :: RedoArgs -> IO ()+ }++data RedoArgs = RedoArgs+ { rwrite :: FilePath -- ^ temporary file managed by redo; write your output here+ -- or to stdout; it will be renamed to 'rname' if the rule+ -- is successful+ , rname :: FilePath -- ^ desired filename+ , rext :: String+ }++-- | Useful for targets that take parameters which you want to+-- convert into path components+class ShowPC a where+ showPC :: a -> String++runVerbosely :: ShellCommand a => a -> IO ()+runVerbosely cmd = run cmd >>= hPutStr stderr++-- ----------------------------------------------------------------------++-- | Targets that use an exact filename match+data ExactTarget = ExactTarget+ { ePath :: FilePath+ , eBlurb :: String+ , eAction :: RedoArgs -> IO ()+ }++data WildcardTarget = WildcardTarget+ { wPrefix :: FilePath+ , wExtension :: String -- ^ as recognised by System.FilePath+ , wBlurb :: String+ , wAction :: RedoArgs -> IO ()+ }+++class TargetLike t where+ target :: t -> Target++instance TargetLike Target where+ target = id++instance TargetLike ExactTarget where+ target (ExactTarget {..}) = Target (== ePath) (ePath, eBlurb) eAction++instance TargetLike WildcardTarget where+ target (WildcardTarget {..}) = Target (matchDirExt wPrefix wExtension)+ (wPrefix </> "*" <.> wExtension, wBlurb)+ wAction++matchDirExt :: FilePath -> String -> FilePath -> Bool+matchDirExt d x f = takeDirectory f == d+ && takeExtensions f == ("" <.> x) -- NB <.> is clever about not duping++-- ----------------------------------------------------------------------++gussyUp :: [Target] -> [Target]+gussyUp ts = target (listing ts)+ : target (listing2 ts)+ : addAll ts++-- | Special target that prints out the targets you can run+-- Note that makedo automatically includes this+listing :: [Target] -> ExactTarget+listing ts = ExactTarget "targets" "list known targets" $+ const $ do listingBody (filter described ts)+ hPutStrLn stderr $ "Try `redo " ++ ePath (listing2 ts) ++ "` for a full list"+ where+ described = not . null . snd . description++-- | Special target that prints out the targets you can run+-- Note that makedo automatically includes this+listing2 :: [Target] -> ExactTarget+listing2 ts = ExactTarget "targets2" "list all known targets" $+ const $ listingBody ts++listingBody :: [Target] -> IO ()+listingBody ts = hPutStr stderr . unlines . map (showd . description) $ ts+ where+ maxl = maximum $ map (length . fst . description) ts+ padRight x = x ++ replicate (maxl - length x) ' '+ showd (d,blurb) = padRight d ++ " " ++ blurb+++addAll :: [Target] -> [Target]+addAll ts =+ if any (\t -> fst (description t) == "all") ts+ then ts+ else allT : ts+ where+ allT = target $ ExactTarget "all" "help text" $ const $ do+ hPutStrLn stderr "run 'redo targets' to see your options"+ exitFailure++-- | Your main function should probably just invoke this and do nothing+-- else+redoMain :: [Target] -> IO ()+redoMain ts = do+ args <- getArgs+ case args of+ [x1, x2, x3] -> fromRedo (gussyUp ts)+ (RedoArgs { rwrite = x3, rname = x1, rext = x2 })+ _ -> fail ("Was expecting exactly 3 arguments\n" +++ "This script should only be run by redo")++fromRedo :: [Target] -> RedoArgs -> IO ()+fromRedo ts args@(RedoArgs {rname}) =+ case filter (flip match rname) ts of+ [] -> fail ("No matches for " ++ rname)+ ms -> mapM_ (flip action args) ms++-- Not using HSH for this because of+-- +-- > Traceback (most recent call last):+-- > File "/usr/local/redo/redo", line 60, in <module>+-- > jwack.setup(j)+-- > File "/usr/local/redo-0.06/jwack.py", line 95, in setup+-- > raise ValueError('broken --jobserver-fds from make; prefix your Makefile rule with a "+"')+-- > ValueError: broken --jobserver-fds from make; prefix your Makefile rule with a "+"+redoIfChange :: [String] -> IO ()+redoIfChange args =+ runProcess "redo-ifchange" args Nothing Nothing Nothing Nothing Nothing >>= waitForProcess >> return ()++redo :: [String] -> IO ()+redo args =+ runProcess "redo" args Nothing Nothing Nothing Nothing Nothing >>= waitForProcess >> return ()++stampAll :: FilePath -> [String] -> IO ()+stampAll d exts_ = do+ cs <- getDirectoryContents d+ runIO $ ("cat", [ d </> c | c <- cs, takeExtensions c `elem` exts ]) -|- "redo-stamp"+ where+ exts = map ("" <.>) exts_
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ makedo.cabal view
@@ -0,0 +1,66 @@+-- makedo.cabal auto-generated by cabal init. For additional options,+-- see+-- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr.+-- The name of the package.+Name: makedo++-- The package version. See the Haskell package versioning policy+-- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for+-- standards guiding when and how versions should be incremented.+Version: 0.1++-- A short (one-line) description of the package.+Synopsis: Helper for writing redo scripts in Haskell++-- A longer description of the package.+-- Description:++-- URL for the project homepage or repository.+Homepage: http://darcsden.com/kowey/makedo++-- The license under which the package is released.+License: BSD3++-- The file containing the license text.+License-file: LICENSE++-- The package author(s).+Author: Eric Kow++-- An email address to which users can send suggestions, bug reports,+-- and patches.+Maintainer: eric.kow@gmail.com++-- A copyright notice.+-- Copyright:++Category: Development++Build-type: Simple++-- Extra files to be distributed with the package, such as examples or+-- a README.+Extra-source-files: Example.hs+ , CorpusFiles.hs++-- Constraint on the version of Cabal needed to build this package.+Cabal-version: >=1.6+++Library+ -- Modules exported by the library.+ Exposed-modules: Makedo+ , Makedo.Contained+ , Makedo.Target++ -- Packages needed in order to build this package.+ Build-depends: base < 5+ , filepath < 1.3+ , directory < 1.2+ , process < 2+ , HSH == 2.0.*+ -- Modules not exported by this package.+ -- Other-modules:++ -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.+ -- Build-tools: