module DisTract.Bug.Field
(loadFieldDfns,
fieldsDir,
writeFields,
loadFields,
updateFields
)
where
import DisTract.Bug.PseudoField
import DisTract.Utils
import DisTract.Types
import DisTract.Layout
import qualified Data.Map as M
import qualified JSON as J
import System.FilePath
import System.Directory
import Data.Maybe
import Data.List
import Control.Monad
fieldsDir :: FilePath
fieldsDir = "fields"
defaultValueKey :: String
defaultValueKey = "default"
fieldTypeKey :: String
fieldTypeKey = "type"
fieldValuesKey :: String
fieldValuesKey = "values"
graphType :: String
graphType = "graph"
simpleType :: String
simpleType = "simple"
freeType :: String
freeType = "free"
pseudoType :: String
pseudoType = "pseudo"
loadFieldDfns :: Config -> IO (M.Map String Field)
loadFieldDfns Config{ baseDir = base }
= do { files <- getDirectoryContents fieldsPath
; fieldDefs <- mapM (readFieldDef fieldsPath) files
; return $ M.fromList . map (fieldName >>= (,)) . catMaybes $ fieldDefs
}
where
fieldsPath = combine (bugsDir base) fieldsDir
readFieldDef :: FilePath -> FilePath -> IO (Maybe Field)
readFieldDef fieldsPath field
= do { isFile <- doesFileExist fullPath
; if isFile
then do { contents <- readFileStrict fullPath
; return $ case J.parse contents of
(Just (J.Object obj)) -> Just $ buildFieldDfn field obj
_ -> Nothing
}
else return Nothing
}
where
fullPath = combine fieldsPath field
buildFieldDfn :: String -> (M.Map String J.Value) -> Field
buildFieldDfn name obj
= case fieldType of
Nothing -> error $ "Cannot find field type for field '" ++ name ++ "'"
(Just (J.String t))
| t == graphType -> buildGraphField name obj
| t == simpleType -> buildSimpleField name obj
| t == freeType -> buildFreeField name obj
| t == pseudoType -> buildPseudoField name obj
| otherwise -> error $ "Unknown field type '" ++ t ++
"' for field '" ++ name ++ "'"
_ -> error $ "Cannot parse field type for field '" ++ name ++ "'"
where
fieldType = M.lookup fieldTypeKey obj
buildPseudoField :: String -> (M.Map String J.Value) -> Field
buildPseudoField name _ = pseudoFieldDfn (read name)
buildFreeField :: String -> (M.Map String J.Value) -> Field
buildFreeField name obj = f
where
f = Field { fieldName = name,
fieldDefault = initValue,
fieldType = FieldFreeForm,
fieldValidator = (Just . flip FieldValue f)
}
initValue = FieldValue init f
init = getDefaultValueForField name obj
buildSimpleField :: String -> (M.Map String J.Value) -> Field
buildSimpleField name obj = f
where
f = Field { fieldName = name,
fieldDefault = initValue,
fieldType = (FieldSimpleValues values),
fieldValidator = validator
}
initValue = FieldValue init f
init = getDefaultValueForField name obj
(J.Array valuesJ) = fromMaybe (error $ "No values found for field '" ++
name ++ "'")
$ M.lookup fieldValuesKey obj
values = nub $ map convert valuesJ
validator :: Validator
validator v = fmap (const $ FieldValue v f) (elemIndex v values)
convert :: J.Value -> String
convert (J.String v) = v
convert v = error $ "Unexpected value '" ++ (show v) ++
"' for field '" ++ name ++ "'"
buildGraphField :: String -> (M.Map String J.Value) -> Field
buildGraphField name obj = f
where
f = Field { fieldName = name,
fieldDefault = initValue,
fieldType = (FieldGraph values),
fieldValidator = validator
}
initValue = FieldValue init f
init = getDefaultValueForField name obj
(J.Object valuesObj) = fromMaybe (error $ "No values found for field '" ++
name ++ "'")
$ M.lookup fieldValuesKey obj
values = M.map convertAndCheck valuesObj
validator :: Validator
validator v = if M.member v values
then Just $ FieldValue v f
else Nothing
convertAndCheck :: J.Value -> [(String,String)]
convertAndCheck (J.Object transitionsObj)
= M.foldWithKey convertAndCheck' [] transitionsObj
convertAndCheck v = error $ "Unexpected value '" ++ (show v) ++
"' for field '" ++ name ++ "'"
convertAndCheck' :: String -> J.Value -> [(String,String)] ->
[(String,String)]
convertAndCheck' verb (J.String next) acc
= case M.member next values of
True -> (verb, next):acc
_ -> error $ "Field '" ++ name ++ "' references a value '" ++ next ++
"' without defining it."
convertAndCheck' _ next _ = error $ "Unexpected reference '" ++ (show next) ++
"' in field '" ++ name ++ "'"
getDefaultValueForField :: String -> (M.Map String J.Value) -> String
getDefaultValueForField name obj = init
where
(J.String init) = fromMaybe
(error $ "Can't find default value for field '" ++
name ++ "'")
$ M.lookup defaultValueKey obj
writeFields :: Config -> BugId ->
M.Map String J.Value -> IO FieldValues
writeFields config@(Config{ fieldDfns = dfns }) bid values
= foldM (writeField fieldsPath) M.empty validated
where
bugPath = bugIdToPath config bid
fieldsPath = combine bugPath fieldsDir
validated = M.foldWithKey validator [] $ dfns
validator :: String -> Field -> [FieldValue] -> [FieldValue]
validator _ (PseudoField {}) acc = acc
validator name dfn acc
= case value of
(Just (J.String v)) -> (fromMaybe dflt (fieldValidator dfn v)):acc
_ -> dflt:acc
where
value = M.lookup name values
dflt = fieldDefault dfn
updateFields :: Config -> Bug ->
M.Map String J.Value -> IO (Bug, [FieldValue])
updateFields config@(Config{ fieldDfns = dfns }) bug values
= do { valuesNew <- foldM (writeField fieldsPath) valuesOld validated
; let bug' = bug { bugFields = valuesNew }
; bug'' <- loadPseudoFields config bug'
; return (bug'', validated)
}
where
(Bug bid _ valuesOld) = bug
bugPath = bugIdToPath config bid
fieldsPath = combine bugPath fieldsDir
validated = M.foldWithKey validator [] $ dfns
validator :: String -> Field -> [FieldValue] -> [FieldValue]
validator _ (PseudoField {}) acc = acc
validator name dfn acc
= case value of
(Just (J.String v)) -> maybe acc (:acc) (fieldValidator dfn v)
_ -> acc
where
value = M.lookup name values
writeField :: FilePath -> FieldValues -> FieldValue -> IO FieldValues
writeField _ obj fv@(FieldValue _ (PseudoField name _))
= return $ M.insert name fv obj
writeField fieldsPath obj fv@(FieldValue value field)
= do { writeFileStrict path value
; return $ M.insert name fv obj
}
where
name = fieldName field
path = combine fieldsPath name
loadFields :: Config -> BugId -> IO FieldValues
loadFields config@(Config{ fieldDfns = dfns }) bid
= do { values <- sequence (M.fold fieldLoader [] dfns)
; return $ M.fromList values
}
where
fieldsPath = combine bugPath fieldsDir
bugPath = bugIdToPath config bid
fieldLoader :: Field -> [IO (String, FieldValue)] ->
[IO (String, FieldValue)]
fieldLoader (PseudoField {}) acc = acc
fieldLoader dfn acc = loader:acc
where
name = fieldName dfn
fieldPath = combine fieldsPath name
dflt = fieldDefault dfn
loader :: IO (String, FieldValue)
loader = do { exists <- doesFileExist fieldPath
; if exists
then do { value <- readFileStrict fieldPath
; case fieldValidator dfn value of
Nothing -> return (name, dflt)
(Just fv) -> return (name, fv)
}
else return (name, dflt)
}