module DDC.Build.Spec.Parser
( parseBuildSpec
, Error(..) )
where
import DDC.Build.Spec.Base
import DDC.Base.Pretty
import Control.Monad
import Data.List
import Data.Char
import Data.Maybe
import qualified DDC.Core.Module as C
data Error
= ErrorEmpty
{ errorFilePath :: FilePath }
| ErrorParse
{ errorFilePath :: FilePath
, errorLine :: Int }
| ErrorMissingField
{ errorFilePath :: FilePath
, errorMissing :: String }
deriving Show
instance Pretty Error where
ppr err
= case err of
ErrorEmpty filePath
-> vcat [ text filePath
, text "Empty file" ]
ErrorParse filePath n
-> vcat [ text filePath <> text ":" <> int n
, text "Parse error" ]
ErrorMissingField filePath field
-> vcat [ text filePath
, text "Missing field '" <> text field <> text "'" ]
type LineNumber = Int
type StartCol = Int
type Parser a = [(LineNumber, StartCol, String)]
-> Either Error a
parseBuildSpec :: FilePath -> String -> Either Error Spec
parseBuildSpec path str
= let
ls = lines str
lsNum = zip [1..] ls
lsNumCols = attachCols lsNum
in pBuildSpec path lsNumCols
pBuildSpec :: FilePath -> Parser Spec
pBuildSpec path []
= Left $ ErrorEmpty path
pBuildSpec path ((n, _s, str) : rest)
| all (\c -> isSpace c || c == '\n') str
= pBuildSpec path rest
| ["ddc", "build", version] <- words str
= do cs <- pComponents path rest
return $ Spec
{ specVersion = version
, specComponents = cs }
| otherwise
= Left $ ErrorParse path n
pComponents :: FilePath -> Parser [Component]
pComponents _path []
= return []
pComponents path ((n, start, str) : rest)
| all (\c -> isSpace c || c == '\n') str
= pComponents path rest
| str == "library"
, (lsLibrary, lsMore)
<- span (\(_, start', _) -> start' == 0 || start' > start) rest
= do fs <- pLibraryFields path lsLibrary
more <- pComponents path lsMore
return $ fs : more
| str == "executable"
, (lsExecutable, lsMore)
<- span (\(_, start', _) -> start' == 0 || start' > start) rest
= do fs <- pExecutableFields path lsExecutable
more <- pComponents path lsMore
return $ fs : more
| otherwise
= Left $ ErrorParse path n
pLibraryFields :: FilePath -> Parser Component
pLibraryFields path str
= do fs <- pFields path str
(sName, fs_name) <- takeField path "name" fs
(sVersion, fs_version) <- takeField path "version" fs_name
(sTetraModules, fs_modules) <- takeField path "tetra-modules" fs_version
let Just msTetra
= sequence
$ map C.readModuleName
$ words $ sTetraModules
return $ SpecLibrary
{ specLibraryName = sName
, specLibraryVersion = sVersion
, specLibraryTetraModules = msTetra
, specLibraryMeta = fs_modules }
pExecutableFields :: FilePath -> Parser Component
pExecutableFields path str
= do fs <- pFields path str
(sName, fs_name) <- takeField path "name" fs
(sTetraMain, fs_main) <- takeField path "tetra-main" fs_name
let (sTetraOther, fs_other) = takeFieldMaybe path "tetra-other" fs_main
let Just mTetraMain
= C.readModuleName sTetraMain
let Just msTetra
= sequence $ map C.readModuleName
$ concat $ maybeToList $ liftM words sTetraOther
return $ SpecExecutable
{ specExecutableName = sName
, specExecutableTetraMain = mTetraMain
, specExecutableTetraOther = msTetra
, specExecutableMeta = fs_other }
pFields :: FilePath -> Parser [(String, String)]
pFields _path []
= return []
pFields path ((n, start, str) : rest)
| all (\c -> isSpace c || c == '\n') str
= pFields path rest
| (lsField, lsMore)
<- span (\(_, start', _) -> start' == 0 || start' > start) rest
, (fieldName, ':' : fieldValue)
<- span (\c -> c /= ':')
$ str ++ concat [ s | (_, _, s) <- lsField]
= do let f = (chomp fieldName, chomp fieldValue)
more <- pFields path lsMore
return $ f : more
| otherwise
= Left $ ErrorParse path n
takeField :: FilePath
-> String -> [(String, String)]
-> Either Error (String, [(String, String)])
takeField path name fs
= case lookup name fs of
Nothing -> Left $ ErrorMissingField path name
Just s -> return (s, delete (name, s) fs)
takeFieldMaybe
:: FilePath
-> String -> [(String, String)]
-> (Maybe String, [(String, String)])
takeFieldMaybe _path name fs
= case lookup name fs of
Nothing -> (Nothing, fs)
Just s -> (Just s, delete (name, s) fs)
attachCols
:: [(LineNumber, String)]
-> [(LineNumber, StartCol, String)]
attachCols lstrs
= [ (ln, startCol 1 str, str) | (ln, str) <- lstrs ]
where startCol n ss
= case ss of
[] -> 0
' ' : ss' -> startCol (n + 1) ss'
'\t' : ss' -> startCol (n + 8) ss'
_ : _ -> n
chomp :: String -> String
chomp str
= reverse $ dropWhile isSpace $ reverse $ dropWhile isSpace str