hub-1.4.0: Hub/Parse.hs
--
-- >>> Hub.Parse <<<
--
-- This module parses the hub XML file to produce a Hub, and the inverse,
-- dumping a Hub into XML.
--
-- (c) 2011-2015 Chris Dornan
module Hub.Parse
( parse
, dump
, PSt(..) -- kill warnings
) where
import Data.Char
import Text.Printf
import qualified Data.ByteString as B
import qualified Text.XML.Expat.Annotated as X
import Hub.Poss
import Hub.Oops
import Hub.Hub
import Hub.FilePaths
parse :: HubSource -> FilePath -> HubName -> FilePath -> HubKind -> IO Hub
parse hs dy hn hf hk =
do cts <- B.readFile hf
case parse' cts of
YUP tr -> case check hs dy hn hf hk tr of
NOPE er -> fail_err hn hf er
YUP hb -> return hb
NOPE er -> fail_err hn hf er
dump :: Hub -> IO ()
dump hub = B.writeFile path xml_bs
where
xml_bs = B.pack $ map (toEnum.fromEnum) xml
xml = unlines $
[ "<hub>"
, printf " <comnt>%s</comnt>" $ string2xml comnt
, printf " <hcbin>%s</hcbin>" $ string2xml hcbin
, printf " <tlbin>%s</tlbin>" $ string2xml tlbin
] ++
[ printf " <civrn>%s</civrn>" $ string2xml civrn | Just civrn<-[mb_civrn]
] ++
[ printf " <glbdb>%s</glbdb>" $ string2xml glbdb
] ++
[ printf " <usrgh>%s</usrgh>" $ string2xml usrgh | Just usrgh<-[mb_usrgh]
] ++
[ printf " <usrdb>%s</usrdb>" $ string2xml usrdb | Just usrdb<-[mb_usrdb]
] ++
[ printf " <lockd>%s</lockd>" lks | not $ null lks
] ++
[ printf " <insta>%s</insta>" $ string2xml $ unwords insa | not $ null insa
] ++
[ "</hub>"
]
lks = if lk then "rmie" else ""
mb_usrgh = fmap glb_hnUHB mb_uh
mb_usrdb = fmap usr_dbUHB mb_uh
lk = maybe False lockedUHB mb_uh
path = path__HUB hub
comnt = commntHUB hub
hcbin = hc_binHUB hub
tlbin = tl_binHUB hub
mb_civrn = ci_vrnHUB hub
glbdb = glb_dbHUB hub
mb_uh = usr___HUB hub
insa = inst_aHUB hub
fail_err :: HubName -> FilePath -> Err -> IO a
fail_err _ hf er = oops PrgO rs
where
rs = printf "%s:%d:%d %s" hf ln (cn+1) es
ln = X.xmlLineNumber lc
cn = X.xmlColumnNumber lc
X.XMLParseError es lc = er
type Loc = X.XMLParseLocation
type Err = X.XMLParseError
type Tag = String
type Node = X.LNode Tag String
tx_err :: Loc -> String -> Err
tx_err _ = err loc0
err :: Loc -> String -> Err
err = flip X.XMLParseError
loc0 :: Loc
loc0 = X.XMLParseLocation 1 0 0 0
parse' :: B.ByteString -> Poss Err Node
parse' = ei2ps . X.parse' X.defaultParseOptions
check :: HubSource -> FilePath -> HubName -> FilePath -> HubKind -> Node -> Poss Err Hub
check hs dy hn hf hk (X.Element "hub" [] ns lc) =
final hs dy hk $ foldl chk (YUP $ start hn hf lc) ns
where
chk (NOPE er) _ = NOPE er
chk (YUP st) nd = foldr (trial st nd) (NOPE $ unrecognised st nd)
[ chk_wspce
, chk_comnt
, chk_hcbin
, chk_tlbin
, chk_civrn
, chk_glbdb
, chk_usrdb
, chk_usrgh
, chk_lockd
, chk_insta
-- depracated (no warnings yet)
, chk_hpbin
, chk_cibin
]
check _ _ _ _ _ _ = NOPE $ err loc0 "expected simple <hub>...</hub>"
data PSt = ST
{ handlST :: HubName
, hpathST :: FilePath
, locwfST :: Loc
, comntST :: Maybe String
, hcbinST :: Maybe FilePath
, tlbinST :: Maybe FilePath
, civrnST :: Maybe FilePath
, glbdbST :: Maybe FilePath
, usrghST :: Maybe FilePath
, usrdbST :: Maybe FilePath
, lockdST :: Maybe Bool
, instaST :: Maybe [String]
} deriving (Show)
start :: HubName -> FilePath -> Loc -> PSt
start hn fp lc =
ST hn fp lc Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
final :: HubSource -> FilePath -> HubKind -> Poss Err PSt -> Poss Err Hub
final _ _ _ (NOPE er) = NOPE er
final hs dy hk (YUP st) =
do co <- get_co
hc <- get_hc
tl <- get_tl
cv <- get_cv
gl <- get_gl
ia <- get_ia
mb_pr <- case (mb_ur,mb_gh) of
(Just ur,Nothing) -> (Just . ((,) ur)) `fmap` calc_gh gl
(Just ur,Just gh) -> return $ Just (ur,gh)
(Nothing,_ ) -> return Nothing
return $ HUB hs hn hk hf co hc tl cv gl ia $ fmap mk_uhb mb_pr
where
get_co = maybe (YUP "" ) YUP mb_co
get_hc = maybe (NOPE hc_err ) YUP mb_hc
get_tl = maybe (YUP toolsBin) YUP mb_tl
get_cv = maybe (YUP Nothing ) (YUP . Just) mb_cv
get_gl = maybe (NOPE gl_err ) YUP mb_gl
get_ia = maybe (YUP [] ) YUP mb_ia
hc_err = err lc "Hub doesn't specify a GHC bin directory"
gl_err = err lc "Hub doesn't specify a global package directory"
mk_uhb = \(ur,gh) -> UHB dy gh ur $ maybe False id mb_lk
calc_gh gl =
case match (mk_re globalHubREs) gl of
Just gh | isHubName gh == Just GlbHK -> return gh
_ -> NOPE $ err loc0 msg
where
msg = "Could not derive the global hub name from the "
++ "filepath of the global package databse"
ST hn hf lc mb_co mb_hc mb_tl mb_cv mb_gl mb_gh mb_ur mb_lk mb_ia = st
trial :: PSt -> Node -> (PSt -> Node -> Maybe(Poss Err PSt)) -> Poss Err PSt -> Poss Err PSt
trial st nd f ps = maybe ps id $ f st nd
unrecognised :: PSt -> Node -> Err
unrecognised _ (X.Element tg _ _ lc) = err lc $ printf "<%s> not recognised" tg
unrecognised st (X.Text tx ) = err lc $ printf "unexpected text: %s" tx
where
lc = locwfST st
chk_comnt, chk_wspce, chk_hcbin, chk_tlbin,
chk_civrn, chk_glbdb, chk_usrgh, chk_usrdb,
chk_hpbin, chk_cibin, chk_lockd, chk_insta :: PSt -> Node -> Maybe(Poss Err PSt)
chk_wspce st nd =
case nd of
X.Element _ _ _ _ -> Nothing
X.Text txt | all isSpace txt -> Just $ YUP st
| otherwise -> Just $ NOPE $ tx_err lc txt_er
where
lc = locwfST st
txt_er = "unexpected top-level text"
chk_comnt st0 nd = simple_node True st0 nd "comnt" chk
where
chk st lc arg =
case comntST st of
Nothing -> YUP (st{comntST=Just arg})
Just _ -> NOPE $ err lc "<comnt> respecified"
chk_hcbin st0 nd = simple_node False st0 nd "hcbin" chk
where
chk st lc arg =
case hcbinST st of
Nothing -> YUP (st{hcbinST=Just arg})
Just _ -> NOPE $ err lc "<hcbin> respecified"
chk_tlbin st0 nd = simple_node False st0 nd "tlbin" chk
where
chk st lc arg =
case tlbinST st of
Nothing -> YUP (st{tlbinST=Just arg})
Just _ -> NOPE $ err lc "<cibin> re-specified"
chk_civrn st0 nd = simple_node False st0 nd "civrn" chk
where
chk st lc arg =
case civrnST st of
Nothing -> YUP (st{civrnST=Just arg})
Just _ -> NOPE $ err lc "<civrn> re-specified"
chk_glbdb st0 nd = simple_node False st0 nd "glbdb" chk
where
chk st lc arg =
case glbdbST st of
Nothing -> YUP (st{glbdbST=Just arg})
Just _ -> NOPE $ err lc "<glbdb> respecified"
chk_usrgh st0 nd = simple_node False st0 nd "usrgh" chk
where
chk st lc arg =
case usrghST st of
Nothing -> YUP (st{usrghST=Just arg})
Just _ -> NOPE $ err lc "<usrgh> respecified"
chk_usrdb st0 nd = simple_node False st0 nd "usrdb" chk
where
chk st lc arg =
case usrdbST st of
Nothing -> YUP (st{usrdbST=Just arg})
Just _ -> NOPE $ err lc "<usrdb> respecified"
chk_lockd st0 nd = simple_node False st0 nd "lockd" chk
where
chk st lc arg =
case lockdST st of
Nothing -> YUP (st{lockdST=Just $ not $ all isSpace arg})
Just _ -> NOPE $ err lc "<lockd> respecified"
chk_insta st0 nd = simple_node True st0 nd "insta" chk
where
chk st lc arg =
case instaST st of
Nothing -> YUP (st{instaST=Just $ words arg})
Just _ -> NOPE $ err lc "<insta> respecified"
-- deprecated (pre-0.3) constructions
chk_hpbin st0 nd = simple_node False st0 nd "hpbin" $ \st _ _ -> YUP st
chk_cibin st0 nd = simple_node False st0 nd "cibin" $ \st _ _ -> YUP st
simple_node :: Bool -> PSt -> Node -> Tag -> (PSt->Loc->String->Poss Err PSt)
-> Maybe (Poss Err PSt)
simple_node ev st (X.Element tg' as ks lc) tg cont
| tg==tg' = Just $
do chk_as
txt <- chk_ks
cont (st {locwfST=lc}) lc txt
| otherwise = Nothing
where
chk_as = case as of
[] -> return ()
_:_ -> NOPE $ err lc ats_er
chk_ks = case [ () | X.Element _ _ _ _<-ks ] of
[] -> chk_nl
_:_ -> NOPE $ err lc txt_er
chk_nl = case all_tx of
[] | not ev -> NOPE $ err lc emp_er
_ -> chk_ls
chk_ls = case all (/='\n') all_tx of
True -> return all_tx
False -> NOPE $ err lc lns_er
all_tx = trim $ concat $ [ txt | X.Text txt<-ks ]
ats_er = printf "<%s> takes no attributes" tg
txt_er = printf "<%s> takes simple text" tg
emp_er = printf "<%s> shouldn't be empty" tg
lns_er = printf "<%s> should be on a single line" tg
simple_node _ _ (X.Text _) _ _
= Nothing
string2xml :: String -> String
string2xml = concatMap fixChar
where
fixChar '<' = "<"
fixChar '>' = ">"
fixChar '&' = "&"
fixChar '"' = """
fixChar c | ord c < 0x80 = [c]
fixChar c = "&#" ++ show (ord c) ++ ";"