mcm-0.6.4.10: ParserTypes.hs

-- 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
                               }