mcm-0.6.8.1: ParserTypes.hs
-- MCM - Machine Configuration Manager; manages the contents of files and directories
-- Copyright (c) 2013-2018 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(..), dummyDefName, 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)
dummyDefName :: DefName
dummyDefName = (DefName . T.pack) "<init>"
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 :: Int -> ContentType -> ContentLine -> Either String [Content]
toContent lineno ct (PrependNewline s) =
case toContent lineno ct (Plain s) of
Left e -> Left e
Right cs -> Right $ CNewline : cs
toContent _ _ (Plain s) | T.null s = Right []
toContent lineno 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
(a, b) | a == T.pack "numformat" && T.head b == '(' -> checkEnd makeNumFormat $ T.tail b
(a, b) | a == T.pack "linn" && T.head b == '(' -> checkEnd makeLinn $ 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
makeNumFormat ss =
let fargs = T.split (== ',') ss
[format, number] = fargs
in
if length fargs == 2
then Right [CNumFormat format number]
else Left $ "Wrong number of numformat arguments: " ++ 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
makeLinn ss | T.null ss = Right [CLinn lineno]
makeLinn ss = Left $ "$linn expects 0 arguments, but received: " ++ 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
| CNumFormat T.Text T.Text
| CLinn Int
| 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
}