mcm (empty) → 0.6.4.10
raw patch · 24 files changed
+4641/−0 lines, 24 filesdep +MissingHdep +basedep +blaze-htmlsetup-changedbinary-added
Dependencies added: MissingH, base, blaze-html, bytestring, containers, directory, filepath, hostname, polyparse, process, text, unix
Files
- Action.hs +28/−0
- FileCorrector.hs +470/−0
- Interpret.hs +655/−0
- InterpretState.hs +390/−0
- LICENCE +674/−0
- Parser.hs +485/−0
- ParserTypes.hs +173/−0
- PathToMCM.hs +109/−0
- README.txt +11/−0
- Setup.hs +2/−0
- VarsParser.hs +62/−0
- changelog +9/−0
- commands2html.1 +61/−0
- commands2html.hs +295/−0
- copyright +19/−0
- mcm.1 +141/−0
- mcm.cabal +54/−0
- mcm.hs +275/−0
- mcm.vim +132/−0
- mcm2html.1 +63/−0
- mcm2html.hs +363/−0
- mcmtags.1 +37/−0
- mcmtags.hs +133/−0
- mcmtestfiles.tgz binary
+ Action.hs view
@@ -0,0 +1,28 @@+-- MCM - Machine Configuration Manager; manages the contents of files and directories+-- Copyright (c) 2013-2016 Anthony Doggett <mcm@interfaces.org.uk>+--+-- Licence:+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program. If not, see <http://www.gnu.org/licenses/>.++module Action (Action(..), displayActions, runActions)+where++data Action = Action {display :: String, action :: IO ()}++displayActions :: [Action] -> IO ()+displayActions = mapM_ (putStrLn . display)++runActions :: [Action] -> IO ()+runActions = mapM_ action+
+ FileCorrector.hs view
@@ -0,0 +1,470 @@+-- MCM - Machine Configuration Manager; manages the contents of files and directories+-- Copyright (c) 2013-2016 Anthony Doggett <mcm@interfaces.org.uk>+--+-- Licence:+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program. If not, see <http://www.gnu.org/licenses/>.++module FileCorrector (ChangesSummary(..), correctAll, CompFun, diffCompare, simpleCompare, Path, PathType(..), theRootDir, addPath, walk, Permissions(..), emptyPermissions, DirType(..), OwnerP(..), GroupP(..), ownerAsString, groupAsString, mergePaths, Source)+where++import Control.Exception (catchJust)+import Data.Char(isSpace)+import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Data.Text.Lazy as T+import qualified Data.Text.Lazy.IO as TextIO+import Numeric(showOct)+import System.Directory (getDirectoryContents, removeFile)+import qualified System.Directory as SD+import System.Exit(ExitCode(ExitSuccess))+import System.FilePath (joinPath, normalise, splitFileName, makeRelative, splitDirectories, dropTrailingPathSeparator, takeFileName, combine)+import System.IO.HVFS.Utils (recursiveRemove, SystemFS(..))+import System.IO.Error (isDoesNotExistErrorType, ioeGetErrorType)+import System.Posix.Directory (createDirectory)+import System.Posix.Files (fileExist, isDirectory, setFileMode, removeLink, getSymbolicLinkStatus, isSymbolicLink, readSymbolicLink, createSymbolicLink, setOwnerAndGroup, setSymbolicLinkOwnerAndGroup, fileMode, fileOwner, fileGroup, getFileStatus, accessModes, intersectFileModes)+import System.Posix.Types (FileMode, UserID, GroupID)+import System.Process (readProcessWithExitCode)++import Action++data ChangesSummary = SomeItemsChangedOrRemoved | OnlyNewItems+ deriving Show++data FT = FileT | DirT | SymlinkT+ deriving (Show, Eq)++data AlsoWrongPermissions = PermissionsWrongToo | PermissionsRight+ deriving (Show, Eq)++-- Intermediate Status of files found (all but for permissions checked)+data IStatus = IMissing -- File/Dir is not there at all+ | IWrongType FT -- File when should be Dir, etc.+ | IWrongContents (Maybe String) -- Files: Might as well not be there...+ | IExtraFiles [(FilePath, FT)] -- Full Dirs: some extra files+ | ILooksOk+ deriving (Show, Eq)++-- Final Status of files found+data FStatus = FMissing -- File/Dir is not there at all+ | FWrongType FT -- File when should be Dir, etc.+ | FWrongContents (Maybe String) -- Files: Might as well not be there...+ | FExtraFiles [(FilePath, FT)] AlsoWrongPermissions -- Full Dirs: some extra files+ | FWrongPermissions -- Content ok, permissions need correcting+ | FPerfect+ deriving (Show, Eq)++data DirType = Full -- Fully managed dir (delete unmanaged files/dirs)+ | Partial -- Partially managed dir (do not delete unmanaged files/dirs)+ | Implicit -- Implicitly created+ deriving (Show, Eq)++data PathType = Dir DirType+ | File T.Text+ | Symlink FilePath+ | Absent+ deriving (Show, Eq)++kind2ft :: PathType -> FT+kind2ft (Dir _) = DirT+kind2ft (File _) = FileT+kind2ft (Symlink _) = SymlinkT+kind2ft Absent = error "Absent has no ft"++-- FileMode, UserName, GroupName+newtype OwnerP = OwnerP (T.Text, UserID)+ deriving (Show, Eq)+newtype GroupP = GroupP (T.Text, GroupID)+ deriving (Show, Eq)+data Permissions = Perm (Maybe FileMode) (Maybe OwnerP) (Maybe GroupP)+ deriving (Show, Eq)++emptyPermissions :: Permissions+emptyPermissions = Perm Nothing Nothing Nothing++ownerAsString :: OwnerP -> String+ownerAsString (OwnerP (o, _)) = T.unpack o++groupAsString :: GroupP -> String+groupAsString (GroupP (g, _)) = T.unpack g++type Source = String++implicitSource :: Source+implicitSource = "(implicit)"++-- A tree of paths. Each FilePath contains the full path+-- ToDo: shouldn't the Map.Map be part of the Dir PathType?+data Path = Path FilePath PathType (Map.Map FilePath Path) Permissions Source+ deriving (Show, Eq)++theRootDir :: Path+theRootDir = Path "" (Dir Implicit) Map.empty emptyPermissions implicitSource++type CompFun = T.Text -> FilePath -> IO IStatus++walk :: Path -> [(FilePath, PathType, Permissions)]+walk (Path "" _ ps _ _) = concatMap walk (Map.elems ps)+walk (Path path kind ps perm _) = x:xs+ where+ x = (path, kind, perm)+ xs = concatMap walk (Map.elems ps)++addPath :: Path -> FilePath -> PathType -> Permissions -> Source -> Either String Path+addPath p f = addPath' p normalisedFilePath+ where+ normalisedFilePath = normalise (dropTrailingPathSeparator f)++addPath' :: Path -> FilePath -> PathType -> Permissions -> Source -> Either String Path+addPath' (Path path kind ps perm source) newPath newType newPermissions newS =+ if path == newPath then+ if kind == Dir Implicit then+ if newType `elem` [Dir Full, Dir Partial] then+ -- Replace old implicit directory+ Right $ Path path newType ps newPermissions newS+ else+ Left $ "Path " ++ newPath ++ " is already implicitly a directory from " ++ show source+ else+ Left $ "Path " ++ newPath ++ " already exists from " ++ show source ++ " and the new definition from " ++ show newS ++ " conflicts."+ else+ let (dir, _) = splitFileName newPath+ dir' = if dir == "./" then "" else dropTrailingPathSeparator dir+ in+ if dir' == path then+ -- Add item into this path,+ -- complaining if already exists and is different+ case Map.lookup newPath ps of+ Nothing -> let iP = Path newPath newType Map.empty newPermissions newS+ in Right $ Path path kind (Map.insert newPath iP ps) perm source+ Just p -> case addPath' p newPath newType newPermissions newS of+ Left e -> Left e+ Right pp -> Right $ Path path kind (Map.insert newPath pp ps) perm source+ else+ -- recurse, adding result as a new/replacement path+ let remainingdirs = makeRelative path dir'+ nextdir = head $ splitDirectories remainingdirs+ newentryPath = joinPath [path, nextdir]+ defaultNewEntry = Path newentryPath (Dir Implicit) Map.empty emptyPermissions newS+ lookedupNewEntry = Map.findWithDefault defaultNewEntry newentryPath ps+ in case addPath' lookedupNewEntry newPath newType newPermissions newS of+ Left e -> Left e+ Right p -> Right $ Path path kind (Map.insert newentryPath p ps) perm source++-- As yet only for the merging of very simple, compileTo-generated paths+mergePaths :: Path -> Path -> Path+mergePaths (Path apath akind aps aperm asource) (Path bpath bkind bps bperm _) =+ if or [apath /= bpath, akind /= bkind, aperm /= bperm]+ then error "Internal Error: Path construction/traversal mistake"+ else let mergedps = Map.unionWith mergePaths aps bps+ in Path apath akind mergedps aperm asource++calculateStatus :: CompFun -> Path -> IO FStatus+calculateStatus compfun (Path path kind paths perm _) = do+ s <- case kind of+ Dir t -> calcDirStatus t path paths+ File s -> calcFileStatus compfun s path+ Symlink fp -> calcSymlinkStatus fp path+ Absent -> calcAbsentStatus path+ checkPermissions kind path perm s++checkPermissions :: PathType -> FilePath -> Permissions -> IStatus -> IO FStatus+checkPermissions kind path perm (IExtraFiles fs) = do+ wrong <- permissionsAreWrong kind path perm+ return $ FExtraFiles fs $ if wrong then PermissionsWrongToo else PermissionsRight+checkPermissions kind path perm ILooksOk = do+ wrong <- permissionsAreWrong kind path perm+ return $ if wrong then FWrongPermissions else FPerfect+checkPermissions _ _ _ IMissing = return FMissing+checkPermissions _ _ _ (IWrongType ft) = return $ FWrongType ft+checkPermissions _ _ _ (IWrongContents ms) = return $ FWrongContents ms++permissionsAreWrong :: PathType -> FilePath -> Permissions -> IO Bool+permissionsAreWrong _ _ (Perm Nothing Nothing Nothing) = return False+permissionsAreWrong kind path (Perm m u g) = do+ let getStatusCmd = case kind of+ (Symlink _) -> getSymbolicLinkStatus+ _ -> getFileStatus+ fstatus <- getStatusCmd path+ let wrong = or [case m of+ (Just m') -> m' /= intersectFileModes accessModes (fileMode fstatus)+ _ -> False+ ,case u of+ (Just (OwnerP(_, u'))) -> u' /= fileOwner fstatus+ _ -> False+ ,case g of+ (Just (GroupP(_, g'))) -> g' /= fileGroup fstatus+ _ -> False+ ]+ return wrong++calcDirStatus :: DirType -> FilePath -> Map.Map FilePath Path -> IO IStatus+calcDirStatus _ "" _ = return ILooksOk+calcDirStatus t path paths = do+ e <- fileExist path+ if e+ then do+ fs <- getSymbolicLinkStatus path+ if isSymbolicLink fs+ then return $ IWrongType SymlinkT+ else if isDirectory fs+ then+ case t of+ Full -> checkContents path paths+ _ -> return ILooksOk+ else return $ IWrongType FileT+ else return IMissing++-- Return ILooksOk if path contains no files other than path.+-- Otherwise return ExtraFiles.+checkContents :: FilePath -> Map.Map FilePath Path -> IO IStatus+checkContents path paths = do+ allfiles <- getDirectoryContents path+ let files = filter (\f -> f `notElem` [".", ".."]) allfiles+ wanted = Set.map (takeFileName.dropTrailingPathSeparator) (Map.keysSet paths)+ actual = Set.fromList files+ extras = Set.toList $ Set.difference actual wanted+ extrasWithPath = map (combine path) extras+ if null extras+ then return ILooksOk+ else do+ withFTs <- mapM appendFileType extrasWithPath+ return $ IExtraFiles withFTs++appendFileType :: FilePath -> IO (FilePath, FT)+appendFileType path = do+ fs <- getSymbolicLinkStatus path+ let t | isSymbolicLink fs = SymlinkT+ | isDirectory fs = DirT+ | otherwise = FileT+ return (path, t)++calcFileStatus :: CompFun -> T.Text -> FilePath -> IO IStatus+calcFileStatus compfun contents path = do+ e <- fileExist path+ if e+ then do+ fs <- getSymbolicLinkStatus path+ if isSymbolicLink fs+ then return $ IWrongType SymlinkT+ else if isDirectory fs+ then return $ IWrongType DirT+ else compfun contents path+ else return IMissing++simpleCompare :: CompFun+simpleCompare contents path = do+ let contents' = appendNewlineIfMissing contents+ current <- TextIO.readFile path+ return $ if current == contents' then ILooksOk else IWrongContents Nothing++diffCompare :: CompFun+diffCompare contents path = do+ let contents' = appendNewlineIfMissing contents+ (exitCode, stderr, stdout)+ <- readProcessWithExitCode "diff" [path, "-"] $ T.unpack contents'+ return $ if exitCode == ExitSuccess+ then ILooksOk+ else IWrongContents (Just $ stderr++stdout)++calcSymlinkStatus :: FilePath -> FilePath -> IO IStatus+calcSymlinkStatus dest source = do+ e <- fileExist source -- NB. Works on the _target_ of symbolic links+ if e+ then do+ fs <- getSymbolicLinkStatus source+ if isSymbolicLink fs+ then do+ l <- readSymbolicLink source+ return $ if l == dest+ then ILooksOk+ else IWrongContents (Just $ "Symlink is currently " ++ l)+ else+ return $ IWrongType $ if isDirectory fs then DirT else FileT+ else do+ isslink <- catchJust (\ex -> if isDoesNotExistErrorType (ioeGetErrorType ex) then Just () else Nothing)+ (do+ fs <- getSymbolicLinkStatus source+ return $ isSymbolicLink fs)+ (\_ -> return False)+ if isslink+ then do+ l <- readSymbolicLink source+ return $ if l == dest+ then ILooksOk+ else IWrongContents (Just $ "Symlink is currently " ++ l)+ else+ return IMissing++calcAbsentStatus :: FilePath -> IO IStatus+calcAbsentStatus path = do+ e <- fileExist path+ if e+ then do+ fs <- getSymbolicLinkStatus path+ return $ IWrongType $ if isSymbolicLink fs+ then SymlinkT+ else if isDirectory fs then DirT else FileT+ else+ return ILooksOk++correctOne :: Path -> FStatus -> [Action]+correctOne _ FPerfect = []+correctOne (Path path kind _ perm _) s@FWrongPermissions = correctPermissions s kind path perm+correctOne (Path path Absent _ _ _) s = correctAbsent s path+correctOne p@(Path path _ _ _ _) s@(FWrongType _) = correctAbsent s path ++ correctOne p FMissing+correctOne (Path path kind _ perm _) s = k ++ cor+ where cor = correctPermissions s kind path perm'+ (perm', k) = case kind of+ Dir _ -> correctDir s path perm+ File c -> correctFile s c path perm+ Symlink fp -> correctSymlink s fp path perm+ Absent -> (emptyPermissions, correctAbsent s path)++correctPermissions :: FStatus -> PathType -> FilePath -> Permissions -> [Action]+correctPermissions FPerfect _ _ _ = []+correctPermissions _ kind path (Perm m u g) = correctM m ++ correctUG u g+ where+ correctM Nothing = []+ correctM (Just m') = [Action ("chmod " ++ showOct m' []+ ++ " " ++ path)+ (setFileMode path m')]+ correctUG Nothing Nothing = []+ correctUG _ _ =+ let text = case (u, g) of+ (Nothing, Nothing) -> ""+ (Nothing, Just s) -> "chgrp " ++ groupAsString s ++ " " ++ path+ (Just s, Nothing) -> "chown " ++ ownerAsString s ++ " " ++ path+ (Just a, Just b) -> "chown " ++ ownerAsString a ++ ":" ++ groupAsString b ++ " " ++ path+ ft = kind2ft kind+ in+ [Action text (repairOwnerAndGroup ft path u g)]++repairOwnerAndGroup :: FT -> FilePath -> Maybe OwnerP -> Maybe GroupP -> IO ()+repairOwnerAndGroup ft p u g = ogrepair p u' g'+ where+ u' = case u of+ Nothing -> -1+ Just (OwnerP(_, uid)) -> uid+ g' = case g of+ Nothing -> -1+ Just (GroupP(_, gid)) -> gid+ ogrepair = case ft of+ SymlinkT -> setSymbolicLinkOwnerAndGroup+ _ -> setOwnerAndGroup++joinWithSpace :: String -> String -> String+joinWithSpace "" b = b+joinWithSpace a "" = a+joinWithSpace a b = a ++ " " ++ b++toModeOwnerGroup :: FT -> FilePath -> Permissions -> String -> (String, IO ())+toModeOwnerGroup _ path (Perm Nothing Nothing Nothing) extraargs = (joinWithSpace extraargs path, return ())+toModeOwnerGroup kind path (Perm m u g) extraargs = (mt ++ ugt ++ joinWithSpace extraargs path, do {mio; ugio})+ where+ (mt, mio) = case m of+ Nothing -> ("", return ())+ Just m' -> ("--mode " ++ showOct m' [] ++ " ", setFileMode path m')+ ugio = repairOwnerAndGroup kind path u g+ ugt = case (u, g) of+ (Nothing, Nothing) -> ""+ (Nothing, Just s) -> "--group " ++ groupAsString s ++ " "+ (Just s, Nothing) -> "--owner " ++ ownerAsString s ++ " "+ (Just a, Just b) -> "--owner " ++ ownerAsString a ++ " --group " ++ groupAsString b ++ " "++correctAbsent :: FStatus -> FilePath -> [Action]+correctAbsent (FWrongType SymlinkT) path = [Action ("rm "++path) (removeLink path)]+correctAbsent (FWrongType FileT) path = [Action ("rm "++path) (removeFile path)]+correctAbsent (FWrongType DirT) path = [Action ("rm -r "++path) (recursiveRemove SystemFS path)]+correctAbsent FMissing _ = [] -- Occurs when parent directories do not exist+correctAbsent s path = error $ "Unexpected correctAbsent state: " ++ show s ++ " (occurred for path " ++ path ++ ")"++-- NB. For security reasons we create the directory with the correct owner+correctDir :: FStatus -> FilePath -> Permissions -> (Permissions, [Action])+correctDir FMissing p perm@(Perm m _ _) =+ let (mogText, mogIO) = toModeOwnerGroup DirT p perm ""+ mkdir = case m of+ Nothing -> SD.createDirectory p+ Just mode -> createDirectory p mode+ in (emptyPermissions, [Action ("mkdir " ++ mogText) (do {mkdir; mogIO})])+correctDir (FExtraFiles fs wrongp) _ perm = (perm', concatMap (\(p, ft) -> correctAbsent (FWrongType ft) p) fs)+ where+ perm' = case wrongp of+ PermissionsRight -> emptyPermissions+ PermissionsWrongToo -> perm+correctDir _ _ _ = error "Unexpected correctDir state"++correctFile :: FStatus -> T.Text -> FilePath -> Permissions -> (Permissions, [Action])+correctFile (FWrongContents w) c p perm =+ let (mogText, mogIO) = toModeOwnerGroup FileT p perm ""+ c' = appendNewlineIfMissing c+ in (emptyPermissions, correctAbsent (FWrongType FileT) p+ ++ showWrong w+ ++ [Action ("install "++mogText) (do {TextIO.writeFile p c'; mogIO})])+correctFile FMissing c p perm =+ let (mogText, mogIO) = toModeOwnerGroup FileT p perm ""+ c' = appendNewlineIfMissing c+ in (emptyPermissions, [Action ("install " ++ mogText) (do {TextIO.writeFile p c'; mogIO})])+correctFile _ _ _ _ = error "Unexpected correctFile state"++correctSymlink :: FStatus -> FilePath -> FilePath -> Permissions -> (Permissions, [Action])+correctSymlink (FWrongContents w) fp p perm =+ let (perm', fixmissing) = correctSymlink FMissing fp p perm+ in (perm', correctAbsent (FWrongType SymlinkT) p ++ showWrong w ++ fixmissing)+correctSymlink FMissing fp p perm =+ let (mogText, mogIO) = toModeOwnerGroup FileT p perm ("-s " ++ fp)+ in (emptyPermissions, [Action ("ln " ++ mogText) (do {createSymbolicLink fp p; mogIO})])+correctSymlink _ _ _ _ = error "Unexpected correctSymlink state"++showWrong :: Maybe String -> [Action]+showWrong Nothing = []+showWrong (Just s) = [Action (trim s) (return ())]++trim :: String -> String+trim = f . f+ where f = reverse . dropWhile isSpace++statusAndCorrect :: CompFun -> Path -> IO (FStatus, [Action])+statusAndCorrect compfun p = do+ s <- calculateStatus compfun p+ return (s, correctOne p s)++correctAll :: CompFun -> Path -> IO (ChangesSummary, [Action])+correctAll compfun p@(Path _ _ paths _ _) = do+ (s, a) <- statusAndCorrect compfun p+ let corrector = case s of+ FPerfect -> correctAll+ FWrongPermissions -> correctAll+ FExtraFiles _ _ -> correctAll+ _ -> \_ pp -> return (OnlyNewItems, correctTheMissingRest pp)+ csummary = case s of+ FMissing -> OnlyNewItems+ FPerfect -> OnlyNewItems+ _ -> SomeItemsChangedOrRemoved+ calcCSummary :: ChangesSummary -> ChangesSummary -> ChangesSummary+ calcCSummary SomeItemsChangedOrRemoved _ = SomeItemsChangedOrRemoved+ calcCSummary _ SomeItemsChangedOrRemoved = SomeItemsChangedOrRemoved+ calcCSummary OnlyNewItems OnlyNewItems = OnlyNewItems+ children <- mapM (corrector compfun) $ Map.elems paths+ return (foldr1 calcCSummary (csummary:map fst children), concat (a:map snd children))++correctTheMissingRest :: Path -> [Action]+correctTheMissingRest p@(Path _ _ paths _ _) =+ let a = correctOne p FMissing+ children = map correctTheMissingRest $ Map.elems paths+ in+ concat (a:children)++appendNewlineIfMissing :: T.Text -> T.Text+appendNewlineIfMissing x | T.null x = x+appendNewlineIfMissing x | T.last x == '\n' = x+appendNewlineIfMissing x = T.snoc x '\n'
+ Interpret.hs view
@@ -0,0 +1,655 @@+-- MCM - Machine Configuration Manager; manages the contents of files and directories+-- Copyright (c) 2013-2016 Anthony Doggett <mcm@interfaces.org.uk>+--+-- Licence:+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program. If not, see <http://www.gnu.org/licenses/>.++module Interpret (run, fullyLoadSectionFromHandle)+where++import Control.Monad (unless, when)+import Data.Either (partitionEithers)+import Data.Maybe (fromMaybe, isNothing)+import Data.List (intercalate)+import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Data.Text.Lazy as T+import qualified Data.Text.Lazy.IO as TextIO+import qualified Data.Traversable as Traversable+import Numeric(readOct)+import System.Posix.Types(FileMode)+import System.Directory (doesFileExist)+import System.FilePath (combine)+import System.IO (Handle)++import FileCorrector (PathType(..), DirType(..), Path, Permissions(..), emptyPermissions, OwnerP(..), GroupP(..))+import InterpretState+import Parser (mcmLoadAndParse, mcmParse)+import ParserTypes (Import(..), PackagePath, lookupDefine, Section(..), Define(..), Invocation(..), InvocationArgs(..), CondLocal(..), packagePath, Content(..), Group(..), Separator(..), Prepend(..), Append(..), section, imports, InvocationCmd(..), ExpandedInvocationCmd(..), lookupImport, DefName(..), UnexpandedDefName(..), Ident(..), OptArgs(..), Locals(..), Value(..), MCMFile(..), VarsExpand(..))+import VarsParser (expandString)++{- Interpreting stages:+ - 0) Parse the initial file to get an initial State+ - (Inc. expanding any package-level lets)+ - 1) Run through all Imports, importing until everything loaded+ - 2) Run Defines, building up basic Path + fragments+ - 3) Load templates+raw and complete fragments+ - 4) Output fragments (completing Path)+ -}++run :: State -> (PackagePath, DefName, Args) -> IO (([Error], [String], Path, [(PackagePath, Group)]), State)+run s0 (pp, defname, args) = do+ (is, s1) <- case fst $ runInterpret s0 (lookupSection pp) of+ Just _ -> return ([], s0)+ Nothing -> loadSection s0 pp+ s2 <- loadImports' s1 is+ let (_, s3) = runInterpret s2 (interpret0 (pp, defname, args))+ (templatesAndRaws, s4) <- loadFiles s3+ let (_, s5) = runInterpret s4 (generate templatesAndRaws)+ return (getResult s5, s5)++-- Interpret the given (Section, DefineName, Args)+interpret0 :: (PackagePath, DefName, Args) -> Interpret ()+interpret0 (pp, defname, args) = do+ sect <- lookupSection pp+ (PLSection sect' plets) <- case sect of+ Just z -> return z+ Nothing -> do+ addError $ "Section \"" ++ show pp ++ "\" not found in imported files."+ return $ PLSection (Section [] Map.empty Map.empty) (AllLocals Map.empty)+ case lookupDefine sect' defname of+ Just d' -> interpret pp plets defname d' args+ Nothing -> addError $ "Define \"" ++ show defname ++ "\" not found in Section " ++ show pp++-- Should now have everything, so complete paths and output+generate :: Map.Map FilePath T.Text -> Interpret ()+generate templatesAndRaws = do+ let expander = fullExpandOne templatesAndRaws+ expandAllPending expander++loadFiles :: State -> IO (Map.Map FilePath T.Text, State)+loadFiles s = do+ let toLoad = getLoadFiles s+ (SearchPath sp) = getSearchPath s+ loadOne :: FilePath -> IO (FilePath, Maybe T.Text)+ loadOne f = do+ c <- keepTrying (loadOne' f) sp+ return (f, c)+ loadOne' :: FilePath -> FilePath -> IO (Maybe T.Text)+ loadOne' f d = do+ let f' = combine d f+ e <- doesFileExist f'+ if e+ then do+ r <- TextIO.readFile f'+ return $ Just r+ else return Nothing+ loaded <- mapM loadOne toLoad+ let tryFromMaybe :: (FilePath, Maybe T.Text) -> Interpret (FilePath, T.Text)+ tryFromMaybe (name, Just c) = return (name, c)+ tryFromMaybe (name, Nothing) = do+ addError $ "File not found in search path: " ++ name+ return (name, T.empty)+ (loaded', s') = runInterpret s (mapM tryFromMaybe loaded)+ return (Map.fromList loaded', s')++loadSection :: State -> PackagePath -> IO ([Import], State)+loadSection s0 pp = do+ let (SearchPath sp) = getSearchPath s0+ fpsect <- keepTrying (loadSect pp) sp+ let fpsect' = fromMaybe ("dummy", MCMFile pp (Section [] Map.empty Map.empty)) fpsect+ (_, s1) = runInterpret s0 (addNewSection pp fpsect')+ is = imports (section $ snd fpsect')+ return (is, s1)++fullyLoadSectionFromHandle :: FilePath -> Handle -> PackagePath -> State -> IO State+fullyLoadSectionFromHandle handleName h pp s0 = do+ t <- TextIO.hGetContents h+ loadImports $ snd $ runInterpret s0 $ addNewSection pp $+ case mcmParse t of+ Right a -> (handleName, a)+ Left e -> error $ intercalate "\n" (("Error parsing " ++ handleName ++ ":"):e)++-- Add the given section+-- and an error if the requested pp is not among them+-- and return the one requested by pp+addNewSection :: PackagePath -> (FilePath, MCMFile) -> Interpret ()+addNewSection pp (fp, ss) = do+ addSectionOrError ss+ r <- lookupSection pp+ case r of+ Nothing -> do+ addError $ "Section " ++ show pp ++ " not found in " ++ fp+ let dummy = MCMFile pp (Section [] Map.empty Map.empty)+ addSectionOrError dummy+ return ()+ Just _ -> return ()++-- Add the given section, or an error that it's aleady defined+addSectionOrError :: MCMFile -> Interpret ()+addSectionOrError (MCMFile name sect@(Section _ plets _)) = do+ s0 <- lookupSection name+ case s0 of+ Nothing -> do+ plets' <- solve' name (AllLocals Map.empty) plets []+ addSection (name, PLSection sect plets')+ Just _ -> addError $ "Section " ++ show name ++ " already defined."++-- Try the given action repeatedly until one succeeds or all fail+keepTrying :: Monad m => (a -> m (Maybe b)) -> [a] -> m (Maybe b)+keepTrying _ [] = return Nothing+keepTrying f (x:xs) = do+ r <- f x+ case r of+ Just _ -> return r+ Nothing -> keepTrying f xs++loadSect :: PackagePath -> FilePath -> IO (Maybe (FilePath, MCMFile))+loadSect pp fp = do+ let f = combine fp (packagePath pp)+ e <- doesFileExist f+ if e+ then do+ r <- mcmLoadAndParse f+ return $ Just (f, r)+ else return Nothing++-- Interpret the given Define using the given args+interpret :: PackagePath -> PackageLets -> DefName -> Define -> Args -> Interpret ()+interpret pp (AllLocals plets) dName d args = do+ args' <- checkForMissingArgs dName (defArgs d) args+ let expectedargs = Set.fromList(defArgs d ++ Map.keys (fromOptArgs . defOptargs $ d))+ givenargs = Map.keysSet . fromArgs $ args'+ checkForExtraArgs expectedargs givenargs+ combined <- unionLocals (fromArgs args') plets+ let uppercaseConsts =+ Map.fromList [((Ident . T.pack) "COMMA", Expanded $ T.pack ",")+ ,((Ident . T.pack) "NEWLINE", Expanded $ T.pack "\n")+ ,((Ident . T.pack) "SPACE", Expanded $ T.pack " ")+ ,((Ident . T.pack) "TAB", Expanded $ T.pack "\t")+ ]+ combined' = Args $ combined `Map.union` uppercaseConsts+ pushLocation pp dName+ al <- solve pp d combined'+ mapM_ (invoke pp al) (defInvokes d)+ popLocation++invoke :: PackagePath -> AllLocals -> Invocation -> Interpret ()+invoke pp al (Invocation icmd iargs) = do+ as <- expand pp al iargs+ let as' = Args as+ icmd' <- expandInvocationCmd pp al icmd+ alreadySeen <- logInvokeOf (icmd', pp, as')+ unless alreadySeen $ do+ let (doit, expectedArgSet) = invokationTable icmd' pp as'+ case expectedArgSet of+ Just expecArgSet -> checkForExtraArgs expecArgSet (Map.keysSet . fromInvocationArgs $ iargs)+ Nothing -> return ()+ doit++toIdentSet :: [String] -> Set.Set Ident+toIdentSet = Set.fromList . map (Ident . T.pack)++invokationTable :: ExpandedInvocationCmd -> PackagePath -> Args -> (Interpret (), Maybe (Set.Set Ident))+invokationTable ExInvDir pp as =+ (if allExpanded as then invokeDir as else invokeLater PendingPath pp as+ ,Just $ toIdentSet ["path", "owner", "group", "mode", "manage"]+ )+invokationTable ExInvFile pp as =+ (if allExpanded as then invokeFile as else invokeLater PendingFile pp as+ ,Just $ toIdentSet ["path", "owner", "group", "mode", "content"]+ )+invokationTable ExInvSymlink pp as =+ (if allExpanded as then invokeSymlink as else invokeLater PendingSymlink pp as+ ,Just $ toIdentSet ["path", "owner", "group", "mode", "link"]+ )+invokationTable ExInvAbsent pp as =+ (if allExpanded as then invokeAbsent as else invokeLater PendingAbsent pp as+ ,Just $ toIdentSet ["path"]+ )+invokationTable ExInvFragment pp as =+ (if allExpanded as then invokeFragment pp as else invokeLater PendingFragment pp as+ ,Just $ toIdentSet ["group", "name", "content"]+ )+-- NB. MUST return an "invoke now" - cannot put off for later (but don't need to)+invokationTable (ExInvLocal d) pp as =+ (interpret0 (pp, d, as), Nothing)+invokationTable (ExInvImport i d) pp as = (interpretImport, Nothing)+ where+ interpretImport = do+ thisSection <- lookupSection pp+ let thisSection' = fromMaybe (error $ "Internal error: could not lookup own section: " ++ show pp) thisSection+ impPP = lookupImport (imports.pl2section $ thisSection') i+ case impPP of+ Nothing -> addError $ "Import " ++ show i ++ " not found."+ Just impPP' -> interpret0 (impPP', d, as)++readFileMode :: String -> Interpret (Maybe FileMode)+readFileMode s = case readOct s of+ [(x, "")] -> return $ Just x+ _ -> do+ addError $ "Failed to parse mode: " ++ s+ return Nothing++parsePermissions :: Args -> Interpret Permissions+parsePermissions as = do+ let l = lookupExpanded as . Ident . T.pack+ o = l "owner"+ g = l "group"+ m = l "mode"+ m' <- case m of+ Nothing -> return Nothing+ Just s -> readFileMode $ T.unpack s+ o' <- case o of+ Nothing -> return Nothing+ Just s -> do+ s' <- parseOwner s+ return $ Just $ OwnerP (s, s')+ g' <- case g of+ Nothing -> return Nothing+ Just s -> do+ s' <- parseGroup s+ return $ Just $ GroupP (s, s')+ let perm = Perm m' o' g'+ return perm++-- To be called only once all args are Expanded+invokeDir :: Args -> Interpret ()+invokeDir as = do+ let l = lookupExpanded as . Ident . T.pack+ p = l "path"+ --t = Map.findWithDefault (Expanded $ T.pack "full") (T.pack "manage") as+ t = l "manage"+ perm <- parsePermissions as+ t' <- case t of+ Just e | e == T.pack "full" -> return Full+ Just e | e == T.pack "partial" -> return Partial+ Nothing -> return Full+ _ -> do+ addError $ "Invalid Directory manage type: " ++ show t+ return Partial+ case p of+ Just p' -> iAddPath (T.unpack p') (Dir t') perm+ Nothing -> addError "No path specified for directory"++-- To be called only once all args are Expanded+invokeSymlink :: Args -> Interpret ()+invokeSymlink as = do+ let l = lookupExpanded as . Ident . T.pack+ p = l "path"+ i = l "link"+ perm@(Perm m o g) <- parsePermissions as+ perm' <- if isNothing m+ then return perm+ else do+ addError $ "It is not possible to set the mode of a symbolic link."+ ++ " Please explicitly set the mode of the destination instead."+ return (Perm Nothing o g)+ i' <- case i of+ Nothing -> do+ addError "No link specified for symlink"+ return T.empty+ Just c -> return c+ case p of+ Just p' -> iAddPath (T.unpack p') (Symlink $ T.unpack i') perm'+ Nothing -> addError "No path specified for symlink"++invokeFile :: Args -> Interpret ()+invokeFile as = do+ let l = lookupExpanded as . Ident . T.pack+ p = l "path"+ t = l "content"+ perm <- parsePermissions as+ t' <- case t of+ Nothing -> do+ addError "No content specified for file"+ return T.empty+ Just c -> return c+ case p of+ Just p' -> iAddPath (T.unpack p') (File t') perm+ Nothing -> addError "No path specified for file"++invokeAbsent :: Args -> Interpret ()+invokeAbsent as = do+ let l = lookupExpanded as . Ident . T.pack+ p = l "path"+ case p of+ Just p' -> iAddPath (T.unpack p') Absent emptyPermissions+ Nothing -> addError "What is it that should be absent?"++invokeFragment :: PackagePath -> Args -> Interpret ()+invokeFragment pp as = do+ let l = lookupExpanded as . Ident . T.pack+ g = l "group"+ c = l "content"+ n = l "name"+ g' <- case g of+ Just s -> return s+ Nothing -> do+ addError "No group specified for Fragment"+ return $ T.pack "defaultGroup"+ c' <- case c of+ Just s -> return s+ Nothing -> do+ addError "No content specified for Fragment"+ return $ T.pack "defaultContent"+ addFragment pp (Group g') (fromMaybe c' n) c'++checkForExtraArgs :: Set.Set Ident -> Set.Set Ident -> Interpret ()+checkForExtraArgs expected actual =+ let difference = actual `Set.difference` expected+ in+ unless (Set.null difference) $+ addError $ "Unexpected argument(s): " ++ show (Set.toList difference)++checkForMissingArgs :: DefName -> [Ident] -> Args -> Interpret Args+checkForMissingArgs dName required args@(Args as) =+ let missing = Set.fromList required `Set.difference` Map.keysSet as+ dummy = Expanded $ T.pack "missingArg"+ in+ if Set.null missing then return args+ else do+ addError $ "Missing argument(s) in call of " ++ show dName+ ++ "(): " ++ show (Set.toList missing)+ return $ Args $ as `Map.union` Map.fromList (map (\m -> (m, dummy)) required)+++-- Suppose that State has been initialised+-- with the very first loaded file (stdin and/or first file loaded).+-- Load all Sections referenced in the Imports+loadImports :: State -> IO State+loadImports s0 = do+ let (imps, s1) = runInterpret s0 allImports+ loadImports' s1 imps++loadImports' :: State -> [Import] -> IO State+loadImports' s0 [] = return s0+loadImports' s0 (Import pp _:is) = do+ let (sect, s1) = runInterpret s0 (lookupSection pp)+ (newis, s2) <- case sect of+ Just _ -> return ([], s1) -- No new imports (already loaded)+ Nothing -> loadSection s1 pp+ loadImports' s2 (is++newis)++unionLocals :: Map.Map Ident a -> Map.Map Ident a -> Interpret (Map.Map Ident a)+unionLocals a b =+ let u = a `Map.union` b+ i = a `Map.intersection` b+ in do+ unless (Map.null i) $ mapM_ (\k -> addError $ "local \"" ++ show k ++ "\" is defined multiple times") (Map.keys i)+ return u++insertLocal :: Ident -> a -> Map.Map Ident a -> Interpret (Map.Map Ident a)+insertLocal k v m = do+ when (k `Map.member` m) $ addError $ "local \"" ++ show k ++ "\" is defined multiple times"+ return $ Map.insert k v m++-- NB. Given args must take precedence over optargs+solve :: PackagePath -> Define -> Args -> Interpret AllLocals+solve pp d (Args a) =+ let (OptArgs a1) = defOptargs d+ (Locals a2) = defLocals d+ a1' = Map.filterWithKey (\k _ -> Map.notMember k a) a1+ alreadySolved = AllLocals a+ in do+ alreadySolved' <- solve' pp alreadySolved a1' []+ solve' pp alreadySolved' a2 (defCondlocals d)++--solve': AllLocals = solved already, Map = tosolve, [CondLocal] = conditionals+solve' :: PackagePath -> AllLocals -> Map.Map Ident [Content] -> [CondLocal] -> Interpret AllLocals+solve' pp (AllLocals al) c [] = do+ expanded <- solveExpand pp al (Map.toList c) []+ return $ AllLocals expanded+solve' pp al c (CondLocal cond alts:xs) = do+ solution <- evaluateCond pp al c cond+ let solveFor (Locals x) = do+ combined <- unionLocals c x+ solve' pp al combined xs+ defaultSolve = if Map.null alts+ then return al+ else solveFor $ snd $ Map.elemAt 0 alts+ case solution of+ Nothing -> defaultSolve+ Just s -> case Map.lookup (Value s) alts of+ Just a -> solveFor a+ Nothing -> do+ addError $ "Error evaluating " ++ show cond ++ ": expected one of " ++ (show . Map.keys) alts ++ " but got " ++ show solution ++ "."+ defaultSolve++-- Step 3: Expand any remaining @var-s+-- Need to trap recursion (as it can't terminate)+solveExpand :: PackagePath -> Map.Map Ident Expander -> [(Ident, [Content])] -> [(Ident, [Content])] -> Interpret (Map.Map Ident Expander)+solveExpand _ solved [] [] = return solved+solveExpand pp s [] unsolved = do+ let process e = case e of+ Right _ -> error "Unexpected state within solveExpand"+ Left e' -> addError e'+ errors <- mapM (expandOne pp (AllLocals s) . snd) unsolved+ mapM_ process errors+ return s+solveExpand pp s ((a,b):xs) u = do+ expanded <- expandOne pp (AllLocals s) b+ case expanded of+ Right b' -> do+ combined <- insertLocal a b' s+ solveExpand pp combined (u++xs) []+ Left _ -> solveExpand pp s xs ((a,b):u) -- Todo: it might be worth saving the error (_) on the unsolved list++-- Solve the given conditional (case variable)+evaluateCond :: PackagePath -> AllLocals -> Map.Map Ident [Content] -> Ident -> Interpret (Maybe T.Text)+evaluateCond pp (AllLocals al) unsolvedlocals s =+ case Map.lookup s al of+ Just (Expanded e) -> return $ Just e+ _ -> case Map.lookup s unsolvedlocals of+ Just b -> do+ b' <- expandOne pp (AllLocals al) b+ case b' of+ Left e -> do+ addError $ "Failed to expand " ++ show b ++ " for the case expression \"" ++ show s ++ "\": " ++ e+ return Nothing+ Right (Expanded b'') -> return $ Just b''+ Right _ -> do+ addError $ "Failed to expand " ++ show b ++ " for the case expression \"" ++ show s ++ "\" as case expansions must be simple"+ return Nothing+ Nothing -> do+ addError $ "Failed to find definition for case variable \"" ++ show s ++ "\""+ return Nothing++{- Simultaneous equations :(+ - I need way of saying "solve [Content] to a string now if you can",+ - and otherwise store the equations for solving later.+ - Content -> Resolution:+ - CWord -> now (solve first with al)+ - CLine -> now (solve first with al)+ - CFile -> later (requires IO; solve now and later with al)+ - CFragments -> later (need to generate all fragments first; solve now and later with al; enumerate dependent fragments for dependency-calculating)+ - CRawFile -> later (requires IO; can solve with al now though)+ - Perhaps it would help to have loaded all templates & raw files in advance?+ - I still need to do fragments later though (once generated).+ -}++expandOne :: PackagePath -> AllLocals -> [Content] -> Interpret (Either String Expander)+expandOne _ _ [] = return $ Right $ Expanded $ T.pack ""+expandOne _ _ [CEmpty] = return $ Right $ Expanded $ T.pack ""+expandOne _ _ [CNewline] = return $ Right $ Expanded $ T.pack "\n"+expandOne _ _ [CRawString s] = return $ Right $ Expanded s+expandOne _ al [CString w] = return $ expandStringFromAl al w+expandOne _ al [CExplicitString w] = return $ expandStringFromAl al w+expandOne _ al [CRawFile f] =+ case expandStringFromAl al f of+ Right (Expanded s) -> do+ let s' = T.unpack s+ addToLoad s'+ return $ Right $ ERawFile s'+ Right _ -> return $ Left "Only simple expansions supported for filenames"+ Left e -> return $ Left e+expandOne _ al [CFile f] =+ case expandStringFromAl al f of+ Right (Expanded s) -> do+ let s' = T.unpack s+ addToLoad s'+ return $ Right $ EFile s' al+ Right _ -> return $ Left "Only simple expansions supported for filenames"+ Left e -> return $ Left e+expandOne pp al [CFragments (Group g) (Prepend prepend) (Append append) (Separator sep)] = do+ g' <- case expandStringFromAl al g of+ Right (Expanded s) ->+ return s+ Right _ -> do+ addError "Only simple expansions supported for group identifiers"+ return $ T.pack "complicatedGroupExpansion"+ Left e -> do+ addError e+ return $ T.pack "erroneousGroupExpansion"+ prepend' <- case expandStringFromAl al prepend of+ Right (Expanded s) ->+ return s+ Right _ -> do+ addError "Only simple expansions supported for fragment prepend strings"+ return $ T.pack "complicatedPrependExpansion"+ Left e -> do+ addError e+ return $ T.pack "erroneousPrependExpansion"+ append' <- case expandStringFromAl al append of+ Right (Expanded s) ->+ return s+ Right _ -> do+ addError "Only simple expansions supported for fragment append strings"+ return $ T.pack "complicatedAppendExpansion"+ Left e -> do+ addError e+ return $ T.pack "erroneousAppendExpansion"+ sep' <- case expandStringFromAl al sep of+ Right (Expanded s) ->+ return s+ Right _ -> do+ addError "Only simple expansions supported for fragment separators"+ return $ T.pack "complicatedSeparatorExpansion"+ Left e -> do+ addError e+ return $ T.pack "erroneousSeparatorExpansion"+ return $ Right $ EFragments pp (Group g') (Prepend prepend') (Append append') (Separator sep')+expandOne pp al xs = do+ singles <- mapM (expandOne pp al . (:[])) xs+ case partitionEithers singles of+ ([], successes) -> return $ Right $ collapseExpander successes+ (e:_, _) -> return $ Left e++expand :: PackagePath -> AllLocals -> InvocationArgs -> Interpret (Map.Map Ident Expander)+expand pp al (InvocationArgs iargs) = Traversable.mapM expand' iargs+ where+ expand' :: [Content] -> Interpret Expander+ expand' iarg = do+ x <- expandOne pp al iarg+ case x of+ Left e -> do+ addError e+ return $ Expanded $ T.pack "erroneousExpansion"+ Right y -> return y++expandInvocationCmd' :: PackagePath -> AllLocals -> UnexpandedDefName -> Interpret DefName+expandInvocationCmd' pp al ud@(UnexpandedDefName u) = do+ x <- expandOne pp al [CString u]+ case x of+ Left e -> do+ addError e+ return $ DefName $ T.pack "erroneousExpansion"+ Right (Expanded y) -> return $ DefName y+ Right _ -> do+ addError $ "Failed to fully expand: " ++ show ud+ return $ DefName $ T.pack "erroneousExpansion"++expandInvocationCmd :: PackagePath -> AllLocals -> InvocationCmd -> Interpret ExpandedInvocationCmd+expandInvocationCmd _ _ InvFile = return ExInvFile+expandInvocationCmd _ _ InvDir = return ExInvDir+expandInvocationCmd _ _ InvAbsent = return ExInvAbsent+expandInvocationCmd _ _ InvFragment = return ExInvFragment+expandInvocationCmd _ _ InvSymlink = return ExInvSymlink+expandInvocationCmd pp al (InvLocal u) = do+ d <- expandInvocationCmd' pp al u+ return $ ExInvLocal d+expandInvocationCmd pp al (InvImport i u) = do+ d <- expandInvocationCmd' pp al u+ return $ ExInvImport i d++allExpanded :: Args -> Bool+allExpanded (Args m) = allExpanded' (Map.elems m)+ where+ allExpanded' :: [Expander] -> Bool+ allExpanded' [] = True+ allExpanded' (Expanded _ :xs) = allExpanded' xs+ allExpanded' _ = False++lookupExpanded :: Args -> Ident -> Maybe T.Text+lookupExpanded (Args as) s = fromExpanded $ Map.lookup s as+ where+ fromExpanded :: Maybe Expander -> Maybe T.Text+ fromExpanded Nothing = Nothing+ fromExpanded (Just (Expanded e)) = Just e+ fromExpanded e = error $ "lookupExpanded should only ever be called when all args are fully expanded, but got: " ++ show e++fullExpandOne :: Map.Map FilePath T.Text -> Expander -> Interpret Expander+fullExpandOne _ e@(Expanded _) = return e+fullExpandOne templatesAndRaws (EFile fp al) = do+ let l = Map.lookup fp templatesAndRaws+ case l of+ Just s -> case expandStringFromAl al s of+ Left err -> do+ addError $ "Error parsing template '" ++ fp ++ "': " ++ err+ return $ Expanded $ T.pack "erroneousTemplate"+ Right s' -> return s'+ Nothing -> do+ addError $ "Internal program error: template \""++fp++"\" not found."+ return $ Expanded $ T.pack "erroneousTemplate2"+-- EFragments pp, g and s are fully expanded; assume that all fragments have been generated+fullExpandOne _ (EFragments pp g (Prepend p) (Append a) (Separator s)) = do+ frags <- takeFragments pp g+ return $ Expanded $ T.intercalate s $ map (\f -> p `T.append` f `T.append` a) frags+fullExpandOne templatesAndRaws (ERawFile fp) = do+ let l = Map.lookup fp templatesAndRaws+ case l of+ Just s -> return $ Expanded s+ Nothing -> do+ addError $ "Internal program error: raw \""++fp++"\" not found."+ return $ Expanded $ T.pack "erroneousRaw2"+fullExpandOne templatesAndRaws (EMulti es) = do+ es' <- mapM (fullExpandOne templatesAndRaws) es+ let r = foldr1 (\(Expanded a) (Expanded b) -> Expanded (a `T.append` b)) es'+ return r++-- Assume that everything expands perfectly+-- Run invocations in the order supplied (completing Path)+expandAllPending :: (Expander -> Interpret Expander) -> Interpret ()+expandAllPending expander = do+ invocations <- takeAllLaters+ mapM_ expandAndInvoke invocations+ where+ expandAndInvoke (cmd, pp, as) = do+ (cmd', pp', as') <- expandit (cmd, pp, as)+ expandAllPending' cmd' pp' as'+ expandit :: (PendingCmd, PackagePath, Args)+ -> Interpret (PendingCmd, PackagePath, Args)+ expandit (cmd, pp, Args as) = do+ as' <- Traversable.mapM expander as+ return (cmd, pp, Args as')+ expandAllPending' :: PendingCmd -> PackagePath -> Args -> Interpret ()+ expandAllPending' PendingFile _ = invokeFile+ expandAllPending' PendingPath _ = invokeDir+ expandAllPending' PendingSymlink _ = invokeSymlink+ expandAllPending' PendingAbsent _ = invokeAbsent+ expandAllPending' PendingFragment pp = invokeFragment pp++expandStringFromAl :: AllLocals -> T.Text -> Either String Expander+expandStringFromAl (AllLocals al) =+ expandString $ VarsExpand (\i _ -> i `Map.lookup` al) Expanded collapseExpander (\a _ -> Expanded a)
+ InterpretState.hs view
@@ -0,0 +1,390 @@+-- MCM - Machine Configuration Manager; manages the contents of files and directories+-- Copyright (c) 2013-2016 Anthony Doggett <mcm@interfaces.org.uk>+--+-- Licence:+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program. If not, see <http://www.gnu.org/licenses/>.++module InterpretState (State, addError, Error, getResult, Expander(..), collapseExpander, AllLocals(..), Interpret, Args(..), PendingCmd(..), runInterpret, lookupSection, allImports, takeFragments, takeAllLaters, pushLocation, popLocation, invokeLater, logInvokeOf, pl2section, addFragment, addToLoad, PackageLets, parseOwner, parseGroup, iAddPath, PLSection(..), getSearchPath, SearchPath(..), addSection, getLoadFiles, initState, Cache, setCache, getCache)+where++import Control.Applicative(Applicative(..))+import Control.Arrow((&&&))+import Control.Monad(ap, liftM, when)+import Data.List(intersect, intercalate)+import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Data.Text.Lazy as T++import FileCorrector(theRootDir,Path,addPath,PathType, Permissions)+import ParserTypes(Group(..),Section,Prepend,Append,Separator,PackagePath, dummyPP,imports,Import,ExpandedInvocationCmd,Ident(..),DefName(..))+import System.FilePath(normalise,dropTrailingPathSeparator,combine)+import System.Posix.User(UserEntry(userName, userID), GroupEntry(groupName, groupID))+import System.Posix.Types (UserID, GroupID)++newtype SearchPath = SearchPath {fromSearchPath :: [FilePath]}+ deriving (Show)++newtype Unexpanded = Unexpanded T.Text+ deriving (Show)++-- AllLocals have the Unexpanded expanded+newtype AllLocals = AllLocals (Map.Map Ident Expander)+ deriving (Show, Eq, Ord)++data Location = Location PackagePath DefName++instance Show Location where+ showsPrec _ (Location s d) = (show s++) . ('.':) . (show d++)++data Error = Error Location String++instance Show Error where+ showsPrec _ (Error l m) = ("Error in "++) . shows l . (": "++) . (m++)++-- Expanding Package-level locals is just like expanding define-level locals+type PackageLets = AllLocals++-- PLSection is like Section but in addition PackageLets have been expanded from the package lets+data PLSection = PLSection Section PackageLets+ deriving (Show, Eq)++pl2section :: PLSection -> Section+pl2section (PLSection s _) = s++-- Expander is like Content, but AllLocals have been expanded from the given strings+data Expander = Expanded T.Text+ | EFile FilePath AllLocals -- AllLocals needed for expanding template+ | EFragments PackagePath Group Prepend Append Separator+ | ERawFile FilePath+ | EMulti [Expander]+ deriving (Show, Eq, Ord)++collapseExpander :: [Expander] -> Expander+collapseExpander = ce+ where+ isExpanded (Expanded _) = True+ isExpanded _ = False+ fromExpanded (Expanded s) = s+ fromExpanded _ = error "Internal error: bad arg to fromExpanded"+ ce [x] = x+ ce xs@(Expanded _:Expanded _:_) =+ case span isExpanded xs of+ (expands, rest) -> ce (Expanded (T.concat $ map fromExpanded expands):rest)+ ce (EMulti as:bs) = EMulti [ce as, ce bs]+ ce (a:b:cs) = EMulti [a, b, ce cs]+ ce [] = Expanded T.empty++newtype Args = Args {fromArgs :: Map.Map Ident Expander}+ deriving (Show, Eq, Ord)++data PendingCmd = PendingFile | PendingPath | PendingSymlink | PendingAbsent | PendingFragment+ deriving (Show, Eq)++data PendingInvocation = PI+ {_piPp :: PackagePath+ ,piArgs :: Args+ ,_piCmd :: PendingCmd+ }+ deriving (Show, Eq)++type FragName = T.Text+type Fragments = Map.Map FragName T.Text+type FragmentGroups = Map.Map Group Fragments+type AllFragments = Map.Map PackagePath FragmentGroups++type PFMap = Map.Map (PackagePath, Group) [PendingInvocation]++data State = State+ {sPath :: Path+ ,sSections :: Map.Map PackagePath PLSection+ ,sSearchPath :: SearchPath+ ,sRoot :: FilePath+ ,sErrors :: [Error]+ ,sPendingSimple :: [PendingInvocation]+ ,sPendingFragment :: PFMap+ ,sToLoad :: Set.Set FilePath -- FilePath should be relative - will be looked for within SearchPath+ ,sFragments :: AllFragments+ ,sNewFragments :: Set.Set (PackagePath, Group)+ ,sCurrentLocation :: [Location] -- Purely for error messages (to be updated at the start of every Define invocation; head = current)+ ,sOwners :: Map.Map T.Text UserID+ ,sGroups :: Map.Map T.Text GroupID+ ,sOwnerWarnings :: Set.Set T.Text+ ,sGroupWarnings :: Set.Set T.Text+ ,sInvocationHistory :: Set.Set (ExpandedInvocationCmd, PackagePath, Args)+ }++newtype Cache = Cache (Map.Map PackagePath PLSection)++newtype Interpret a = Interpret (State -> (a, State))++instance Monad Interpret where+ Interpret c1 >>= fc2 = Interpret (\s0 -> let (r,s1) = c1 s0+ Interpret c2 = fc2 r+ in c2 s1)+ return k = Interpret (\s -> (k,s))++instance Applicative Interpret where+ pure = return+ (<*>) = ap++instance Functor Interpret where+ fmap = liftM++runInterpret :: State -> Interpret a -> (a, State)+runInterpret s0 (Interpret i) = i s0++addError :: String -> Interpret ()+addError msg =+ Interpret (\s -> ((), s {sErrors=Error ((head.sCurrentLocation) s) msg:sErrors s}))++pushLocation :: PackagePath -> DefName -> Interpret ()+pushLocation sect d = Interpret (\s -> ((), s {sCurrentLocation=Location sect d:sCurrentLocation s}))++popLocation :: Interpret ()+popLocation = Interpret (\s -> ((), s{sCurrentLocation=(tail.sCurrentLocation) s}))++showLocationStack :: [Location] -> String+showLocationStack = showLocationStack' . tail . reverse+ where+ showLocationStack' ls = intercalate "-" $ map show ls++lookupRoot :: Interpret FilePath+lookupRoot = Interpret (\s -> (sRoot s, s))++iAddPath :: FilePath -> PathType -> Permissions -> Interpret ()+iAddPath f pt perm = do+ r <- lookupRoot+ let lookupSPath = Interpret (\s -> (sPath s, s))+ let lookupLocation = Interpret (\s -> (sCurrentLocation s, s))+ sp <- lookupSPath+ l <- lookupLocation+ fp <- rootCombine r f+ case fp of+ Nothing -> return ()+ Just fp' -> case addPath sp fp' pt perm (showLocationStack l) of+ Left e -> addError e+ Right p -> Interpret (\s -> ((), s {sPath=p}))++-- NB. different from standard combine because we (always) want to prepend (sRoot s)+rootCombine :: FilePath -> FilePath -> Interpret (Maybe FilePath)+rootCombine ('/':'/':_) _ =+ addError "Internal error: impossible (and bad) root" >> return Nothing+rootCombine _ p@('/':'/':_) =+ addError ("Invalid path: " ++ p) >> return Nothing+rootCombine r ('/':p) = return $ Just $ combine r p+rootCombine _ p = addError ("Expected path to start '/' but found: " ++ p) >> return Nothing++initState :: [UserEntry] -> [GroupEntry] -> SearchPath -> FilePath -> State+initState users groups sp r =+ State theRootDir Map.empty sp r' [] [] Map.empty Set.empty Map.empty Set.empty [l0] us gs Set.empty Set.empty Set.empty+ where+ l0 = Location dummyPP $ (DefName . T.pack) "<init>"+ r' = dropTrailingPathSeparator $ normalise r+ us = Map.fromList (map ((T.pack . userName) &&& userID ) users)+ gs = Map.fromList (map ((T.pack . groupName) &&& groupID) groups)++getCache :: State -> Cache+getCache s = Cache $ sSections s++setCache :: State -> Cache -> State+setCache s (Cache ss) = s {sSections = sSections s `Map.union` ss}++getResult :: State -> ([Error], [String], Path, [(PackagePath, Group)])+getResult s = (reverse (sErrors s), ownerAndGroupWarnings, sPath s, Set.toList $ sNewFragments s)+ where+ ownerAndGroupWarnings :: [String]+ ownerAndGroupWarnings = uWs (sOwnerWarnings s) ++ gWs (sGroupWarnings s)+ where+ uWs w = map (\x -> "Warning: User " ++ T.unpack x ++ " not found. "+ ++ "Using root instead.") $ Set.toList w+ gWs w = map (\x -> "Warning: Group " ++ T.unpack x ++ " not found. "+ ++ "Using root instead.") $ Set.toList w++lookupSection :: PackagePath -> Interpret (Maybe PLSection)+lookupSection pp = Interpret (\s -> (Map.lookup pp (sSections s), s))++getSearchPath :: State -> SearchPath+getSearchPath = sSearchPath++addSection :: (PackagePath, PLSection) -> Interpret ()+addSection (name, section) = Interpret (\s -> ((), s {sSections=Map.insert name section (sSections s)}))++allImports :: Interpret [Import]+allImports = Interpret (\s -> (allImports' (Map.elems $ sSections s), s))+ where+ allImports' :: [PLSection] -> [Import]+ allImports' = concatMap (\(PLSection s _) -> imports s)++-- Record a file for loading (e.g. template, raw)+addToLoad :: FilePath -> Interpret ()+addToLoad f = Interpret (\s -> ((), s {sToLoad=Set.insert f (sToLoad s)}))++getLoadFiles :: State -> [FilePath]+getLoadFiles s = Set.toList $ sToLoad s++thisgroup :: Args -> Group+thisgroup (Args as) =+ case Map.lookup (Ident $ T.pack "group") as of+ Just (Expanded g) -> Group g+ Just _ -> error "Groups cannnot reference external files"+ Nothing -> error $ "Internal failure: fragment args without a group: " ++ show as++invokeLater :: PendingCmd -> PackagePath -> Args -> Interpret ()+invokeLater pc pp as = Interpret (\s -> ((), invokeLater' pc s))+ where+ invokeLater' PendingFragment s =+ s {sPendingFragment=addFrag (PI pp as pc) (sPendingFragment s)}+ invokeLater' _ s =+ s {sPendingSimple=PI pp as pc : sPendingSimple s}+ addFrag :: PendingInvocation -> PFMap -> PFMap+ addFrag pendi@(PI pp' as' _) =+ Map.insertWith (++) (pp', g) [pendi]+ where+ g = thisgroup as'++-- takeAllLaters solves an ordering problem: fragment dependencies+-- We need to fully process all dependent fragments first+-- And if there is a recursive loop, need to error to the user+-- We return non-Fragments last, as they can depend on fragments but aren't required by fragments+{-+ - Does a PendingFragment know which group it is for?+ - - yes: the "group" parameter+ - How do I know when a PendingFragment is ready to yield?+ - - there are no later PendingFragments that are needed+ - to generate any of its parameters (e.g. "content")+ - So:+ - 1) Spurt out all PendingFragments that don't have+ - Fragments commands in their parameters+ - (NB. complicated by EMulti)+ - (NB. complicated by movement of EFragments between files in args)+ - Collect other PendingFragments in a map of sets, grouped by+ - their (pp,group parameter) (ppgp)+ - 2) Calcualate the set of fragment (pp, group) mentioned in the+ - parameters (fgms)+ - 3) Spurt out PendingFragments once none of their fgms are in the keyset of ppgp-s+ - 4) Add to sError any loops found+ -}+takeAllLaters :: Interpret [(PendingCmd, PackagePath, Args)]+takeAllLaters = Interpret (\s -> ((extract.fragmentextract) (sPendingFragment s)+ ++ extract (sPendingSimple s)+ ,s {sPendingSimple=[], sPendingFragment=Map.empty}))+ where+ extract = map (\(PI pp args cmd) -> (cmd, pp, args))++ fragmentextract :: PFMap -> [PendingInvocation]+ fragmentextract m = orderbymentions withMentioned+ where+ withMentioned :: Map.Map (PackagePath, Group) ([(PackagePath, Group)], [PendingInvocation])+ withMentioned = Map.map addMentioned m++ orderbymentions m | Map.null m = []+ orderbymentions m = readypis' ++ orderbymentions othergroups+ where+ (readygroups, othergroups) = Map.partition (readytogo (Map.keys m)) m+ readypis :: [PendingInvocation]+ readypis = concatMap snd $ Map.elems readygroups+ readypis' = case readypis of+ [] -> error $ "Circular reference in fragments: " ++ show m+ xs -> xs+ readytogo keys (grs, _) = null (keys `intersect` grs)++ addMentioned :: [PendingInvocation] -> ([(PackagePath, Group)], [PendingInvocation])+ addMentioned pis = (concatMap mentionedfragments pis, pis)++ mentionedfragments :: PendingInvocation -> [(PackagePath, Group)]+ mentionedfragments (PI {piArgs=Args as}) = mentionedfragments' (Map.elems as)+ mentionedfragments' [] = []+ mentionedfragments' (EFragments ppF g _ _ _:as) = (ppF,g):mentionedfragments' as+ mentionedfragments' (EMulti xs:as) = mentionedfragments' xs ++ mentionedfragments' as+ mentionedfragments' (_:as) = mentionedfragments' as++addFragment :: PackagePath -> Group -> T.Text -> T.Text -> Interpret ()+addFragment pp g n c = do+ existingFragmentContent <- lookupFragment+ case existingFragmentContent of+ Nothing -> return ()+ Just c' -> when (c' /= c)+ $ addError $ "Fragment " ++ show n ++ " already exists with different content (" ++ show c ++ " vs " ++ show c' ++ ")."+ updateFragments insertFragment+ updateNewFragments+ where+ updateFragments :: (AllFragments -> AllFragments) -> Interpret ()+ updateFragments f = Interpret (\s -> ((), s {sFragments=f (sFragments s)}))++ updateNewFragments :: Interpret ()+ updateNewFragments = Interpret (\s -> ((), s {sNewFragments=Set.insert (pp, g) (sNewFragments s)}))++ lookupFragment :: Interpret (Maybe T.Text)+ lookupFragment = Interpret (\s -> (lup (sFragments s), s))+ where+ lup af = Map.lookup n $ lookupFragmentGroup af pp g++ insertFragment :: AllFragments -> AllFragments+ insertFragment af = Map.insert pp newfg af+ where+ fg :: FragmentGroups+ fg = Map.findWithDefault Map.empty pp af+ newfg :: FragmentGroups+ newfg = Map.insert g newf fg+ f :: Fragments+ f = Map.findWithDefault Map.empty g fg+ newf = Map.insert n c f++-- Return set of requested fragments+-- Fragments should be complete thanks to takeAllLaters+-- (Assumption: sPendingFragment and sPendingSimple are empty at this point)+takeFragments :: PackagePath -> Group -> Interpret [T.Text]+takeFragments pp g = Interpret takeFragments'+ where+ takeFragments' :: State -> ([T.Text], State)+ takeFragments' (s@State {sFragments=af, sNewFragments=sNew}) =+ (Map.elems (lookupFragmentGroup af pp g), s {sNewFragments=Set.delete (pp, g) sNew})++lookupFragmentGroup :: AllFragments -> PackagePath -> Group -> Fragments+lookupFragmentGroup af pp g =+ let fg :: FragmentGroups+ fg = Map.findWithDefault Map.empty pp af+ in Map.findWithDefault Map.empty g fg++parseOwner :: T.Text -> Interpret UserID+parseOwner o = do+ let lookupOwner x = Interpret (\s -> (Map.lookup x (sOwners s), s))+ let addOwnerWarning x = Interpret (\s -> ((), s {sOwnerWarnings=Set.insert x (sOwnerWarnings s)}))+ o' <- lookupOwner o+ case o' of+ Nothing -> do+ addOwnerWarning o+ r <- lookupOwner $ T.pack "root"+ case r of+ Nothing -> error "Internal assumption failure: no root user on system"+ Just r' -> return r'+ Just ii -> return ii++parseGroup :: T.Text -> Interpret GroupID+parseGroup o = do+ let lookupGroup x = Interpret (\s -> (Map.lookup x (sGroups s), s))+ let addGroupWarning x = Interpret (\s -> ((), s {sGroupWarnings=Set.insert x (sGroupWarnings s)}))+ o' <- lookupGroup o+ case o' of+ Nothing -> do+ addGroupWarning o+ r <- lookupGroup $ T.pack "root"+ case r of+ Nothing -> error "Internal assumption failure: no group \"root\" on system"+ Just r' -> return r'+ Just ii -> return ii++logInvokeOf :: (ExpandedInvocationCmd, PackagePath, Args) -> Interpret Bool+logInvokeOf t = Interpret (\s -> (Set.member t (sInvocationHistory s),+ s {sInvocationHistory=Set.insert t (sInvocationHistory s)}))
+ LICENCE view
@@ -0,0 +1,674 @@+ GNU GENERAL PUBLIC LICENSE+ Version 3, 29 June 2007++ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.++ Preamble++ The GNU General Public License is a free, copyleft license for+software and other kinds of works.++ The licenses for most software and other practical works are designed+to take away your freedom to share and change the works. By contrast,+the GNU General Public License is intended to guarantee your freedom to+share and change all versions of a program--to make sure it remains free+software for all its users. We, the Free Software Foundation, use the+GNU General Public License for most of our software; it applies also to+any other work released this way by its authors. You can apply it to+your programs, too.++ When we speak of free software, we are referring to freedom, not+price. Our General Public Licenses are designed to make sure that you+have the freedom to distribute copies of free software (and charge for+them if you wish), that you receive source code or can get it if you+want it, that you can change the software or use pieces of it in new+free programs, and that you know you can do these things.++ To protect your rights, we need to prevent others from denying you+these rights or asking you to surrender the rights. Therefore, you have+certain responsibilities if you distribute copies of the software, or if+you modify it: responsibilities to respect the freedom of others.++ For example, if you distribute copies of such a program, whether+gratis or for a fee, you must pass on to the recipients the same+freedoms that you received. You must make sure that they, too, receive+or can get the source code. And you must show them these terms so they+know their rights.++ Developers that use the GNU GPL protect your rights with two steps:+(1) assert copyright on the software, and (2) offer you this License+giving you legal permission to copy, distribute and/or modify it.++ For the developers' and authors' protection, the GPL clearly explains+that there is no warranty for this free software. For both users' and+authors' sake, the GPL requires that modified versions be marked as+changed, so that their problems will not be attributed erroneously to+authors of previous versions.++ Some devices are designed to deny users access to install or run+modified versions of the software inside them, although the manufacturer+can do so. This is fundamentally incompatible with the aim of+protecting users' freedom to change the software. The systematic+pattern of such abuse occurs in the area of products for individuals to+use, which is precisely where it is most unacceptable. Therefore, we+have designed this version of the GPL to prohibit the practice for those+products. If such problems arise substantially in other domains, we+stand ready to extend this provision to those domains in future versions+of the GPL, as needed to protect the freedom of users.++ Finally, every program is threatened constantly by software patents.+States should not allow patents to restrict development and use of+software on general-purpose computers, but in those that do, we wish to+avoid the special danger that patents applied to a free program could+make it effectively proprietary. To prevent this, the GPL assures that+patents cannot be used to render the program non-free.++ The precise terms and conditions for copying, distribution and+modification follow.++ TERMS AND CONDITIONS++ 0. Definitions.++ "This License" refers to version 3 of the GNU General Public License.++ "Copyright" also means copyright-like laws that apply to other kinds of+works, such as semiconductor masks.++ "The Program" refers to any copyrightable work licensed under this+License. Each licensee is addressed as "you". "Licensees" and+"recipients" may be individuals or organizations.++ To "modify" a work means to copy from or adapt all or part of the work+in a fashion requiring copyright permission, other than the making of an+exact copy. The resulting work is called a "modified version" of the+earlier work or a work "based on" the earlier work.++ A "covered work" means either the unmodified Program or a work based+on the Program.++ To "propagate" a work means to do anything with it that, without+permission, would make you directly or secondarily liable for+infringement under applicable copyright law, except executing it on a+computer or modifying a private copy. Propagation includes copying,+distribution (with or without modification), making available to the+public, and in some countries other activities as well.++ To "convey" a work means any kind of propagation that enables other+parties to make or receive copies. Mere interaction with a user through+a computer network, with no transfer of a copy, is not conveying.++ An interactive user interface displays "Appropriate Legal Notices"+to the extent that it includes a convenient and prominently visible+feature that (1) displays an appropriate copyright notice, and (2)+tells the user that there is no warranty for the work (except to the+extent that warranties are provided), that licensees may convey the+work under this License, and how to view a copy of this License. If+the interface presents a list of user commands or options, such as a+menu, a prominent item in the list meets this criterion.++ 1. Source Code.++ The "source code" for a work means the preferred form of the work+for making modifications to it. "Object code" means any non-source+form of a work.++ A "Standard Interface" means an interface that either is an official+standard defined by a recognized standards body, or, in the case of+interfaces specified for a particular programming language, one that+is widely used among developers working in that language.++ The "System Libraries" of an executable work include anything, other+than the work as a whole, that (a) is included in the normal form of+packaging a Major Component, but which is not part of that Major+Component, and (b) serves only to enable use of the work with that+Major Component, or to implement a Standard Interface for which an+implementation is available to the public in source code form. A+"Major Component", in this context, means a major essential component+(kernel, window system, and so on) of the specific operating system+(if any) on which the executable work runs, or a compiler used to+produce the work, or an object code interpreter used to run it.++ The "Corresponding Source" for a work in object code form means all+the source code needed to generate, install, and (for an executable+work) run the object code and to modify the work, including scripts to+control those activities. However, it does not include the work's+System Libraries, or general-purpose tools or generally available free+programs which are used unmodified in performing those activities but+which are not part of the work. For example, Corresponding Source+includes interface definition files associated with source files for+the work, and the source code for shared libraries and dynamically+linked subprograms that the work is specifically designed to require,+such as by intimate data communication or control flow between those+subprograms and other parts of the work.++ The Corresponding Source need not include anything that users+can regenerate automatically from other parts of the Corresponding+Source.++ The Corresponding Source for a work in source code form is that+same work.++ 2. Basic Permissions.++ All rights granted under this License are granted for the term of+copyright on the Program, and are irrevocable provided the stated+conditions are met. This License explicitly affirms your unlimited+permission to run the unmodified Program. The output from running a+covered work is covered by this License only if the output, given its+content, constitutes a covered work. This License acknowledges your+rights of fair use or other equivalent, as provided by copyright law.++ You may make, run and propagate covered works that you do not+convey, without conditions so long as your license otherwise remains+in force. You may convey covered works to others for the sole purpose+of having them make modifications exclusively for you, or provide you+with facilities for running those works, provided that you comply with+the terms of this License in conveying all material for which you do+not control copyright. Those thus making or running the covered works+for you must do so exclusively on your behalf, under your direction+and control, on terms that prohibit them from making any copies of+your copyrighted material outside their relationship with you.++ Conveying under any other circumstances is permitted solely under+the conditions stated below. Sublicensing is not allowed; section 10+makes it unnecessary.++ 3. Protecting Users' Legal Rights From Anti-Circumvention Law.++ No covered work shall be deemed part of an effective technological+measure under any applicable law fulfilling obligations under article+11 of the WIPO copyright treaty adopted on 20 December 1996, or+similar laws prohibiting or restricting circumvention of such+measures.++ When you convey a covered work, you waive any legal power to forbid+circumvention of technological measures to the extent such circumvention+is effected by exercising rights under this License with respect to+the covered work, and you disclaim any intention to limit operation or+modification of the work as a means of enforcing, against the work's+users, your or third parties' legal rights to forbid circumvention of+technological measures.++ 4. Conveying Verbatim Copies.++ You may convey verbatim copies of the Program's source code as you+receive it, in any medium, provided that you conspicuously and+appropriately publish on each copy an appropriate copyright notice;+keep intact all notices stating that this License and any+non-permissive terms added in accord with section 7 apply to the code;+keep intact all notices of the absence of any warranty; and give all+recipients a copy of this License along with the Program.++ You may charge any price or no price for each copy that you convey,+and you may offer support or warranty protection for a fee.++ 5. Conveying Modified Source Versions.++ You may convey a work based on the Program, or the modifications to+produce it from the Program, in the form of source code under the+terms of section 4, provided that you also meet all of these conditions:++ a) The work must carry prominent notices stating that you modified+ it, and giving a relevant date.++ b) The work must carry prominent notices stating that it is+ released under this License and any conditions added under section+ 7. This requirement modifies the requirement in section 4 to+ "keep intact all notices".++ c) You must license the entire work, as a whole, under this+ License to anyone who comes into possession of a copy. This+ License will therefore apply, along with any applicable section 7+ additional terms, to the whole of the work, and all its parts,+ regardless of how they are packaged. This License gives no+ permission to license the work in any other way, but it does not+ invalidate such permission if you have separately received it.++ d) If the work has interactive user interfaces, each must display+ Appropriate Legal Notices; however, if the Program has interactive+ interfaces that do not display Appropriate Legal Notices, your+ work need not make them do so.++ A compilation of a covered work with other separate and independent+works, which are not by their nature extensions of the covered work,+and which are not combined with it such as to form a larger program,+in or on a volume of a storage or distribution medium, is called an+"aggregate" if the compilation and its resulting copyright are not+used to limit the access or legal rights of the compilation's users+beyond what the individual works permit. Inclusion of a covered work+in an aggregate does not cause this License to apply to the other+parts of the aggregate.++ 6. Conveying Non-Source Forms.++ You may convey a covered work in object code form under the terms+of sections 4 and 5, provided that you also convey the+machine-readable Corresponding Source under the terms of this License,+in one of these ways:++ a) Convey the object code in, or embodied in, a physical product+ (including a physical distribution medium), accompanied by the+ Corresponding Source fixed on a durable physical medium+ customarily used for software interchange.++ b) Convey the object code in, or embodied in, a physical product+ (including a physical distribution medium), accompanied by a+ written offer, valid for at least three years and valid for as+ long as you offer spare parts or customer support for that product+ model, to give anyone who possesses the object code either (1) a+ copy of the Corresponding Source for all the software in the+ product that is covered by this License, on a durable physical+ medium customarily used for software interchange, for a price no+ more than your reasonable cost of physically performing this+ conveying of source, or (2) access to copy the+ Corresponding Source from a network server at no charge.++ c) Convey individual copies of the object code with a copy of the+ written offer to provide the Corresponding Source. This+ alternative is allowed only occasionally and noncommercially, and+ only if you received the object code with such an offer, in accord+ with subsection 6b.++ d) Convey the object code by offering access from a designated+ place (gratis or for a charge), and offer equivalent access to the+ Corresponding Source in the same way through the same place at no+ further charge. You need not require recipients to copy the+ Corresponding Source along with the object code. If the place to+ copy the object code is a network server, the Corresponding Source+ may be on a different server (operated by you or a third party)+ that supports equivalent copying facilities, provided you maintain+ clear directions next to the object code saying where to find the+ Corresponding Source. Regardless of what server hosts the+ Corresponding Source, you remain obligated to ensure that it is+ available for as long as needed to satisfy these requirements.++ e) Convey the object code using peer-to-peer transmission, provided+ you inform other peers where the object code and Corresponding+ Source of the work are being offered to the general public at no+ charge under subsection 6d.++ A separable portion of the object code, whose source code is excluded+from the Corresponding Source as a System Library, need not be+included in conveying the object code work.++ A "User Product" is either (1) a "consumer product", which means any+tangible personal property which is normally used for personal, family,+or household purposes, or (2) anything designed or sold for incorporation+into a dwelling. In determining whether a product is a consumer product,+doubtful cases shall be resolved in favor of coverage. For a particular+product received by a particular user, "normally used" refers to a+typical or common use of that class of product, regardless of the status+of the particular user or of the way in which the particular user+actually uses, or expects or is expected to use, the product. A product+is a consumer product regardless of whether the product has substantial+commercial, industrial or non-consumer uses, unless such uses represent+the only significant mode of use of the product.++ "Installation Information" for a User Product means any methods,+procedures, authorization keys, or other information required to install+and execute modified versions of a covered work in that User Product from+a modified version of its Corresponding Source. The information must+suffice to ensure that the continued functioning of the modified object+code is in no case prevented or interfered with solely because+modification has been made.++ If you convey an object code work under this section in, or with, or+specifically for use in, a User Product, and the conveying occurs as+part of a transaction in which the right of possession and use of the+User Product is transferred to the recipient in perpetuity or for a+fixed term (regardless of how the transaction is characterized), the+Corresponding Source conveyed under this section must be accompanied+by the Installation Information. But this requirement does not apply+if neither you nor any third party retains the ability to install+modified object code on the User Product (for example, the work has+been installed in ROM).++ The requirement to provide Installation Information does not include a+requirement to continue to provide support service, warranty, or updates+for a work that has been modified or installed by the recipient, or for+the User Product in which it has been modified or installed. Access to a+network may be denied when the modification itself materially and+adversely affects the operation of the network or violates the rules and+protocols for communication across the network.++ Corresponding Source conveyed, and Installation Information provided,+in accord with this section must be in a format that is publicly+documented (and with an implementation available to the public in+source code form), and must require no special password or key for+unpacking, reading or copying.++ 7. Additional Terms.++ "Additional permissions" are terms that supplement the terms of this+License by making exceptions from one or more of its conditions.+Additional permissions that are applicable to the entire Program shall+be treated as though they were included in this License, to the extent+that they are valid under applicable law. If additional permissions+apply only to part of the Program, that part may be used separately+under those permissions, but the entire Program remains governed by+this License without regard to the additional permissions.++ When you convey a copy of a covered work, you may at your option+remove any additional permissions from that copy, or from any part of+it. (Additional permissions may be written to require their own+removal in certain cases when you modify the work.) You may place+additional permissions on material, added by you to a covered work,+for which you have or can give appropriate copyright permission.++ Notwithstanding any other provision of this License, for material you+add to a covered work, you may (if authorized by the copyright holders of+that material) supplement the terms of this License with terms:++ a) Disclaiming warranty or limiting liability differently from the+ terms of sections 15 and 16 of this License; or++ b) Requiring preservation of specified reasonable legal notices or+ author attributions in that material or in the Appropriate Legal+ Notices displayed by works containing it; or++ c) Prohibiting misrepresentation of the origin of that material, or+ requiring that modified versions of such material be marked in+ reasonable ways as different from the original version; or++ d) Limiting the use for publicity purposes of names of licensors or+ authors of the material; or++ e) Declining to grant rights under trademark law for use of some+ trade names, trademarks, or service marks; or++ f) Requiring indemnification of licensors and authors of that+ material by anyone who conveys the material (or modified versions of+ it) with contractual assumptions of liability to the recipient, for+ any liability that these contractual assumptions directly impose on+ those licensors and authors.++ All other non-permissive additional terms are considered "further+restrictions" within the meaning of section 10. If the Program as you+received it, or any part of it, contains a notice stating that it is+governed by this License along with a term that is a further+restriction, you may remove that term. If a license document contains+a further restriction but permits relicensing or conveying under this+License, you may add to a covered work material governed by the terms+of that license document, provided that the further restriction does+not survive such relicensing or conveying.++ If you add terms to a covered work in accord with this section, you+must place, in the relevant source files, a statement of the+additional terms that apply to those files, or a notice indicating+where to find the applicable terms.++ Additional terms, permissive or non-permissive, may be stated in the+form of a separately written license, or stated as exceptions;+the above requirements apply either way.++ 8. Termination.++ You may not propagate or modify a covered work except as expressly+provided under this License. Any attempt otherwise to propagate or+modify it is void, and will automatically terminate your rights under+this License (including any patent licenses granted under the third+paragraph of section 11).++ However, if you cease all violation of this License, then your+license from a particular copyright holder is reinstated (a)+provisionally, unless and until the copyright holder explicitly and+finally terminates your license, and (b) permanently, if the copyright+holder fails to notify you of the violation by some reasonable means+prior to 60 days after the cessation.++ Moreover, your license from a particular copyright holder is+reinstated permanently if the copyright holder notifies you of the+violation by some reasonable means, this is the first time you have+received notice of violation of this License (for any work) from that+copyright holder, and you cure the violation prior to 30 days after+your receipt of the notice.++ Termination of your rights under this section does not terminate the+licenses of parties who have received copies or rights from you under+this License. If your rights have been terminated and not permanently+reinstated, you do not qualify to receive new licenses for the same+material under section 10.++ 9. Acceptance Not Required for Having Copies.++ You are not required to accept this License in order to receive or+run a copy of the Program. Ancillary propagation of a covered work+occurring solely as a consequence of using peer-to-peer transmission+to receive a copy likewise does not require acceptance. However,+nothing other than this License grants you permission to propagate or+modify any covered work. These actions infringe copyright if you do+not accept this License. Therefore, by modifying or propagating a+covered work, you indicate your acceptance of this License to do so.++ 10. Automatic Licensing of Downstream Recipients.++ Each time you convey a covered work, the recipient automatically+receives a license from the original licensors, to run, modify and+propagate that work, subject to this License. You are not responsible+for enforcing compliance by third parties with this License.++ An "entity transaction" is a transaction transferring control of an+organization, or substantially all assets of one, or subdividing an+organization, or merging organizations. If propagation of a covered+work results from an entity transaction, each party to that+transaction who receives a copy of the work also receives whatever+licenses to the work the party's predecessor in interest had or could+give under the previous paragraph, plus a right to possession of the+Corresponding Source of the work from the predecessor in interest, if+the predecessor has it or can get it with reasonable efforts.++ You may not impose any further restrictions on the exercise of the+rights granted or affirmed under this License. For example, you may+not impose a license fee, royalty, or other charge for exercise of+rights granted under this License, and you may not initiate litigation+(including a cross-claim or counterclaim in a lawsuit) alleging that+any patent claim is infringed by making, using, selling, offering for+sale, or importing the Program or any portion of it.++ 11. Patents.++ A "contributor" is a copyright holder who authorizes use under this+License of the Program or a work on which the Program is based. The+work thus licensed is called the contributor's "contributor version".++ A contributor's "essential patent claims" are all patent claims+owned or controlled by the contributor, whether already acquired or+hereafter acquired, that would be infringed by some manner, permitted+by this License, of making, using, or selling its contributor version,+but do not include claims that would be infringed only as a+consequence of further modification of the contributor version. For+purposes of this definition, "control" includes the right to grant+patent sublicenses in a manner consistent with the requirements of+this License.++ Each contributor grants you a non-exclusive, worldwide, royalty-free+patent license under the contributor's essential patent claims, to+make, use, sell, offer for sale, import and otherwise run, modify and+propagate the contents of its contributor version.++ In the following three paragraphs, a "patent license" is any express+agreement or commitment, however denominated, not to enforce a patent+(such as an express permission to practice a patent or covenant not to+sue for patent infringement). To "grant" such a patent license to a+party means to make such an agreement or commitment not to enforce a+patent against the party.++ If you convey a covered work, knowingly relying on a patent license,+and the Corresponding Source of the work is not available for anyone+to copy, free of charge and under the terms of this License, through a+publicly available network server or other readily accessible means,+then you must either (1) cause the Corresponding Source to be so+available, or (2) arrange to deprive yourself of the benefit of the+patent license for this particular work, or (3) arrange, in a manner+consistent with the requirements of this License, to extend the patent+license to downstream recipients. "Knowingly relying" means you have+actual knowledge that, but for the patent license, your conveying the+covered work in a country, or your recipient's use of the covered work+in a country, would infringe one or more identifiable patents in that+country that you have reason to believe are valid.++ If, pursuant to or in connection with a single transaction or+arrangement, you convey, or propagate by procuring conveyance of, a+covered work, and grant a patent license to some of the parties+receiving the covered work authorizing them to use, propagate, modify+or convey a specific copy of the covered work, then the patent license+you grant is automatically extended to all recipients of the covered+work and works based on it.++ A patent license is "discriminatory" if it does not include within+the scope of its coverage, prohibits the exercise of, or is+conditioned on the non-exercise of one or more of the rights that are+specifically granted under this License. You may not convey a covered+work if you are a party to an arrangement with a third party that is+in the business of distributing software, under which you make payment+to the third party based on the extent of your activity of conveying+the work, and under which the third party grants, to any of the+parties who would receive the covered work from you, a discriminatory+patent license (a) in connection with copies of the covered work+conveyed by you (or copies made from those copies), or (b) primarily+for and in connection with specific products or compilations that+contain the covered work, unless you entered into that arrangement,+or that patent license was granted, prior to 28 March 2007.++ Nothing in this License shall be construed as excluding or limiting+any implied license or other defenses to infringement that may+otherwise be available to you under applicable patent law.++ 12. No Surrender of Others' Freedom.++ If conditions are imposed on you (whether by court order, agreement or+otherwise) that contradict the conditions of this License, they do not+excuse you from the conditions of this License. If you cannot convey a+covered work so as to satisfy simultaneously your obligations under this+License and any other pertinent obligations, then as a consequence you may+not convey it at all. For example, if you agree to terms that obligate you+to collect a royalty for further conveying from those to whom you convey+the Program, the only way you could satisfy both those terms and this+License would be to refrain entirely from conveying the Program.++ 13. Use with the GNU Affero General Public License.++ Notwithstanding any other provision of this License, you have+permission to link or combine any covered work with a work licensed+under version 3 of the GNU Affero General Public License into a single+combined work, and to convey the resulting work. The terms of this+License will continue to apply to the part which is the covered work,+but the special requirements of the GNU Affero General Public License,+section 13, concerning interaction through a network will apply to the+combination as such.++ 14. Revised Versions of this License.++ The Free Software Foundation may publish revised and/or new versions of+the GNU General Public License from time to time. Such new versions will+be similar in spirit to the present version, but may differ in detail to+address new problems or concerns.++ Each version is given a distinguishing version number. If the+Program specifies that a certain numbered version of the GNU General+Public License "or any later version" applies to it, you have the+option of following the terms and conditions either of that numbered+version or of any later version published by the Free Software+Foundation. If the Program does not specify a version number of the+GNU General Public License, you may choose any version ever published+by the Free Software Foundation.++ If the Program specifies that a proxy can decide which future+versions of the GNU General Public License can be used, that proxy's+public statement of acceptance of a version permanently authorizes you+to choose that version for the Program.++ Later license versions may give you additional or different+permissions. However, no additional obligations are imposed on any+author or copyright holder as a result of your choosing to follow a+later version.++ 15. Disclaimer of Warranty.++ THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY+APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT+HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY+OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR+PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM+IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF+ALL NECESSARY SERVICING, REPAIR OR CORRECTION.++ 16. Limitation of Liability.++ IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS+THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY+GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE+USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF+DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD+PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),+EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF+SUCH DAMAGES.++ 17. Interpretation of Sections 15 and 16.++ If the disclaimer of warranty and limitation of liability provided+above cannot be given local legal effect according to their terms,+reviewing courts shall apply local law that most closely approximates+an absolute waiver of all civil liability in connection with the+Program, unless a warranty or assumption of liability accompanies a+copy of the Program in return for a fee.++ END OF TERMS AND CONDITIONS++ How to Apply These Terms to Your New Programs++ If you develop a new program, and you want it to be of the greatest+possible use to the public, the best way to achieve this is to make it+free software which everyone can redistribute and change under these terms.++ To do so, attach the following notices to the program. It is safest+to attach them to the start of each source file to most effectively+state the exclusion of warranty; and each file should have at least+the "copyright" line and a pointer to where the full notice is found.++ <one line to give the program's name and a brief idea of what it does.>+ Copyright (C) <year> <name of author>++ This program is free software: you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation, either version 3 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program. If not, see <http://www.gnu.org/licenses/>.++Also add information on how to contact you by electronic and paper mail.++ If the program does terminal interaction, make it output a short+notice like this when it starts in an interactive mode:++ <program> Copyright (C) <year> <name of author>+ This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.+ This is free software, and you are welcome to redistribute it+ under certain conditions; type `show c' for details.++The hypothetical commands `show w' and `show c' should show the appropriate+parts of the General Public License. Of course, your program's commands+might be different; for a GUI interface, you would use an "about box".++ You should also get your employer (if you work as a programmer) or school,+if any, to sign a "copyright disclaimer" for the program, if necessary.+For more information on this, and how to apply and follow the GNU GPL, see+<http://www.gnu.org/licenses/>.++ The GNU General Public License does not permit incorporating your program+into proprietary programs. If your program is a subroutine library, you+may consider it more useful to permit linking proprietary applications with+the library. If this is what you want to do, use the GNU Lesser General+Public License instead of this License. But first, please read+<http://www.gnu.org/philosophy/why-not-lgpl.html>.
+ Parser.hs view
@@ -0,0 +1,485 @@+-- MCM - Machine Configuration Manager; manages the contents of files and directories+-- Copyright (c) 2013-2016 Anthony Doggett <mcm@interfaces.org.uk>+--+-- Licence:+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program. If not, see <http://www.gnu.org/licenses/>.++module Parser (mcmParse, mcmLoadAndParse, mcmParsePackagePath)+where++import Control.Monad(unless, when)+import Data.Char (isLower, isUpper, isAlpha, isAlphaNum, isSpace, generalCategory, GeneralCategory(..))+import Data.List (intercalate)+import Data.Int (Int64)+import Data.Foldable (foldlM)+import qualified Data.Map as Map+import qualified Data.Text.Lazy as T+import qualified Data.Text.Lazy.IO as TextIO+import Text.ParserCombinators.Poly.StateText++import ParserTypes++-- State is (LineNumber, [ParseErrors])+newtype State = State (Int, [String])+ deriving Show++type P = Parser State++initState :: State+initState = State (1, [])++incNewline :: P ()+incNewline = stUpdate (\(State (n, es)) -> State(n+1, es))++addError :: String -> P ()+addError e = stUpdate (\(State (n, es)) -> State(n, prep n:es))+ where+ prep n = "line " ++ show n ++ ": " ++ e++adjustError :: P a -> String -> P a+adjustError pa e = do+ n <- stQuery (\(State (n, _)) -> n)+ pa `adjustErr` (("line " ++ show n ++ ": " ++ e ++ "\n")++)++prettyFail :: String -> P ()+prettyFail e = do+ n <- stQuery (\(State (n, _)) -> n)+ fail $ "line " ++ show n ++ ": " ++ e++prettyFailBad :: String -> P ()+prettyFailBad = commit . prettyFail++ensureEof :: P ()+ensureEof =+ oneOf+ [eof+ ,do+ n <- stQuery (\(State (n, _)) -> n)+ r <- manySatisfy(/= '\n')+ failBad $ "Parsing unexpectedly ended at line " ++ show n +++ " with the rest of the line being " ++ show r+ ]++toContent' :: ContentType -> ContentLine -> P [Content]+toContent' ct cl = case toContent ct cl of+ Left e -> addError e >> return []+ Right cs -> return cs++checkUniqueAndInsert :: (Show t, Ord t) => String -> Map.Map t a -> (t, a) -> P (Map.Map t a)+checkUniqueAndInsert s m (k,v) = do+ when (k `Map.member` m) $ addError $ s ++ " \"" ++ show k ++ "\" is defined multiple times"+ return $ Map.insert k v m++checkUniqueAndUnion :: (Show t, Ord t) => String -> Map.Map t a -> Map.Map t a -> P (Map.Map t a)+checkUniqueAndUnion s m1 m2 = do+ let i = m1 `Map.intersection` m2+ unless (Map.null i) $ mapM_ ((\k -> addError $ s ++ "\" \"" ++ k ++ "\" is defined multiple times") . show) $ Map.keys i+ return $ Map.union m1 m2++char :: Char -> P ()+char c = do+ n <- next+ unless (c == n) $ prettyFail $ "expected " ++ show c ++ " but got " ++ show n++isSpaceOrTab :: Char -> Bool+isSpaceOrTab '\t' = True+isSpaceOrTab ' ' = True+isSpaceOrTab _ = False++pSpaceButCheckOthers :: P ()+pSpaceButCheckOthers = do+ w <- manySatisfy isSpaceOrTab+ unless (T.length w == 1 && T.unpack w == " ") $+ addError $ "was expecting a single space character but got " ++ show w++pSpaceButCheckSingleTab :: P ()+pSpaceButCheckSingleTab = do+ c <- next+ when (c == '\t') $+ addError $ "was expecting a single space character but got " ++ show c+ unless (isSpaceOrTab c) $+ prettyFail $ "was expecting a single space character but got " ++ show c++nToWord :: Int64 -> String -> String -> String+nToWord 0 _ plural = "no " ++ plural+nToWord 1 single _ = "one " ++ single+nToWord 2 _ plural = "two " ++ plural+nToWord 3 _ plural = "three " ++ plural+nToWord 4 _ plural = "four " ++ plural+nToWord 5 _ plural = "five " ++ plural+nToWord 6 _ plural = "six " ++ plural+nToWord 7 _ plural = "seven " ++ plural+nToWord 8 _ plural = "eight " ++ plural+nToWord 9 _ plural = "nine " ++ plural+nToWord 10 _ plural = "ten " ++ plural+nToWord n _ plural = show n ++ " " ++ plural++pIndentN :: Int64 -> P ()+pIndentN n = do+ w <- many1Satisfy isSpaceOrTab `adjustError`+ "was expecting at least one tab"+ let tabs = nToWord n "tab character" "tab characters"+ nspaces = T.count (T.pack " ") w+ spaces = nToWord nspaces "space" "spaces"+ when (nspaces /= 0) $+ prettyFailBad $ "was expecting an indent using just tabs but found " ++ spaces ++ ": " ++ show w+ unless (T.length w == n && T.count (T.pack "\t") w == n) $+ prettyFail $ "was expecting an indent with " ++ tabs ++ " but got " ++ show w++pIndent :: P ()+pIndent = pIndentN 1++pIndent2 :: P ()+pIndent2 = pIndentN 2++pIndent3 :: P ()+pIndent3 = pIndentN 3++keyword :: T.Text -> P ()+keyword s = do+ let fmsg = "was expecting the keyword '" ++ T.unpack s ++ "'"+ found <- many1Satisfy isAlpha `adjustError` fmsg+ when (s /= found) $ prettyFail $ fmsg ++ " but found '" ++ T.unpack found ++ "'"+ return ()++isOtherLetter :: Char -> Bool+isOtherLetter c = generalCategory c == OtherLetter++isUnderscore :: Char -> Bool+isUnderscore c = c == '_'++isAt :: Char -> Bool+isAt c = c == '@'++pOUword_ :: P T.Text+pOUword_ = do+ let fmsg = "expected a word_ starting with an uppercase letter"+ as <- many1Satisfy (\c -> isAlphaNum c || isUnderscore c) `adjustError` fmsg+ let f c = isUpper c || isOtherLetter c+ unless (f $ T.head as) $ prettyFail fmsg+ return as++pOLwordMaker :: (Char -> Bool) -> P T.Text+pOLwordMaker validChar = do+ let fmsg = "expected a word starting with a lowercase letter"+ as <- many1Satisfy validChar `adjustError` fmsg+ let f c = isLower c || isOtherLetter c+ unless (f $ T.head as) $ prettyFail fmsg+ return as++pOLword_ :: P T.Text+pOLword_ = pOLwordMaker (\c -> isAlphaNum c || isUnderscore c)++pOLwordAt_ :: P T.Text+pOLwordAt_ = do+ let validChar c = isAlphaNum c || isUnderscore c || isAt c+ let fmsg = "expected a word starting with a lowercase letter or '@'"+ as <- many1Satisfy validChar `adjustError` fmsg+ let f c = isLower c || isOtherLetter c || isAt c+ unless (f $ T.head as) $ prettyFail fmsg+ return as++mcmParsePackagePath :: T.Text -> Either [String] PackagePath+mcmParsePackagePath t = case runParser pPackagePath' initState t of+ (Left s, State(_, es), _) -> Left (s:reverse es)+ (Right pp, State(_, []), v) | T.null v -> Right pp+ (Right _, State(_, es), v) | T.null v -> Left $ reverse es+ (Right _, State(_, es), v) -> Left (("Failed to parse end: " ++ T.unpack v):reverse es)+ where+ pPackagePath' = do {r <- pPackagePath; eof; return r}++mcmParse :: T.Text -> Either [String] MCMFile+mcmParse t = case runParser pFile initState t of+ (Left s, State(_, es), _) -> Left (s:reverse es)+ (Right pp, State(_, []), v) | T.null v -> Right pp+ (Right _, State(_, es), v) | T.null v -> Left $ reverse es+ (Right _, State(_, es), v) -> Left (("Failed to parse end: " ++ T.unpack v):reverse es)++mcmLoadAndParse :: FilePath -> IO MCMFile+mcmLoadAndParse f = do+ t <- TextIO.readFile f+ case mcmParse t of+ Right s -> return s+ Left e -> error $ intercalate "\n" (("Error parsing " ++ f ++ ":") : e)++pFile :: P MCMFile+pFile = do+ pp <- pHeader+ pMaybeEmptyLinesAndComments+ is <- many pImport+ when (is /= []) pMaybeEmptyLinesAndComments+ packagelocals <- many pPackageLocals+ packagelocals' <- foldlM (checkUniqueAndUnion "packagelocal") Map.empty packagelocals+ unless (Map.null packagelocals') pMaybeEmptyLinesAndComments+ defines <- many (do {d <- pDefine; pMaybeEmptyLinesAndComments; return d})+ defines' <- foldlM (checkUniqueAndInsert "define") Map.empty defines+ ensureEof+ return $ MCMFile pp (Section is packagelocals' defines')++pHeader :: P PackagePath+pHeader = do+ keyword (T.pack "MCM")+ pSpaceButCheckOthers+ pp <- pPackagePath+ pJustNewline+ return pp++pMaybeEmptyLinesAndComments :: P ()+pMaybeEmptyLinesAndComments = do+ _ <- many $ oneOf [pJustNewline, pComment]+ return ()++pIndentAndMaybeComments :: P ()+pIndentAndMaybeComments = do+ pIndent+ _ <- many (do {pComment; pIndent `adjustError`+ "expected a tab to indent the line following the comment"})+ return ()++pIndent3AndMaybeComments :: P ()+pIndent3AndMaybeComments = do+ pIndent3+ _ <- many (do {pComment; pIndent3 `adjustError`+ "expected three tabs to indent the line following the comment"})+ return ()++pJustNewline :: P ()+pJustNewline = do+ c <- next+ unless (c == '\n') $ prettyFail "failed to match end of line"+ incNewline++pManyUntilNewline :: P T.Text+pManyUntilNewline = manySatisfy (/= '\n')++pComment :: P ()+pComment = do+ char '#'+ commit nop+ _ <- pManyUntilNewline+ pJustNewline++nop :: P ()+nop = return ()++pPackagePath :: P PackagePath+pPackagePath = do+ ps <- sepBy1 pOUword_ (char '.' >> commit nop) `adjustError`+ "failed to parse package path"+ return $ PackagePath ps++pImport :: P Import+pImport = do+ keyword (T.pack "import")+ pSpaceButCheckOthers+ pp <- pPackagePath+ pSpaceButCheckOthers+ keyword (T.pack "as")+ pSpaceButCheckOthers+ label <- pOUword_+ pJustNewline+ return $ Import pp label++pPackageLocals :: P (Map.Map Ident [Content])+pPackageLocals = pLocals++pLocals :: P (Map.Map Ident [Content])+pLocals = do+ keyword (T.pack "let")+ ls <- oneOf+ [do pSpaceButCheckSingleTab+ l <- pImmediateLocal+ ls <- many pIndentedLocal+ return (l:ls)+ ,pJustNewline >> many pIndentedLocal+ ] `adjustError` "Invalid syntax for 'let'"+ foldlM (checkUniqueAndInsert "local") Map.empty ls++pImmediateLocal :: P (Ident, [Content])+pImmediateLocal = do+ i <- fmap Ident pOLword_+ pSpaceButCheckOthers+ char '='+ c <- oneOf+ [pContent+ ,return []+ ]+ cs <- pArgMore+ pJustNewline+ return (i, c ++ cs)++pIndentedLocal :: P (Ident, [Content])+pIndentedLocal = do+ pIndent2+ pImmediateLocal++pContent :: P [Content]+pContent = do+ ct <- pContentType pSpaceButCheckSingleTab+ c <- pManyUntilNewline+ toContent' ct (Plain c)++pDefine :: P (DefName, Define)+pDefine = do+ keyword (T.pack "define")+ pSpaceButCheckOthers+ name <- fmap DefName pOLword_+ char '('+ args <- sepBy (fmap Ident pOLword_) (char ' ') `adjustError`+ "failed to parse define arguments"+ optargs <- oneOf+ [do {char ')'; return []}+ ,do {pJustNewline; r <- many pIndentedLocal; pIndent; char ')'; return r}+ ] `adjustError` "failed to parse arguments list"+ optargs' <- OptArgs <$> foldlM (checkUniqueAndInsert "optarg") Map.empty optargs+ pJustNewline+ (locals, condlocals, invokes) <- oneOf+ [do {pIndentAndMaybeComments; pDefine'}+ ,return (Locals Map.empty, [], [])+ ]+ return (name, Define name args optargs' locals condlocals invokes)++-- NB. Must parse something before the end of the define+-- (Comments don't count as "something")+pDefine' :: P (Locals, [CondLocal], [Invocation])+pDefine' = do+ locals <- sepBy pLocals pIndentAndMaybeComments `adjustError`+ "failed to parse define locals"+ (condlocals, invokes) <- if locals /= []+ then oneOf+ [do {pIndentAndMaybeComments; pDefine''}+ ,return ([], [])+ ]+ else pDefine''+ locals' <- Locals <$> foldlM (checkUniqueAndUnion "local") Map.empty locals+ return (locals', condlocals, invokes)++pDefine'' :: P ([CondLocal], [Invocation])+pDefine'' = do+ condlocals <- sepBy pCondLocal pIndentAndMaybeComments+ invokes <- if condlocals /= []+ then oneOf+ [do {pIndentAndMaybeComments; sepBy pInvoke pIndentAndMaybeComments}+ ,return []+ ]+ else sepBy pInvoke pIndentAndMaybeComments+ return (condlocals, invokes)++pCondLocal :: P CondLocal+pCondLocal = do+ keyword (T.pack "case")+ pSpaceButCheckOthers+ cond <- fmap Ident pOLword_+ pJustNewline+ whens <- many pWhen+ whensMaps <- foldlM (checkUniqueAndInsert "when") Map.empty whens+ let whenKeys = map (Map.keys . fromLocals . snd) whens+ let allTheSame [] = True+ allTheSame (x:xs) = all (==x) xs+ unless (allTheSame whenKeys) $+ addError $ unwords+ ["conditional mismatch:"+ ,show whenKeys+ ]+ return $ CondLocal cond whensMaps++pWhen :: P (Value, Locals)+pWhen = do+ pIndent+ keyword (T.pack "when")+ pSpaceButCheckOthers+ v <- fmap Value pManyUntilNewline+ pJustNewline+ locals <- many pIndentedLocal+ locals' <- foldlM (checkUniqueAndInsert "when local") Map.empty locals+ return (v, Locals locals')++pInvoke :: P Invocation+pInvoke = do+ cmd <- pInvokationCmd+ args <- many pArg+ args' <- InvocationArgs <$> foldlM (checkUniqueAndInsert "arg") Map.empty args+ pJustNewline+ return $ Invocation cmd args'++pInvokationCmd :: P InvocationCmd+pInvokationCmd = oneOf+ [do {char '.'; (InvLocal . UnexpandedDefName) <$> pOLwordAt_}+ ,do k <- pOUword_+ case T.unpack k of+ "Absent" -> return InvAbsent+ "Dir" -> return InvDir+ "Symlink" -> return InvSymlink+ "File" -> return InvFile+ "Fragment" -> return InvFragment+ _ -> oneOf+ [do char '.'+ d <- pOLwordAt_+ return $ InvImport k (UnexpandedDefName d)+ ,do addError $ "Unexpected command " ++ show k+ return $ InvImport k (UnexpandedDefName $ T.pack "unexpectedCommand")+ ]+ ]++pArg :: P (Ident, [Content])+pArg = do+ oneOf+ [do {pJustNewline; pIndent2}+ ,pSpaceButCheckOthers+ ]+ i <- fmap Ident pOLword_+ a <- pInitialArg+ as <- pArgMore+ return (i, a ++ as)++pContentType :: P () -> P ContentType+pContentType spaceparser = oneOf+ [char '$' >> return CTDollar+ ,pNothingIfAtEndOfLine >> return CTSpace+ ,spaceparser >> return CTSpace+ ]++pInitialArg :: P [Content]+pInitialArg = oneOf+ [do char ':'+ ct <- pContentType pSpaceButCheckSingleTab+ l <- pManyUntilNewline+ toContent' ct (Plain l)+ ,do char '>'+ ct <- pContentType pSpaceButCheckOthers+ l <- many1Satisfy (not . isSpace)+ toContent' ct (Plain l)+ ]++pArgMore :: P [Content]+pArgMore = concat <$> many pArgCont++pArgCont :: P [Content]+pArgCont = do+ pJustNewline+ pIndent3AndMaybeComments+ t <- oneOf+ [do {char '+'; return PrependNewline}+ ,do {char '\\'; return Plain}+ ] `adjustError` "was expecting '+' or '\\'"+ ct <- pContentType pSpaceButCheckSingleTab+ l <- pManyUntilNewline+ toContent' ct (t l)++-- Parse nothing if at the end of the line already+pNothingIfAtEndOfLine :: P T.Text+pNothingIfAtEndOfLine = do+ cs <- pManyUntilNewline+ unless (T.null cs) $ prettyFail "expected end of line"+ return T.empty
+ ParserTypes.hs view
@@ -0,0 +1,173 @@+-- MCM - Machine Configuration Manager; manages the contents of files and directories+-- Copyright (c) 2013-2016 Anthony Doggett <mcm@interfaces.org.uk>+--+-- Licence:+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program. If not, see <http://www.gnu.org/licenses/>.++module ParserTypes (Import(..), PackagePath(..), dummyPP, packagePath, Ident(..), Value(..), UnexpandedDefName(..), DefName(..), Locals(..), OptArgs(..), CondLocal(..), Define(..), Section(..), section, imports, lookupDefine, lookupImport, InvocationCmd(..), ExpandedInvocationCmd(..), InvocationArgs(..), MCMFile(..), Invocation(..), Group(..), Separator(..), Prepend(..), Append(..), ContentLine(..), Content(..), ContentType(..), toContent, VarsExpand(..)) where++import Data.Char (isAlpha)+import Data.List (find, intercalate)+import qualified Data.Map as Map+import qualified Data.Text.Lazy as T+import System.FilePath (joinPath)++-- For translating the full PackagePath into a short name+data Import = Import PackagePath T.Text+ deriving (Show, Eq)++lookupImport :: [Import] -> T.Text -> Maybe PackagePath+lookupImport is i =+ case find (\(Import _ s) -> i==s) is of+ Nothing -> Nothing+ Just (Import pp _) -> Just pp++newtype PackagePath = PackagePath [T.Text]+ deriving (Eq, Ord)++dummyPP :: PackagePath+dummyPP = PackagePath []++instance Show PackagePath where+ show (PackagePath pp) = intercalate "." $ map T.unpack pp++packagePath :: PackagePath -> FilePath+packagePath (PackagePath pp) = joinPath (map T.unpack pp) ++ ".mcm"++newtype Ident = Ident {fromIdent :: T.Text}+ deriving (Eq, Ord)+newtype Value = Value T.Text+ deriving (Eq, Ord)+newtype DefName = DefName {fromDefName :: T.Text}+ deriving (Eq, Ord)+-- UnexpandedDefName is like DefName but can contain one or more @-vars that need expanding+newtype UnexpandedDefName = UnexpandedDefName {fromUnexpandedDefName :: T.Text}+ deriving (Eq, Ord)++instance Show Ident where+ show (Ident i) = T.unpack i+instance Show Value where+ show (Value v) = T.unpack v+instance Show DefName where+ show (DefName d) = T.unpack d+instance Show UnexpandedDefName where+ show (UnexpandedDefName d) = T.unpack d++newtype Locals = Locals {fromLocals :: Map.Map Ident [Content]}+ deriving (Show, Eq)++newtype OptArgs = OptArgs{fromOptArgs :: Map.Map Ident [Content]}+ deriving (Show, Eq)++data CondLocal = CondLocal Ident (Map.Map Value Locals)+ deriving (Show, Eq)++data Define = Define {defName :: DefName+ ,defArgs :: [Ident]+ ,defOptargs :: OptArgs+ ,defLocals :: Locals+ ,defCondlocals :: [CondLocal]+ ,defInvokes :: [Invocation]+ }+ deriving (Show, Eq)++lookupDefine :: Section -> DefName -> Maybe Define+lookupDefine (Section _ _ ds) dname = Map.lookup dname ds++data InvocationCmd = InvFile | InvDir | InvAbsent | InvFragment | InvSymlink+ | InvLocal UnexpandedDefName | InvImport T.Text UnexpandedDefName+ deriving (Show, Eq, Ord)++data ExpandedInvocationCmd = ExInvFile | ExInvDir | ExInvAbsent | ExInvFragment+ | ExInvSymlink | ExInvLocal DefName | ExInvImport T.Text DefName+ deriving (Show, Eq, Ord)++newtype InvocationArgs = InvocationArgs {fromInvocationArgs :: Map.Map Ident [Content]}+ deriving (Show, Eq)+data Invocation = Invocation InvocationCmd InvocationArgs+ deriving (Show, Eq)++data MCMFile = MCMFile PackagePath Section deriving Show++section :: MCMFile -> Section+section (MCMFile _ s) = s++data Section = Section [Import] (Map.Map Ident [Content]) (Map.Map DefName Define)+ deriving (Show, Eq)++imports :: Section -> [Import]+imports (Section imps _ _) = imps++newtype Group = Group T.Text deriving (Eq, Ord)+newtype Separator = Separator T.Text deriving (Eq, Ord)+newtype Prepend = Prepend T.Text deriving (Eq, Ord)+newtype Append = Append T.Text deriving (Eq, Ord)++instance Show Group where+ show (Group g) = T.unpack g+instance Show Separator where+ show (Separator s) = T.unpack s+instance Show Prepend where+ show (Prepend p) = T.unpack p+instance Show Append where+ show (Append a) = T.unpack a++data ContentLine = Plain T.Text+ | PrependNewline T.Text++data ContentType = CTSpace | CTDollar++toContent :: ContentType -> ContentLine -> Either String [Content]+toContent ct (PrependNewline s) =+ case toContent ct (Plain s) of+ Left e -> Left e+ Right cs -> Right $ CNewline : cs+toContent _ (Plain s) | T.null s = Right []+toContent ct (Plain s) =+ case ct of+ CTSpace -> return [CString s]+ CTDollar -> case T.span isAlpha s of+ (a, b) | a == T.pack "file" && T.head b == '(' -> checkEnd (\ss -> Right [CFile ss]) $ T.tail b+ (a, b) | a == T.pack "rawfile" && T.head b == '(' -> checkEnd (\ss -> Right [CRawFile ss]) $ T.tail b+ (a, b) | a == T.pack "rawstring" && T.head b == '(' -> checkEnd (\ss -> Right [CRawString ss]) $ T.tail b+ (a, b) | a == T.pack "string" && T.head b == '(' -> checkEnd (\ss -> Right [CExplicitString ss]) $ T.tail b+ (a, b) | a == T.pack "fragments" && T.head b == '(' -> checkEnd makeFragments $ T.tail b+ _ -> Left $ "Expected a valid $COMMAND but got: $" ++ T.unpack s+ where+ checkEnd f ss = if T.last ss == ')'+ then f $ T.init ss+ else Left $ "Content missing final ')'? : " ++ T.unpack ss+ makeFragments ss =+ let fargs = T.split (== ',') ss+ [g, prepend, append, sep] = fargs+ in+ if length fargs == 4+ then Right [CFragments (Group g) (Prepend prepend) (Append append) (Separator sep)]+ else Left $ "Wrong number of fragments arguments: " ++ T.unpack ss++data Content = CString T.Text -- As input+ | CExplicitString T.Text -- As input within explicit string()+ | CRawString T.Text -- String on which to perform no expansion+ | CEmpty -- Nothing+ | CNewline -- A newline+ | CFile T.Text+ | CFragments Group Prepend Append Separator+ | CRawFile T.Text+ deriving (Show, Eq)++data VarsExpand a = VarsExpand {vexpand :: Ident -> T.Text -> Maybe a+ ,vnoexpand :: T.Text -> a+ ,vcollapse :: [a] -> a+ ,vescapeexpand :: T.Text -> T.Text -> a+ }
+ PathToMCM.hs view
@@ -0,0 +1,109 @@+-- MCM - Machine Configuration Manager; manages the contents of files and directories+-- Copyright (c) 2013-2016 Anthony Doggett <mcm@interfaces.org.uk>+--+-- Licence:+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program. If not, see <http://www.gnu.org/licenses/>.++module PathToMCM (pathToMcm)+where++import qualified Data.Text.Lazy as T+import Numeric (showOct)++import FileCorrector(Path, walk, PathType(..), Permissions(..), DirType(..), ownerAsString, groupAsString)++type PT = (FilePath, PathType, Permissions)++pathToMcm :: String -> String -> Path -> ShowS+pathToMcm package define p = s . showl toMcm (walk p)+ where+ s = showString "MCM " . showString package . showString "\n\n" .+ showString "define " . showString define . showString "()\n"+ showl :: (PT -> ShowS) -> [PT] -> ShowS+ showl _ [] = id+ showl f (x:xs) = f x . showl f xs++s1 :: ShowS+s1 = showString "\t"++s2 :: ShowS+s2 = s1 . s1++s3 :: ShowS+s3 = s2 . s1++-- Like prelude's "lines", but does care whether the last line ends '\n'+linesN :: String -> [String]+linesN "" = []+linesN s = linesN' s+linesN' :: String -> [String]+linesN' "" = [""]+linesN' s = let (l, s') = break (== '\n') s+ in l : case s' of+ [] -> []+ (_:s'') -> linesN' s''++-- Append the permissions lines to the Absent/File/Directory+perms :: Permissions -> ShowS+perms (Perm mf mu mg) = f . u . g+ where+ f = case mf of+ Nothing -> id+ Just s -> showString " mode> " .+ showOct s+ u = case mu of+ Nothing -> id+ Just s -> showString " owner> " .+ (ownerAsString s ++)+ g = case mg of+ Nothing -> id+ Just s -> showString " group> " .+ (groupAsString s ++)++raw :: String -> ShowS+raw s = showString "$rawstring(" . showString s . showString ")\n"++rawcontinuations :: [String] -> ShowS+rawcontinuations [] = id+rawcontinuations (x:xs) =+ s3 . showString "+" . raw x . rawcontinuations xs++toMcm :: PT -> ShowS+toMcm (fp, Absent, perm) = showString "" .+ s1 . showString "Absent" . perms perm .+ showString " path:" . raw fp+toMcm (fp, File f, perm) =+ s1 . showString "File" . perms perm .+ showString " path:" . raw fp .+ s2 . showString "content:" . raw first .+ rawcontinuations rest+ where+ (first,rest) = case f' of+ [] -> ("",[])+ (x:xs) -> (x, xs)+ f' = linesN . T.unpack $ f+toMcm (_, Dir Implicit, _) = id+toMcm (fp, Dir dt, perm) =+ s1 . showString "Dir" . perms perm .+ showString " manage> " . showString d .+ showString " path:" . raw fp+ where+ d = case dt of+ Partial -> "partial"+ Full -> "full"+ Implicit -> error "Impossible"+toMcm (fp, Symlink sfp, perm) =+ s1 . showString "Symlink" . perms perm .+ showString " path:" . raw fp .+ s2 . showString "link:" . raw sfp
+ README.txt view
@@ -0,0 +1,11 @@+MCM - Machine Configuration Manager; manages the contents of files and directories+Copyright (c) 2013-2016 Anthony Doggett <mcm@interfaces.org.uk>+http://interfaces.org.uk/mcm++Written for Debian and friends (though as yet only really tested on Debian and+Raspbian).++MCM is designed such that it is easy for its inputs and outputs to be reviewed+and audited.++I hope you like this piece of living art.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ VarsParser.hs view
@@ -0,0 +1,62 @@+-- MCM - Machine Configuration Manager; manages the contents of files and directories+-- Copyright (c) 2013-2016 Anthony Doggett <mcm@interfaces.org.uk>+--+-- Licence:+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program. If not, see <http://www.gnu.org/licenses/>.++module VarsParser (expandString)+where++import Control.Monad(unless)+import Data.Char (isAlphaNum)+import qualified Data.Text.Lazy as T+import Text.ParserCombinators.Poly.Text++import ParserTypes (Ident(..), VarsExpand(..))++-- Perform substitution on strings like "Fifty @(pound)s of @rice"+expandString :: VarsExpand a -> T.Text -> Either String a+expandString ve t = case runParser (pSplitter ve) t of+ (Left s, _) -> Left s+ (Right e, v) -> if T.null v then Right e else Left $ "Failed to parse end: " ++ T.unpack v++isVar :: Char -> Bool+isVar c = isAlphaNum c || c `elem` "_"++doReplace :: VarsExpand a -> T.Text -> T.Text -> Parser a+doReplace ve t r = case vexpand ve (Ident t) r of+ Just s -> return s+ Nothing -> failBad $ "Failed to lookup @" ++ T.unpack t++char :: Char -> Parser ()+char c = do+ n <- next+ unless (c == n) $ fail "Failed to match char"++pSplitter :: VarsExpand a -> Parser a+pSplitter ve = vcollapse ve <$> (many . oneOf)+ [vnoexpand ve <$> many1Satisfy (/= '@')+ ,do char '@'+ oneOf+ [do v <- many1Satisfy isVar+ commit $ doReplace ve v $ T.cons '@' v+ ,do char '('+ v <- many1Satisfy isVar+ commit $ char ')' `adjustErr ` ("expected closing bracket\n"++)+ doReplace ve v $ T.concat [T.pack "@(", v, T.pack ")"]+ ,do char '@'+ commit $ return $ vescapeexpand ve (T.pack "@") (T.pack "@@")+ ]+ ]+
+ changelog view
@@ -0,0 +1,9 @@+[0.6.4.10] 2016-06-28+ - improve "mcm --help" output+ - fix why-can-immediate-locals-not-have-underscores bug+ - fix "let =" parsing oddity+ - slightly simplify compiled mcm output+ - spelling and punctuation fixes+[0.6.4.9] 2016-06-25+ - add one further parseerrortest+ - fix long-contents-with-some-$fragments-are-slow bug
+ commands2html.1 view
@@ -0,0 +1,61 @@+.TH COMMANDS2HTML "1" "January 2016" "commands2html" "User Commands"+.SH NAME+commands2html \- simple command interpreter that outputs HTML+.SH SYNOPSIS+.B commands2html+[\fIOPTION\fR..]+\fIFILE\fR+[\fIOPTION\fR..]+.SH DESCRIPTION+.PP+Execute the commands listed in given .commands file and output to a .html_snippet file, in a format that appears that the commands were run at a sh prompt.+.PP+The commands are executed with the current directory set to the directory containing the input .commands file.+.PP+The generated HTML snippet is a PRE block, intended for inclusion in an HTML page.+Use of the options can output other bits of relevant HTML.+.PP+The generated .html_snippet (or .html, depending on options used) file is overwritten if it already exists.+.TP+FILE+input file listing the commands to be executed.+.SH OPTIONS+.TP+\fB\-V\fR, \fB\-\-version\fR+show version+.TP+\fB\-\-head\fR+output (to stdout) the suggested snippet for within <head>+.TP+\fB\-\-css\fR+output (to stdout) the suggested snippet for within an included CSS file+.TP+\fB\-\-fullpage\fR+write a full .html page (instead of .html_snippet)++.SH EXIT STATUS+.TP+0+if OK,+.TP+1+when errors are encountered.++.SH FILES+None but that given on the command line and the same but with either .html or .html_snippet appended.+.SH EXAMPLES+Run the commands listed in myscript.commands (output is written to myscript.commands.html_snippet):+.IP+commands2html myscript.commands+.PP+Run the commands listed in all .commands files below the current directory, writing the results out as full html pages ready for viewing in a web browser (each output is written to FILE.html):+.IP+find . -name '*.commands' -type f -exec commands2html --fullpage '{}' ';'+.SH AUTHOR+Written by Anthony Doggett <mcm@interfaces.org.uk>+.SH REPORTING BUGS+Please email the author at the above address, preferably with sufficient information to reproduce the bug.+.SH COPYRIGHT+Copyright (c) 2015-2016 Anthony Doggett+.PP+<http://interfaces.org.uk/mcm>
+ commands2html.hs view
@@ -0,0 +1,295 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- MCM - Machine Configuration Manager; manages the contents of files and directories+-- Copyright (c) 2013-2016 Anthony Doggett <mcm@interfaces.org.uk>+--+-- Licence:+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program. If not, see <http://www.gnu.org/licenses/>.++-- Reads the list of commands+-- then runs them one at a time+-- and converts the output to an HTML snippet+-- NB. Based on mcm2html.hs++module Main (main)+where++import Paths_mcm (version)++import Control.Monad(when, unless)+import qualified Data.ByteString.Lazy as B+import Data.Char (isDigit)+import Data.List (foldl')+import Data.String (fromString)+import qualified Data.Text.Lazy as T+import Data.Version (showVersion)+import System.Console.GetOpt+import System.Directory (getCurrentDirectory, setCurrentDirectory)+import System.Environment (getArgs)+import System.Exit (ExitCode(..), exitSuccess, exitFailure)+import System.FilePath (takeDirectory)+import System.Process (readProcessWithExitCode)+import qualified Text.Blaze.Html5 as H5+import Text.Blaze.Html5 (ToMarkup, toHtml)+import Text.Blaze.Html5.Attributes (class_, type_, charset)+import qualified Text.Blaze.Html.Renderer.Utf8 as Render_Utf8+import qualified Text.Blaze.Html.Renderer.String as Render_String+import Text.ParserCombinators.Poly.Plain++usage :: String+usage = unlines ["Usage: commands2html [OPTION..] FILE [OPTION..]"+ ,"Create .commands.html_snippet from the given .commands"+ ]++main :: IO ()+main = do+ progargs <- getArgs+ let (actions, nonOpts, msgs) = getOpt Permute options progargs+ unless (null msgs) $ error $ concat msgs ++ usageInfo usage options+ opts <- foldl' (>>=) (return defaultOptions) actions+ let Options {optOutFilenameExtension = extension+ ,optOutputWrapper = wrapper+ } = opts+ infilename <- case nonOpts of+ [i] -> return i+ xs -> do+ putStrLn $ "Error: expected a single .commands filename but received: " ++ show xs+ exitFailure+ when (extension == "") $ error "Extension can't be empty!"+ let outfilename = infilename ++ extension+ infiledir = takeDirectory infilename+ putStrLn $ "Writing " ++ outfilename+ cmds <- commandsLoadAndParse infilename+ cdir <- getCurrentDirectory+ setCurrentDirectory infiledir+ r <- mapM runCommand cmds+ setCurrentDirectory cdir+ B.writeFile outfilename $ Render_Utf8.renderHtml . wrapper $ do+ H5.pre H5.! class_ (fromString "C2H") $ mapM_ toHtml r+ newline++isComment :: String -> Bool+isComment "" = False+isComment ('#':_) = True+isComment _ = False++commandsLoadAndParse :: FilePath -> IO [String]+commandsLoadAndParse fp = do+ s <- readFile fp+ return $ filter (not . isComment) $ lines s++newtype CmdResult = CmdResult (String, ExitCode, String, String)++runCommand :: String -> IO CmdResult+runCommand cmd = do+ (exitcode, out, err) <- readProcessWithExitCode "/bin/sh" ["-c", cmd] ""+ return $ CmdResult (cmd, exitcode, out, err)++instance ToMarkup CmdResult where+ toMarkup (CmdResult (cmd, exitcode, out, err)) = do+ colourwith Prompt $ text "> "+ text cmd+ newline+ parseAndToHtml out+ parseAndToHtml err+ toHtml exitcode++instance ToMarkup ExitCode where+ toMarkup ExitSuccess = text ""+ toMarkup (ExitFailure f) = colourwith BadExit $ do+ text "Exit failure: "+ text . show $ f+ newline++parseAndToHtml :: String -> H5.Html+parseAndToHtml = c . collapseNested . colourstring2nested . parse+ where+ c [] = text ""+ c (x:xs) = do+ toHtml x+ c xs++data Options = Options+ {optOutFilenameExtension :: String+ ,optOutputWrapper :: H5.Html -> H5.Html+ }++defaultOptions :: Options+defaultOptions = Options+ {optOutFilenameExtension = ".html_snippet"+ ,optOutputWrapper = id+ }++options :: [OptDescr (Options -> IO Options)]+options = [Option "V" ["version"] (NoArg displayVersion) "show version and exit"+ ,Option [] ["head"] (NoArg headOpt) "output (to stdout) the suggested snippet for within <head> and exit"+ ,Option [] ["css"] (NoArg cssOpt) "output (to stdout) the suggested snippet for within an included CSS file and exit"+ ,Option [] ["fullpage"] (NoArg fullpageOpt) "write a full .html page (instead of .html_snippet)"+ ,Option "h" ["help"] (NoArg justHelp) "show this help and exit"+ ]++displayVersion :: Options -> IO Options+displayVersion _ = do+ putStrLn $ "commands2html " ++ showVersion version+ exitSuccess++justHelp :: Options -> IO Options+justHelp _ = do+ putStrLn $ usageInfo usage options+ exitSuccess++headOpt :: Options -> IO Options+headOpt _ = do+ putStrLn . Render_String.renderHtml $ suggestedHead+ exitSuccess++suggestedHead :: H5.Html+suggestedHead = H5.meta H5.! charset (fromString "utf-8")++cssOpt :: Options -> IO Options+cssOpt _ = do+ putStrLn . Render_String.renderHtml $ suggestedCss+ exitSuccess++-- NB. Valid colours: http://www.w3.org/TR/CSS21/syndata.html#color-units+suggestedCss :: H5.Html+suggestedCss = text $ unlines+ ["pre.C2H {white-space: pre-wrap; tab-size: 4;-moz-tab-size: 4}"+ ,"pre.C2H .BadExit {font-weight: bold;color: red;background-color: white}"+ ,"pre.C2H .Prompt {font-weight: bold}"+ ,"pre.C2H .GM1 {font-weight: bold}"+ ,"pre.C2H .GM30 {color: black}" -- black+ ,"pre.C2H .GM31 {color: red}" -- red+ ,"pre.C2H .GM32 {color: green}" -- green4+ ,"pre.C2H .GM33 {color: yellow}" -- yellow+ ,"pre.C2H .GM34 {color: blue}" -- blue+ ,"pre.C2H .GM35 {color: fuchsia}" -- magenta+ ,"pre.C2H .GM36 {color: aqua}" -- cyan4+ ,"pre.C2H .GM37 {color: white}" -- white+ ,"pre.C2H .GM40 {background-color: black}" -- black+ ,"pre.C2H .GM41 {background-color: red}" -- red+ ,"pre.C2H .GM42 {background-color: green}" -- green4+ ,"pre.C2H .GM43 {background-color: yellow}" -- yellow+ ,"pre.C2H .GM44 {background-color: blue}" -- blue+ ,"pre.C2H .GM45 {background-color: fuchsia}" -- magenta+ ,"pre.C2H .GM46 {background-color: aqua}" -- cyan4+ ,"pre.C2H .GM47 {background-color: white}" -- white+ ]++fullpageOpt :: Options -> IO Options+fullpageOpt opts = return opts {optOutFilenameExtension = ".html"+ ,optOutputWrapper = fullPage+ }++fullPage :: H5.Html -> H5.Html+fullPage content = H5.docTypeHtml $ do+ H5.head $ do+ suggestedHead+ newline+ H5.style H5.! type_ (fromString "text/css") $ suggestedCss+ newline+ H5.body content+ newline++text :: String -> H5.Html+text = H5.toHtml . T.pack++newline :: H5.Html+newline = text "\n"++data ColourType = BadExit | Prompt+ deriving Show++colourwith :: ColourType -> H5.Html -> H5.Html+colourwith c h = H5.span H5.! class_ (fromString . show $ c) $ h++type P = Parser Char++data ColourString = Plain String+ | GraphicsMode Int++data NestedColourString = NPlain String+ | NGraphicsMode [Int] [NestedColourString]++instance ToMarkup NestedColourString where+ toMarkup (NPlain s) = text s+ toMarkup (NGraphicsMode ns cs) = H5.span H5.! class_ cl $ mapM_ toHtml cs+ where+ cl = fromString $ unwords $ map (\n -> "GM" ++ show n) ns++manySatisfy :: (Char -> Bool) -> P String+manySatisfy p = many (satisfy p)++many1Satisfy :: (Char -> Bool) -> P String+many1Satisfy p = many1 (satisfy p)++char :: Char -> P ()+char c = do+ n <- next+ unless (c == n) $ fail $ "Unexpected char: " ++ show n+--+-- Parse (a small subset of) ANSI Escape sequences+-- See http://ascii-table.com/ansi-escape-sequences.php+-- and http://hackage.haskell.org/package/ansi-terminal+-- and http://stackoverflow.com/questions/4842424/list-of-ansi-color-escape-sequences+-- and http://wiki.bash-hackers.org/scripting/terminalcodes+parse :: String -> [ColourString]+parse s = case runParser (many pBit) s of+ (Left e, _) -> error e+ (Right ps, []) -> concat ps+ (_, v) -> error $ "Failed to parse end: " ++ v++pBit :: P [ColourString]+pBit = oneOf+ [do+ char '\ESC'+ char '['+ as <- sepBy pNum (char ';')+ char 'm'+ return $ map GraphicsMode as+ ,do+ c <- next+ cs <- pManyUntilEsc+ return [Plain (c:cs)]+ ]++pManyUntilEsc :: P String+pManyUntilEsc = manySatisfy (/= '\ESC')++pNum :: P Int+pNum = do+ ds <- many1Satisfy isDigit+ return $ read ds++colourstring2nested :: [ColourString] -> [NestedColourString]+colourstring2nested [] = []+colourstring2nested xs =+ case colourstring2nested' xs of+ (r, []) -> r+ (r, xs') -> r ++ colourstring2nested xs'+ where+ colourstring2nested' :: [ColourString] -> ([NestedColourString], [ColourString])+ colourstring2nested' [] = ([], [])+ colourstring2nested' (Plain s : cs) = (NPlain s : cs', r)+ where+ (cs', r) = colourstring2nested' cs+ colourstring2nested' (GraphicsMode 0 : cs) = ([], cs)+ colourstring2nested' (GraphicsMode n : cs) = ([NGraphicsMode [n] cs'], r)+ where+ (cs', r) = colourstring2nested' cs++-- Items are commonly bold + fg, so spot these and permit easy conversion to class="bold + fg"+collapseNested :: [NestedColourString] -> [NestedColourString]+collapseNested [] = []+collapseNested (NGraphicsMode a [NGraphicsMode b bs]:ns) = collapseNested (NGraphicsMode (a++b) bs : ns)+collapseNested (n:ns) = n:collapseNested ns
+ copyright view
@@ -0,0 +1,19 @@+MCM - Machine Configuration Manager; manages the contents of files and directories+Copyright (c) 2013-2016 Anthony Doggett <mcm@interfaces.org.uk>++Licence:+ This program is free software: you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation, either version 3 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program. If not, see <http://www.gnu.org/licenses/>.++The complete text of the GNU General Public License can be found in the file+LICENCE in the source distribution.
+ mcm.1 view
@@ -0,0 +1,141 @@+.TH MCM "1" "January 2016" "mcm" "User Commands"+.SH NAME+mcm \- Machine Configuration Manager+.SH SYNOPSIS+.B mcm+[\fIOPTION\fR..]+[\fISTARTINGPOINT\fR..]+[\fIOPTION\fR..]+.SH DESCRIPTION+.PP+Configure the specified files and directories+(both file/directory contents and permissions).+Changes to be made (if any) are displayed before they are enacted.+.PP+Machine Configuration Manager can be used to maintain directories,+configuration files and to build scripts in a declarative way.+MCM is designed such that it is easy for its inputs and outputs to be reviewed and audited.+.TP+STARTINGPOINT+starting point (default = "Go.<lowercase_hostname>").+The starting point may be provided partially. E.g. ".blue" would result in the+starting point "Go.blue" being used; similarly "MyUserConfigs." would result in+"MyUserConfigs.<lowercase_hostname>" being used.+Multiple starting points may be provided, though it only really makes sense to+provide multiple starting points together with the options+\fB\-\-parse\-only\fR or \fB\-\-compile-to\fR.+.SH OPTIONS+.TP+\fB\-V\fR, \fB\-\-version\fR+show version+.TP+\fB\-P\fR \fIPATH\fR, \fB\-\-config\-path\fR=\fIPATH\fR+colon\-separated list of directories holding configs (default = ".")+.TP+\fB\-r\fR \fIDIRECTORY\fR, \fB\-\-root\fR=\fIDIRECTORY\fR+path to manage (default = "./build")+.TP+\fB\-f\fR \fIno\fR|\fIprompt\fR|\fIifnew\fR|\fIyes\fR|\fIpromptunlessonlyadditions\fR, \fB\-\-fix\fR=\fIno\fR|\fIprompt\fR|\fIifnew\fR|\fIyes\fR|\fIpromptunlessonlyadditions\fR+whether to enact the changes (default = \fIprompt\fR).+\fIno\fR and \fIyes\fR result in the changes being only displayed or unconditionally enacted respectively.+\fIifnew\fR causes the changes to be made if the root directory does not exist.+\fIprompt\fR asks the user whether to enact the changes,+\fIpromptunlessonlyadditions\fR automatically enacts the changes if the changes would only result in the addition of new files and/or directories, otherwise prompts the user.+.TP+\fB\-d\fR, \fB\-\-diff\fR+display differences (requires 'diff')+.TP+\fB\-\-parse\-only\fR+parse configuration(s) only+.TP+\fB\-c\fR \fIDIRECTORY\fR, \fB\-\-compile\-to\fR=\fIDIRECTORY\fR+compile (each provided starting point) to a single (but separate) file.+Compiled files can then, for example, be sent to destination hosts for implementation.+.TP+\fB\-\-stdin\fR+read (initial) config from stdin+.TP+\fB\-\-error\-on\-leftover\-fragments\fR+complain if there are fragments without corresponding files++.SH EXIT STATUS+.TP+0+if OK,+.TP+1+when errors are encountered in either reading the config files or implementing+the changes,+.TP+2+if \fB--fix\fR=\fIifnew\fR but the root path to manage already exists,+.TP+3+if \fB--fix\fR=\fIprompt\fR or \fB--fix\fR=\fIpromptunlessonlyadditions\fR and the changes are not enacted (e.g. "N" is entered).+.SH NOTES+The use of aliases/functions (e.g. in ~/.bashrc) is recommended for frequently used invocations.+For example:+.IP+alias mcmroot='sudo mcm -r / -P ~/mcm'+.br+alias mcmhome='mcm -r / -P ~/mcm MyUserConfigs.'+.PP+Or if using the grc colouriser:+.IP+alias mcmroot='grc sudo mcm -r / -P ~/mcm'+.br+alias mcmhome='grc mcm -r / -P ~/mcm MyUserConfigs.'+.PP+You might also like to create an alias along the lines of the following,+where mcmuserscripts and mcmrootscripts run any Machine Configuration Manager-generated scripts:+.IP+alias mcmall='mcmuser && mcmuserscripts; mcmroot && mcmrootscripts'+.PP+.SH FILES+None but those within directories specified with \fB\-\-config\-path\fR.+.SH ENVIRONMENT+.TP+\fIPATH\fR+$PATH can be altered to change the version of diff invoked when the \fB-d\fR, \fB--diff\fR option is provided.+.SH EXAMPLES+Starting with the define "mystart" in the file "Go.mcm" in the current+directory (with the MCM Package of "Go"),+show what changes would be made to+the root ./build and then prompt whether to enact them:+.IP+mcm .mystart+.PP+Starting with the define "<lowercase_hostname>" in the file "MyUserConfigs.mcm" in+the current directory (with the MCM Package of "MyUserConfigs"),+show what changes would be made to the root ~/ and then prompt whether to enact+them:+.IP+mcm -r ~/ MyUserConfigs.+.PP+Test a long list of starting points (e.g. that a change made for one of them has not broken any others):+.IP+mcm --parse-only --error-on-leftover-fragments .oak .beech .birch .maple \\+ MyUserConfigs.oak MyUserConfigs.beech MyUserConfigs.birch MyUserConfigs.maple \\+ LiveCD.basic LiveCD.X11 LiveCD.friends \\+ DebianInstaller.basic DebianInstaller.home DebianInstaller.work DebianInstaller.friends \\+ Deb.basic Deb.mypackage \\+ Website.main Website.photos \\+ RaspberryInstallation.simple RaspberryInstallation.maple RaspberryInstallation.demo+.PP+Compile the starting points (Go).maple and MyUserConfigs.maple to single files.+The single files can then, for example, be copied to the destination host for+implementation, or compared to other compiled files.+.IP+grc mcm -d -r / -c compiled/ .maple MyUserConfigs.maple++.SH AUTHOR+Written by Anthony Doggett <mcm@interfaces.org.uk>+.SH REPORTING BUGS+Please email the author at the above address, preferably with sufficient information to reproduce the bug.+.SH COPYRIGHT+Copyright (c) 2014-2016 Anthony Doggett+.PP+<http://interfaces.org.uk/mcm>+.SH SEE ALSO+mcm2html(1),+mcmtags(1)
+ mcm.cabal view
@@ -0,0 +1,54 @@+name: mcm+version: 0.6.4.10+synopsis: Machine Configuration Manager+description:+ Machine Configuration Manager (MCM) manages the contents of files and+ directories. One or more of those files can be a script, enabling MCM to+ control anything. Typically MCM is used to manage the configurations of user+ profiles, machines, systems and systems of systems.+ * The declarative language is simple and easy on the eye yet very powerful.+ * MCM is simple, fast and transparent.+license: GPL-3+license-file: LICENCE+author: Anthony Doggett <mcm@interfaces.org.uk>+maintainer: Anthony Doggett <mcm@interfaces.org.uk>+copyright: (c) 2013-2016 Anthony Doggett+homepage: http://interfaces.org.uk/mcm+category: Language, System, Text+stability: alpha+build-type: Simple+cabal-version: >=1.9.2+extra-source-files: README.txt changelog copyright mcm.vim mcmtestfiles.tgz commands2html.1 mcm.1 mcm2html.1 mcmtags.1++Executable commands2html+ main-is: commands2html.hs+ other-modules: + build-depends: base >=4.5 && <5, blaze-html >=0.7, bytestring >=0.9, containers >=0.4, directory >=1.1, filepath >=1.3, polyparse >=1.7, process >=1.1, text >=0.11+ hs-source-dirs: .+ ghc-options: -Wall -fwarn-tabs+ build-tools: ++Executable mcm+ main-is: mcm.hs+ other-modules: Action, Parser, ParserTypes, VarsParser, FileCorrector, Interpret, InterpretState, PathToMCM+ build-depends: MissingH >=1.1, base >=4.5 && <5, containers >=0.4, directory >=1.1, filepath >=1.3, hostname >=1.0, polyparse >=1.7, process >=1.1, text >=0.11, unix >=2.5+ hs-source-dirs: .+ ghc-options: -Wall -fwarn-tabs+ build-tools: ++Executable mcm2html+ main-is: mcm2html.hs+ other-modules: Parser, ParserTypes+ build-depends: base >=4.5 && <5, blaze-html >=0.7, bytestring >=0.9, containers >=0.4, filepath >=1.3, polyparse >=1.7, text >=0.11+ hs-source-dirs: .+ ghc-options: -Wall -fwarn-tabs+ build-tools: ++Executable mcmtags+ main-is: mcmtags.hs+ other-modules: Parser, ParserTypes, Interpret, InterpretState+ build-depends: base >=4.5 && <5, containers >=0.4, directory >=1.1, filepath >=1.3, polyparse >=1.7, text >=0.11, unix >=2.5+ hs-source-dirs: .+ ghc-options: -Wall -fwarn-tabs+ build-tools: +
+ mcm.hs view
@@ -0,0 +1,275 @@+-- MCM - Machine Configuration Manager; manages the contents of files and directories+-- Copyright (c) 2013-2016 Anthony Doggett <mcm@interfaces.org.uk>+--+-- Licence:+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program. If not, see <http://www.gnu.org/licenses/>.+module Main (main)+where++import Action (Action, displayActions, runActions)+import FileCorrector(ChangesSummary(..), correctAll, CompFun, diffCompare, simpleCompare, Path, theRootDir, emptyPermissions, PathType(..), addPath, mergePaths)+import Parser (mcmParsePackagePath)+import ParserTypes (PackagePath(..), Group, DefName(..), packagePath)+import InterpretState (initState, SearchPath(..), Args(..), State, getCache, setCache)+import Interpret (run, fullyLoadSectionFromHandle)+import PathToMCM (pathToMcm)+import Paths_mcm (version)++import Control.Monad(when, unless, foldM)+import Data.List (foldl')+import qualified Data.Map as Map+import qualified Data.Text.Lazy as T+import Data.Version (showVersion)+import Network.HostName (getHostName)+import System.Environment (getArgs)+import System.Console.GetOpt+import System.Directory (getCurrentDirectory, doesDirectoryExist)+import System.Exit (exitSuccess, exitFailure, exitWith, ExitCode(..))+import System.FilePath (normalise, dropTrailingPathSeparator, combine)+import System.IO.PlafCompat (nullFileName)+import System.Posix.User (getAllUserEntries, getAllGroupEntries)+import System.IO (stdin, stdout, hFlush)+import System.IO.Unsafe (unsafeInterleaveIO)++usage :: String+usage = unlines ["Usage: mcm [OPTION..] [STARTINGPOINT..] [OPTION..]"+ ,"Configure the specified files and directories"+ ,"(both file/directory contents and permissions)."+ ,"Changes to be made (if any) are displayed before they are enacted."+ ,""+ ,"STARTINGPOINT\tstarting point (default = \"Go.<lowercase_hostname>\")."+ ,"FIXTYPE\t\tno|prompt|ifnew|yes|promptunlessonlyadditions"+ ]++main :: IO ()+main = do+ progargs <- getArgs+ let (actions, nonOpts, msgs) = getOpt Permute options progargs+ unless (null msgs) $ error $ concat msgs ++ usageInfo usage options+ opts <- foldl' (>>=) (return defaultOptions) actions+ hostname <- unsafeInterleaveIO getHostName+ let go = PackagePath [T.pack "Go"]+ let lhostname = T.toLower . T.pack $ hostname+ let startingpoints@((pp0, _):_) = reverse $+ case parseNonOpts (go, DefName lhostname) [] nonOpts of+ [] -> [(go, DefName lhostname)]+ xs -> xs+ let Options {optRoot = root+ ,optConfigPath = configpath+ ,optEnactChanges = enactchanges+ ,optLeftoverChecker = leftoverchecker+ ,optLoadInitialConfig = loadinitialconfig+ ,optComparisonFunction = compfun+ ,optCorrectFunction = correctfun+ ,optCompileToFunction = compilefun+ ,optCollatePaths = collatePaths+ ,optDisplayOGWarnings = displayOGwarnings+ } = opts+ sp <- configpath+ us <- getAllUserEntries+ gs <- getAllGroupEntries+ s0 <- loadinitialconfig pp0 $ initState us gs sp root+ let correctDisplayEnact p = do+ (csummary, as) <- correctfun compfun p+ displayActions as+ enactchanges csummary as+ (_, combinedPath, enactResults) <- foldM (\(c, cumulativePaths, enactResults) (pp, d) -> do+ when (length startingpoints > 1) $+ putStrLn $ "== " ++ show pp ++ "." ++ show d ++ " =="+ ((errors, ogwarnings, path, leftoverFragments), s1) <-+ run (setCache s0 c) (pp, d, Args Map.empty)+ displayOGwarnings ogwarnings+ mapM_ print errors+ leftoverchecker leftoverFragments+ let path' = compilefun pp d path+ unless (null errors) exitFailure+ er <- if collatePaths then return AsExpected else correctDisplayEnact path'+ return (getCache s1, cumulativePaths `mergePaths` path', er:enactResults)+ ) (getCache s0, theRootDir, []) startingpoints+ er <- if collatePaths then correctDisplayEnact combinedPath else return AsExpected+ unless (all (== AsExpected) (er:enactResults)) $ exitWith $ ExitFailure 3++parseNonOpts :: (PackagePath, DefName) -> [(PackagePath, DefName)] -> [String] -> [(PackagePath, DefName)]+parseNonOpts _ ys [] = ys+parseNonOpts _ _ ("":_) = error "'' is an invalid starting point"+parseNonOpts defaults@(go, lhostname) ys (x:xs) =+ let parsepp p = case mcmParsePackagePath (T.pack p) of+ Right a -> a+ Left _ -> error $ "Bad package name: " ++ show p+ y = case break (== '.') (reverse x) of+ (_, []) -> error $ "ERROR: Starting point '"++ x ++ "' is not of the format PACKAGE.DEFINE"+ ([], ".") -> (go, lhostname)+ (revdefine, ".") -> (go, (DefName . T.pack . reverse) revdefine)+ ([], '.':revpackage) -> (parsepp (reverse revpackage), lhostname)+ (revdefine, '.':revpackage) -> (parsepp (reverse revpackage), (DefName . T.pack . reverse) revdefine)+ _ -> error $ "ERROR: Impossible starting point: " ++ show x++ in+ parseNonOpts defaults (y:ys) xs++data EnactResult = AsExpected | UserCancelled+ deriving (Show, Eq)++data Options = Options+ {optRoot :: String+ ,optConfigPath :: IO SearchPath+ ,optEnactChanges :: ChangesSummary -> [Action] -> IO EnactResult+ ,optLeftoverChecker :: [(PackagePath, Group)] -> IO ()+ ,optLoadInitialConfig :: PackagePath -> State -> IO State+ ,optComparisonFunction :: CompFun+ ,optCorrectFunction :: CompFun -> Path -> IO (ChangesSummary, [Action])+ ,optCompileToFunction :: PackagePath -> DefName -> Path -> Path+ ,optCollatePaths :: Bool+ ,optDisplayOGWarnings :: [String] -> IO ()+ }++defaultOptions :: Options+defaultOptions = Options+ {optRoot = "./build"+ ,optConfigPath = do {d <- getCurrentDirectory; return $ SearchPath [d]}+ ,optEnactChanges = const prompt+ ,optLeftoverChecker = warnIfAny+ ,optLoadInitialConfig = \_ s0 -> return s0+ ,optComparisonFunction = simpleCompare+ ,optCorrectFunction = correctAll+ ,optCompileToFunction = \_ _ p -> p+ ,optCollatePaths = False+ ,optDisplayOGWarnings = mapM_ putStrLn+ }++options :: [OptDescr (Options -> IO Options)]+options = [Option "V" ["version"] (NoArg displayVersion) "show version and exit"+ ,Option "P" ["config-path"] (ReqArg setPath "PATH") "colon-separated list of directories holding configs (default = \".\")"+ ,Option "r" ["root"] (ReqArg setRoot "DIRECTORY") "path to manage (default = \"./build\")"+ ,Option [] ["error-on-leftover-fragments"] (NoArg errorOnLeftoverFragments) "complain if there are fragments without corresponding files"+ ,Option "f" ["fix"] (ReqArg chooseFix "FIXTYPE") "whether to enact the changes (default=\"prompt\")"+ ,Option "d" ["diff"] (NoArg useDiff) "display differences (requires 'diff')"+ ,Option [] ["parse-only"] (NoArg parseOnly) "parse configuration only"+ ,Option "c" ["compile-to"] (ReqArg compileTo "DIRECTORY") "compile to a single MCM file"+ ,Option [] ["stdin"] (NoArg readStdin) "read (initial) config from stdin"+ ,Option "h" ["help"] (NoArg justHelp) "show this help and exit"+ ]++setRoot :: FilePath -> Options -> IO Options+setRoot r opt = return opt {optRoot = r}++readStdin :: Options -> IO Options+readStdin opt = return opt {optLoadInitialConfig = fullyLoadSectionFromHandle "<stdin>" stdin}++useDiff :: Options -> IO Options+useDiff opt = return opt {optComparisonFunction = diffCompare}++parseOnly :: Options -> IO Options+parseOnly opt = return opt {optCorrectFunction = \_ p -> writeToNull p+ ,optDisplayOGWarnings = \_ -> return ()+ }+ where+ writeToNull path = do+ writeFile nullFileName (pathToMcm "ParseOnly" "parseonly" path "")+ return (SomeItemsChangedOrRemoved, [])++compileTo :: FilePath -> Options -> IO Options+compileTo fp opt = return opt {optCompileToFunction = p2m+ ,optCollatePaths = True+ ,optDisplayOGWarnings = \_ -> return ()+ }+ where+ p2m (PackagePath pp) d@(DefName d') path =+ let content = T.pack $ pathToMcm (show pp') (show d) path ""+ pp' = PackagePath $ appendD pp+ appendD [] = []+ appendD [x] = [x `T.append` T.cons '_' d']+ appendD (x:xs) = x : appendD xs+ filename = combine fp' (packagePath pp')+ fp' = dropTrailingPathSeparator $ normalise fp+ compiledPath = addPath theRootDir filename (File content) emptyPermissions "(compiled)"+ in case compiledPath of+ Left s -> error s+ Right p -> p++setPath :: String -> Options -> IO Options+setPath p opt = return opt {optConfigPath = return $ SearchPath (extractPath p)}++-- Change ".:/etc/mcm" to [".", "/etc/mcm"]+extractPath :: String -> [FilePath]+extractPath "" = []+extractPath p = let (l, p') = break (== ':') p+ in l : case p' of+ [] -> []+ (_:p'') -> extractPath p''++doFix :: [Action] -> IO EnactResult+doFix [] = return AsExpected+doFix as = do+ putStrLn "Enacting..."+ runActions as+ return AsExpected++chooseFix :: String -> Options -> IO Options+chooseFix "no" opt = return opt {optEnactChanges = \_ _ -> return AsExpected}+chooseFix "yes" opt = return opt {optEnactChanges = const doFix}+chooseFix "ifnew" opt = return opt {optEnactChanges = \_ as -> do+ exists <- doesDirectoryExist (optRoot opt)+ if exists+ then exitWith $ ExitFailure 2+ else doFix as+ }+chooseFix "prompt" opt = return opt {optEnactChanges = const prompt}+chooseFix "promptunlessonlyadditions" opt = return opt {optEnactChanges = promptunlessonlyadditions}+chooseFix f _ = error ("Unrecognised fix method: " ++ f ++"\n" ++ usageInfo usage options)++prompt :: [Action] -> IO EnactResult+prompt [] = return AsExpected+prompt as = do+ putStrLn "Enact changes? (Y/N)"+ hFlush stdout+ r <- getLine+ if r `elem` ["Y", "y"]+ then doFix as+ else putStrLn "Not correcting." >> return UserCancelled++promptunlessonlyadditions :: ChangesSummary -> [Action] -> IO EnactResult+promptunlessonlyadditions OnlyNewItems = doFix+promptunlessonlyadditions SomeItemsChangedOrRemoved = prompt++errorOnLeftoverFragments :: Options -> IO Options+errorOnLeftoverFragments opt = return opt {optLeftoverChecker = errorIfAny}++warnIfAny :: [(PackagePath, Group)] -> IO ()+warnIfAny [] = return ()+warnIfAny fs = do+ putStr "Warning: "+ ifany fs++errorIfAny :: [(PackagePath, Group)] -> IO ()+errorIfAny [] = return ()+errorIfAny fs = do+ putStr "Error: "+ ifany fs+ exitFailure++ifany :: [(PackagePath, Group)] -> IO ()+ifany fs = do+ putStrLn "Leftover fragments:"+ mapM_ print fs++displayVersion :: Options -> IO Options+displayVersion _ = do+ putStrLn $ "mcm " ++ showVersion version+ exitSuccess++justHelp :: Options -> IO Options+justHelp _ = do+ putStrLn $ usageInfo usage options+ exitSuccess
+ mcm.vim view
@@ -0,0 +1,132 @@+" Language: mcm+" Maintainer: Anthony Doggett (MCM@interfaces.org.uk)+"+" MCM - Machine Configuration Manager; manages the contents of files and directories+" Copyright (c) 2013-2016 Anthony Doggett <mcm@interfaces.org.uk>+"+" Licence:+" This program is free software: you can redistribute it and/or modify+" it under the terms of the GNU General Public License as published by+" the Free Software Foundation, either version 3 of the License, or+" (at your option) any later version.+"+" This program is distributed in the hope that it will be useful,+" but WITHOUT ANY WARRANTY; without even the implied warranty of+" MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+" GNU General Public License for more details.+"+" You should have received a copy of the GNU General Public License+" along with this program. If not, see <http://www.gnu.org/licenses/>.+"+" Installation Instructions:+"+" 1) Place this file in $HOME/.vim/syntax/+"+" 2) Create the file $HOME/.vim/filetype.vim if it does not already exist.+" Insert the following:+"+" " My filetype file+" if exists("did_load_filetypes")+" finish+" endif+" augroup filetypedetect+" au! BufRead,BufNewFile *.mcm setfiletype mcm+" augroup END+++" For version 5.x: Clear all syntax items+" For version 6.x: Quit when a syntax file was already loaded+if version < 600+ syntax clear+elseif exists("b:current_syntax")+ finish+endif++" All patterns match one-line only+syn sync minlines=1 maxlines=1++syn match tagError "^\t*\zs[ ]\+"+syn match tagComment "^[ ]*#.*"+syn match tagDoubleAt "@@"+syn match tagDoubleAt "@@" contained+syn match tagCase "^\t\(case [a-z][A-Za-z0-9_]*\|when .\+\)$"+syn match tagDefine "^define "+syn match tagMCM "^MCM "+syn match tagImport "^import "+syn match tagBuiltin "^\t\(File\|Fragment\|Absent\|Symlink\|Dir\)\ze\($\| \)" contained+syn match tagLocalDef "^\t\.[a-z@][A-Za-z0-9_@]*\ze\($\| \)" contained+syn match tagImportedDef "^\t[A-Z][A-Za-z0-9_]*\.[a-z@][A-Za-z0-9_@]*\ze\($\| \)" contained+syn match tagContaVar "@[0-9a-zA-Z_]\+" contained+syn match tagContaVar "@([0-9a-zA-Z_]\+)" contained+syn match tagVariable "@[0-9a-zA-Z_]\+"+syn match tagVariable "@([0-9a-zA-Z_]\+)"+" The following line doesn't work right. It's as though every line needs+" a space in it for a match to work.+syn match tagVariable "^\(\t\)\?let\( \|$\)"+syn match tagVariable "^\(\t\)\?let [0-9a-zA-Z_]\+ =\( \|$\)"+syn match tagVariable "^\(\t\)\?let [0-9a-zA-Z_]\+ =\ze\$.*" contains=tagCommandGroup+syn match tagVariable "^\t\t[0-9a-zA-Z_]\+ =\( \|$\)"+syn match tagVariable "^\t\t[0-9a-zA-Z_]\+ =\ze\$.*" contains=tagCommandGroup+syn match tagVariable "^\t\t\t[0-9a-zA-Z_]\+ =\( \|$\)"+syn match tagVariable "^\t\t\t[0-9a-zA-Z_]\+ =\ze\$.*" contains=tagCommandGroup+" See vim's help for "syn-define" :)+" And ":h pattern"+syn match tagInLine "^\t\t[a-z][a-z0-9A-Z_]*[:>]\([$ ].*\|$\)" contains=tagInlineArg,tagContaVar,tagDoubleAt+syn match tagInLine "^\t\t\t[+\\]\($\|[$ ].*\)" contains=tagContinuation,tagContaVar,tagDoubleAt+syn match tagContinuation "^\t\t\t[+\\]\($\| \).*" contained+syn match tagContinuation "^\t\t\t[+\\]\zs\$.*" contained contains=tagCommandGroup+syn match tagCommandGroup "\$\<\(fragments\|rawfile\|rawstring\|file\|string\)(.*)$" contained contains=tagCommand+syn match tagWordCommandGroup "\$\<\(fragments\|rawfile\|rawstring\|file\|string\)(\S*)" contained contains=tagCommand+syn match tagCommand "\$\<\(fragments\|rawfile\|rawstring\|file\|string\)(" contained+syn match tagCommand ")$" contained+syn match tagCommand "," contained+syn match tagContent "> \zs\S\+" contained+syn match tagContent ": \zs.*" contained+syn match tagContent ">\zs\$\S\+\ze" contained contains=tagWordCommandGroup+syn match tagContent ":\zs\$.*" contained contains=tagCommandGroup+syn match tagInlineArg "[\t ][a-z][0-9a-zA-Z_]*\(>[$ ]\S\+\|:\($\|[$ ].*\)\)" contained contains=tagContent+syn match tagCallingLine "^\t\S\+\( [a-z][a-zA-Z0-9_]*>[$ ]\S\+\)*\( [a-z][a-zA-Z0-9_]*:[$ ].*\)\?$" contains=tagInlineArg,tagBuiltin,tagLocalDef,tagImportedDef++syn region myFold start="^\(define\|\nimport\) " end="^$" transparent fold+set foldmethod=syntax++" Define the default highlighting.+" For version 5.7 and earlier: only when not done already+" For version 5.8 and later: only when an item doesn't have highlighting yet+if version >= 508 || !exists("did_drchip_tags_inits")+ if version < 508+ let did_drchip_tags_inits = 1+ command -nargs=+ HiLink hi link <args>+ else+ command -nargs=+ HiLink hi def link <args>+ endif++ HiLink tagBuiltin Identifier+ HiLink tagLocalDef Identifier+ HiLink tagImportedDef Identifier+ HiLink tagImport PreProc+ HiLink tagMCM Statement+ HiLink tagVariable Number+ HiLink tagContaVar Number+ HiLink tagCase Type+ HiLink tagDefine Type+ HiLink tagDoubleAt Todo+ HiLink tagInlineArg Comment+ HiLink tagComment Comment+ HiLink tagContinuation Special+ HiLink tagCommand Statement+ HiLink tagContent Special+ HiLink tagError Error++ delcommand HiLink+endif++setlocal iskeyword=a-z,A-Z,_,48-57+setlocal softtabstop=4+setlocal shiftwidth=4+setlocal tabstop=4+setlocal comments=b:+,b:#,b:\+setlocal formatoptions-=t formatoptions+=rojql++let b:current_syntax = "mcm"+
+ mcm2html.1 view
@@ -0,0 +1,63 @@+.TH MCM2HTML "1" "January 2016" "mcm2html" "User Commands"+.SH NAME+mcm2html \- Machine Configuration Manager to HTML pretty printer+.SH SYNOPSIS+.B mcm2html+[\fIOPTION\fR..]+\fIFILE\fR+[\fIOPTION\fR..]+.SH DESCRIPTION+.PP+Convert the given .mcm file to a .html_snippet file.+.PP+The generated HTML snippet is a PRE block, intended for inclusion in an HTML page.+Use of the options can output other bits of relevant HTML.+.PP+During conversion, comments are dropped and many MCM constructs are sorted.+.PP+The generated .html_snippet (or .html, depending on options used) file is overwritten if it already exists.+.TP+FILE+input MCM file.+.SH OPTIONS+.TP+\fB\-V\fR, \fB\-\-version\fR+show version+.TP+\fB\-\-head\fR+output (to stdout) the suggested snippet for within <head>+.TP+\fB\-\-css\fR+output (to stdout) the suggested snippet for within an included CSS file+.TP+\fB\-\-fullpage\fR+write a full .html page (instead of .html_snippet)++.SH EXIT STATUS+.TP+0+if OK,+.TP+1+when errors are encountered.++.SH FILES+None but that given on the command line and the same but with either .html or .html_snippet appended.+.SH EXAMPLES+Create .html_snippet version of Go.mcm (written to Go.mcm.html_snippet):+.IP+mcm2html Go.mcm+.PP+Create .html_snippet versions of all .mcm files below the current directory:+.IP+find . -name '*.mcm' -type f -exec mcm2html '{}' ';'+.SH AUTHOR+Written by Anthony Doggett <mcm@interfaces.org.uk>+.SH REPORTING BUGS+Please email the author at the above address, preferably with sufficient information to reproduce the bug.+.SH COPYRIGHT+Copyright (c) 2014-2016 Anthony Doggett+.PP+<http://interfaces.org.uk/mcm>+.SH SEE ALSO+mcm(1)
+ mcm2html.hs view
@@ -0,0 +1,363 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- MCM - Machine Configuration Manager; manages the contents of files and directories+-- Copyright (c) 2013-2016 Anthony Doggett <mcm@interfaces.org.uk>+--+-- Licence:+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program. If not, see <http://www.gnu.org/licenses/>.++module Main (main)+where++import Parser (mcmLoadAndParse)+import ParserTypes (Import(..), Section(..), Define(..), Invocation(..), InvocationArgs(..), CondLocal(..), Content(..), Group(..), Separator(..), Prepend(..), Append(..), InvocationCmd(..), Ident(..), OptArgs(..), Locals(..), Value(..), MCMFile(..), VarsExpand(..))+import Paths_mcm (version)+import VarsParser (expandString)++import Control.Monad(when, unless)+import qualified Data.ByteString.Lazy as B+import Data.Char (isSpace)+import Data.List (foldl', intersperse, sort, sortBy)+import qualified Data.Map as Map+import Data.Maybe (isJust)+import Data.Ord (comparing)+import Data.String (fromString)+import qualified Data.Text.Lazy as T+import Data.Version (showVersion)+import System.Console.GetOpt+import System.Environment (getArgs)+import System.Exit (exitSuccess, exitFailure)+import qualified Text.Blaze.Html5 as H5+import Text.Blaze.Html5 (ToMarkup, toHtml)+import Text.Blaze.Html5.Attributes (class_, type_, charset)+import qualified Text.Blaze.Html.Renderer.Utf8 as Render_Utf8+import qualified Text.Blaze.Html.Renderer.String as Render_String++usage :: String+usage = unlines ["Usage: mcm2html [OPTION..] FILE [OPTION..]"+ ,"Create .mcm.html_snippet from the given .mcm"+ ]++main :: IO ()+main = do+ progargs <- getArgs+ let (actions, nonOpts, msgs) = getOpt Permute options progargs+ unless (null msgs) $ error $ concat msgs ++ usageInfo usage options+ opts <- foldl' (>>=) (return defaultOptions) actions+ let Options {optOutFilenameExtension = extension+ ,optOutputWrapper = wrapper+ } = opts+ infilename <- case nonOpts of+ [i] -> return i+ xs -> do+ putStrLn $ "Error: expected a single .mcm filename but received: " ++ show xs+ exitFailure+ when (extension == "") $ error "Extension can't be empty!"+ let outfilename = infilename ++ extension+ putStrLn $ "Writing " ++ outfilename+ f <- mcmLoadAndParse infilename+ B.writeFile outfilename $ Render_Utf8.renderHtml . wrapper $ toHtml f++data Options = Options+ {optOutFilenameExtension :: String+ ,optOutputWrapper :: H5.Html -> H5.Html+ }++defaultOptions :: Options+defaultOptions = Options+ {optOutFilenameExtension = ".html_snippet"+ ,optOutputWrapper = id+ }++options :: [OptDescr (Options -> IO Options)]+options = [Option "V" ["version"] (NoArg displayVersion) "show version and exit"+ ,Option [] ["head"] (NoArg headOpt) "output (to stdout) the suggested snippet for within <head> and exit"+ ,Option [] ["css"] (NoArg cssOpt) "output (to stdout) the suggested snippet for within an included CSS file and exit"+ ,Option [] ["fullpage"] (NoArg fullpageOpt) "write a full .html page (instead of .html_snippet)"+ ,Option "h" ["help"] (NoArg justHelp) "show this help and exit"+ ]++displayVersion :: Options -> IO Options+displayVersion _ = do+ putStrLn $ "mcm2html " ++ showVersion version+ exitSuccess++justHelp :: Options -> IO Options+justHelp _ = do+ putStrLn $ usageInfo usage options+ exitSuccess++headOpt :: Options -> IO Options+headOpt _ = do+ putStrLn . Render_String.renderHtml $ suggestedHead+ exitSuccess++suggestedHead :: H5.Html+suggestedHead = H5.meta H5.! charset (fromString "utf-8")++cssOpt :: Options -> IO Options+cssOpt _ = do+ putStrLn . Render_String.renderHtml $ suggestedCss+ exitSuccess++suggestedCss :: H5.Html+suggestedCss = text $ unlines+ ["pre.MCM {white-space: pre-wrap; tab-size: 4;-moz-tab-size: 4}"+ ,"pre.MCM .Keyword {color: #ff6060}"+ ,"pre.MCM .Invoke {color: #ff40ff}"+ ,"pre.MCM .Iden {color: #8535e0}"+ ,"pre.MCM .Escaped {color: #3585e0}"+ ,"pre.MCM .Cmd {color: #0000ff}"+ ,"pre.MCM .Con {background-color: #80ff80}"+ ,"pre.MCM .IdenUse {color: #ff0000}"+ ,"pre.MCM .WhenText {background-color: #8080ff}"+ ]++fullpageOpt :: Options -> IO Options+fullpageOpt opts = return opts {optOutFilenameExtension = ".html"+ ,optOutputWrapper = fullPage+ }++fullPage :: H5.Html -> H5.Html+fullPage content = H5.docTypeHtml $ do+ H5.head $ do+ suggestedHead+ newline+ H5.style H5.! type_ (fromString "text/css") $ suggestedCss+ newline+ H5.body content+ newline++text :: String -> H5.Html+text = H5.toHtml . T.pack++newline :: H5.Html+newline = text "\n"++data ColourType = Keyword | Invoke | Iden | Con | Cmd | IdenUse | WhenText | Escaped+ deriving Show++colourwith :: ColourType -> H5.Html -> H5.Html+colourwith c h = H5.span H5.! class_ (fromString . show $ c) $ h++instance ToMarkup MCMFile where+ toMarkup (MCMFile pp s) = do+ H5.pre H5.! class_ (fromString "MCM") $ do+ colourwith Keyword $ text "MCM"+ text " "+ text . show $ pp+ newline+ toHtml s+ newline++instance ToMarkup Section where+ toMarkup (Section is plets defines) = do+ when (is /= []) newline+ mapM_ toHtml is+ unless (Map.null plets) $ do+ newline+ let (x:xs) = sortBy (comparing fst) $ Map.toList plets+ toHtmlLetHead x+ mapM_ toHtmlLetTail xs+ mapM_ toHtml $ sortBy (comparing defName) $ Map.elems defines++toHtmlLetHead :: (Ident, [Content]) -> H5.Html+toHtmlLetHead (i, cs) = do+ colourwith Keyword $ text "let"+ text " "+ toHtmlIdentContent Let (i, cs)+ newline++toHtmlLetTail :: (Ident, [Content]) -> H5.Html+toHtmlLetTail (i, cs) = do+ text "\t\t"+ toHtmlIdentContent Let (i, cs)+ newline++toHtmlInvArg :: (Ident, [Content]) -> H5.Html+toHtmlInvArg (i, cs) = do+ text "\t\t"+ toHtmlIdentContent Arg (i, cs)+ newline++toHtmlInvWordArg :: (Ident, [Content]) -> H5.Html+toHtmlInvWordArg (i, cs) = do+ text " "+ toHtmlIdentContent WordArg (i, cs)++toHtmlWhen :: (Value, Locals) -> H5.Html+toHtmlWhen (v, Locals ls) = do+ text "\t"+ colourwith Keyword $ text "when"+ text " "+ colourwith WhenText $ text . show $ v+ newline+ let ls' = sortBy (comparing fst) $ Map.toList ls+ when (ls' /= []) $ mapM_ toHtmlLetTail ls'++data ICStyle = Let | Arg | WordArg+instance Show ICStyle where+ show Arg = ":"+ show WordArg = ">"+ show Let = " ="++toHtmlIdentContent :: ICStyle -> (Ident, [Content]) -> H5.Html+toHtmlIdentContent icstyle (i, cs) = do+ colourwith Iden $ text . show $ i+ text . show $ icstyle+ let toHtmlRemainingContent :: [Content] -> H5.Html+ toHtmlRemainingContent [] = text ""+ toHtmlRemainingContent xs = do+ newline+ text "\t\t\t"+ toHtmlRemainingContent' xs+ toHtmlRemainingContent' :: [Content] -> H5.Html+ toHtmlRemainingContent' [] = error "It is supposed to be impossible to get here within toHtmlRemainingContent'"+ toHtmlRemainingContent' [CNewline] = text "+"+ toHtmlRemainingContent' [x] = do {text "\\"; toHtml x}+ toHtmlRemainingContent' (CNewline:(xs@(CNewline:_))) = do {text "+"; toHtmlRemainingContent xs}+ toHtmlRemainingContent' (CNewline:x:xs) = do {text "+"; toHtml x; toHtmlRemainingContent xs}+ toHtmlRemainingContent' (x:xs) = do {text "\\"; toHtml x; toHtmlRemainingContent xs}+ case cs of+ [] -> text ""+ xs@(CNewline:_) -> toHtmlRemainingContent xs+ [x] -> toHtml x+ (x:xs) -> do+ toHtml x+ toHtmlRemainingContent xs++command :: T.Text -> String -> (T.Text -> H5.Html) -> H5.Html+command content cmd contentConverter =+ if T.null content+ then colourwith Cmd $ text $ "$" ++ cmd ++ "()"+ else do colourwith Cmd $ text $ "$" ++ cmd ++ "("+ colourwith Con $ contentConverter content+ colourwith Cmd $ text ")"++expandAts :: T.Text -> H5.Html+expandAts t =+ let ve = VarsExpand (\_ s -> Just . colourwith IdenUse $ toHtml s) toHtml toHtml (\_ b -> colourwith Escaped $ toHtml b)+ in case expandString ve t of+ Left s -> error $ "Internal error: " ++ s+ Right e -> e++instance ToMarkup Content where+ toMarkup CEmpty = text ""+ toMarkup (CString s) = if T.null s then text " " else do {text " "; colourwith Con $ expandAts s}+ toMarkup (CExplicitString s) = command s "string" expandAts+ toMarkup (CRawString s) = command s "rawstring" toHtml+ toMarkup (CFile f) = command f "file" expandAts+ toMarkup (CRawFile f) = command f "rawfile" expandAts+ toMarkup (CFragments (Group g) (Prepend p) (Append a) (Separator s)) =+ command (T.intercalate (T.pack ",") [g,p,a,s]) "fragments" expandAts+ toMarkup CNewline = error "Unexpected CNewline"++instance ToMarkup Import where+ toMarkup (Import pp as) = do+ colourwith Keyword $ text "import"+ text " "+ text . show $ pp+ text " "+ colourwith Keyword $ text "as"+ text " "+ H5.toHtml as+ newline++instance ToMarkup Define where+ toMarkup (Define n a oa l cl i) = do+ newline+ colourwith Keyword $ text "define"+ text " "+ text . show $ n+ text "("+ toHtml $ intersperse (text " ") $ map (colourwith Iden . text . show) $ sort a+ toHtml oa+ text ")"+ newline+ toHtml l+ mapM_ toHtml cl+ mapM_ toHtml i++instance ToMarkup Locals where+ toMarkup (Locals l) = unless (Map.null l) $ do+ let (x:xs) = sortBy (comparing fst) $ Map.toList l+ text "\t"+ toHtmlLetHead x+ mapM_ toHtmlLetTail xs++instance ToMarkup Invocation where+ toMarkup (Invocation c a) = do+ text "\t"+ colourwith Invoke $ toHtml c+ toHtml a++instance ToMarkup InvocationCmd where+ toMarkup InvFile = text "File"+ toMarkup InvDir = text "Dir"+ toMarkup InvAbsent = text "Absent"+ toMarkup InvFragment = text "Fragment"+ toMarkup InvSymlink = text "Symlink"+ toMarkup (InvLocal u) = do+ text "."+ expandAts . T.pack . show $ u+ toMarkup (InvImport a b) = do+ toHtml a+ text "."+ expandAts . T.pack . show $ b++instance ToMarkup InvocationArgs where+ toMarkup (InvocationArgs as) = do+ let (wordas, otheras) = bucketArgs $ Map.toList as+ when (wordas /= []) $ mapM_ toHtmlInvWordArg wordas+ newline+ mapM_ toHtmlInvArg otheras++containsWhitespaceOrEmpty :: Content -> Bool+containsWhitespaceOrEmpty CEmpty = True+containsWhitespaceOrEmpty CNewline = True+containsWhitespaceOrEmpty (CString s) = isJust $ T.find isSpace s+containsWhitespaceOrEmpty (CExplicitString s) = containsWhitespaceOrEmpty (CString s)+containsWhitespaceOrEmpty (CRawString s) = isJust $ T.find isSpace s+containsWhitespaceOrEmpty (CFile f) = isJust $ T.find isSpace f+containsWhitespaceOrEmpty (CRawFile f) = isJust $ T.find isSpace f+containsWhitespaceOrEmpty (CFragments (Group g) (Prepend p) (Append a) (Separator s)) = any (isJust . T.find isSpace) [g, p, a, s]++type ICs = [(Ident, [Content])]++bucketArgs :: ICs -> (ICs, ICs)+bucketArgs zs = (sortByFirst as', sortByFirst bs')+ where+ sortByFirst = sortBy (comparing fst)+ (as', bs') = bucketArgs' ([], []) zs+ bucketArgs' (ws, os) [] = (ws, os)+ bucketArgs' (ws, os) (x@(_,[c]):xs) =+ if containsWhitespaceOrEmpty c+ then bucketArgs' (ws, x:os) xs+ else bucketArgs' (x:ws, os) xs+ bucketArgs' (ws, os) (x:xs) = bucketArgs' (ws, x:os) xs++instance ToMarkup OptArgs where+ toMarkup (OptArgs o) | Map.null o = text ""+ toMarkup (OptArgs o) = do+ newline+ mapM_ toHtmlLetTail $ sortBy (comparing fst) $ Map.toList o+ text "\t"++instance ToMarkup CondLocal where+ toMarkup (CondLocal i ls) = do+ text "\t"+ colourwith Keyword $ text "case"+ text " "+ colourwith Iden $ text . show $ i+ newline+ mapM_ toHtmlWhen $ sortBy (comparing fst) $ Map.toList ls
+ mcmtags.1 view
@@ -0,0 +1,37 @@+.TH MCMTAGS: "1" "January 2016" "mcmtags" "User Commands"+.SH NAME+mcmtags \- Generate tag files from MCM files+.SH SYNOPSIS+.B mcmtags+[\fIDIR\fR..]+.SH DESCRIPTION+.PP+Generate an index (or "tag") file+from all *.mcm files found below the current directory,+or if directories given as arguments, below those directories.+The resulting tags are written to ./tags.+.PP+Print warnings for any files that fail to parse.+.SH OPTIONS+.TP+\fB\-V\fR, \fB\-\-version\fR+show version+.SH EXAMPLES+Generate ./tags from all *.mcm files found below the current directory:+.IP+mcmtags+.PP+Generate ./tags from all *.mcm files found below ./src and ./test:+.IP+mcmtags src test+.SH AUTHOR+Written by Anthony Doggett <mcm@interfaces.org.uk>+.SH REPORTING BUGS+Please email the author at the above address, preferably with sufficient information to reproduce the bug.+.SH COPYRIGHT+Copyright (c) 2014-2016 Anthony Doggett+.PP+<http://interfaces.org.uk/mcm>+.SH SEE ALSO+mcm(1),+ctags(1)
+ mcmtags.hs view
@@ -0,0 +1,133 @@+-- MCM - Machine Configuration Manager; manages the contents of files and directories+-- Copyright (c) 2013-2016 Anthony Doggett <mcm@interfaces.org.uk>+--+-- Licence:+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program. If not, see <http://www.gnu.org/licenses/>.++-- Parses all .mcm files below the current directory+-- (If directories given as arguments, uses those instead)+-- Writes the results to "tags" file (in current directory)+-- Prints warnings for any files that fail to parse+module Main (main)+where++import Parser (mcmParse)+import ParserTypes (Define(..), Section(..), MCMFile(..), DefName(..))+import Paths_mcm (version)++import Control.Monad (filterM, unless)+import Data.Char (isAsciiUpper)+import Data.List (isSuffixOf, intercalate, sort, foldl')+import Data.Version (showVersion)+import qualified Data.Map as Map+import qualified Data.Text.Lazy as T+import qualified Data.Text.Lazy.IO as TextIO+import System.Console.GetOpt+import System.Directory (getDirectoryContents)+import System.Environment (getArgs)+import System.Exit (exitSuccess)+import System.FilePath (joinPath)+import System.Posix.Files (getFileStatus, isDirectory)++usage :: String+usage = unlines ["Usage: mcmtags [DIR..]"+ ,"Parse all *.mcm files below the current directory,"+ ,"or if directories given as arguments, below those directories."+ ,"The resulting tags are written to ./tags."+ ,"Print warnings for any files that fail to parse."+ ]++toWarn :: FilePath -> String+toWarn f = "WARNING: failed to parse " ++ f++tryParse :: FilePath -> IO (Maybe MCMFile)+tryParse f = do+ ss <- TextIO.readFile f+ case mcmParse ss of+ Right a -> return $ Just a+ Left _ -> return Nothing++makeTag :: FilePath -> String -> String -> String+makeTag f n ex_cmd = n ++ "\t" ++ f ++ "\t" ++ ex_cmd++toTags :: (FilePath, MCMFile) -> [String]+toTags (f, MCMFile pp (Section _ _ ds)) = ppTag:map dsTag (Map.elems ds)+ where+ ppTag = makeTag f (lastBitOfPath (show pp)) "/^MCM/"+ dsTag d = makeTag f (strDefName d) ("/^define " ++ strDefName d ++ "(/")+ lastBitOfPath :: String -> String+ lastBitOfPath = reverse . takeWhile (/= '.') . reverse+ strDefName = T.unpack . fromDefName . defName++isDirectory' :: FilePath -> IO Bool+isDirectory' f = do+ s <- getFileStatus f+ return $ isDirectory s++findMcm :: FilePath -> IO [FilePath]+findMcm p = do+ allfiles <- getDirectoryContents p+ let fs = [f | f <- allfiles, f `notElem` [".", ".."]]+ ms = [joinPath [p,f] | f <- fs, ".mcm" `isSuffixOf` f]+ ds = [joinPath [p,f] | f <- fs, isAsciiUpper (head f), '.' `notElem` f]+ dirs <- filterM isDirectory' ds+ children <- mapM findMcm dirs+ return $ ms ++ concat children++splitParsed :: [(FilePath, Maybe MCMFile)] -> ([FilePath], [(FilePath, MCMFile)])+splitParsed [] = ([], [])+splitParsed ((fp, m):xs) =+ let (as, bs) = splitParsed xs+ in case m of+ Nothing -> (fp:as, bs)+ Just f -> (as, (fp, f):bs)++main :: IO ()+main = do+ args <- getArgs+ let (actions, nonOpts, msgs) = getOpt Permute options args+ unless (null msgs) $ error $ concat msgs ++ usageInfo usage options+ _ <- foldl' (>>=) (return defaultOptions) actions+ let toRecurse = case nonOpts of+ [] -> ["."]+ _ -> args+ toParse <- mapM findMcm toRecurse+ let toParse' = concat toParse+ parsed <- mapM tryParse toParse'+ let fparsed = zip toParse' parsed+ let (bad, good) = splitParsed fparsed+ tags = sort $ concatMap toTags good+ mapM_ (putStrLn . toWarn) bad+ writeFile "tags" $ intercalate "\n" tags+ return ()++data Options = Options {}++defaultOptions :: Options+defaultOptions = Options {}++options :: [OptDescr (Options -> IO Options)]+options = [Option "V" ["version"] (NoArg displayVersion) "show version and exit"+ ,Option "h" ["help"] (NoArg justHelp) "show this help and exit"+ ]++displayVersion :: Options -> IO Options+displayVersion _ = do+ putStrLn $ "mcmtags " ++ showVersion version+ exitSuccess++justHelp :: Options -> IO Options+justHelp _ = do+ putStrLn $ usageInfo usage options+ exitSuccess
+ mcmtestfiles.tgz view
binary file changed (absent → 23397 bytes)