module DatabaseDesign.Ampersand.InputProcessing (
createFspec
)
where
import qualified DatabaseDesign.Ampersand.Basics as Basics
import DatabaseDesign.Ampersand.Fspec
import DatabaseDesign.Ampersand.Misc
import DatabaseDesign.Ampersand.ADL1.P2A_Converters
import DatabaseDesign.Ampersand.Input.ADL1.UU_Scanner
import DatabaseDesign.Ampersand.Input.ADL1.UU_Parsing
import DatabaseDesign.Ampersand.Input.ADL1.Parser
import DatabaseDesign.Ampersand.ADL1
import DatabaseDesign.Ampersand.Input.ADL1.CtxError (CtxError(PE))
import Data.List
import System.Directory
import System.FilePath
import Control.Monad
import Data.Traversable (sequenceA)
import Control.Applicative
fatal :: Int -> String -> a
fatal = Basics.fatalMsg "InputProcessing"
createFspec :: Options
-> IO(Guarded Fspc)
createFspec flags =
do userCtx <- parseWithIncluded flags (fileName flags)
bothCtx <- if includeRap flags
then do let rapFile = ampersandDataDir flags </> "FormalAmpersand" </> "FormalAmpersand.adl"
exists <- doesFileExist rapFile
when (not exists) (fatal 39 $ "Ampersand isn't installed properly. Formal specification of Ampersand expected at:"
++"\n "++show rapFile
++"\n (You might want to re-install ampersand...)")
rapCtx <- parseWithIncluded flags rapFile
popsCtx <- popsCtxOf userCtx
case sequenceA [userCtx, rapCtx, popsCtx] of
Errors err -> return (Errors err)
Checked ps -> return (Checked
(foldr mergeContexts emptyContext ps))
else return userCtx
case bothCtx of
Errors err -> return (Errors err)
Checked pCtx
-> do let (gaCtx) = pCtx2aCtx pCtx
case gaCtx of
(Errors err ) -> return (Errors err)
(Checked aCtx) -> return (Checked (makeFspec flags aCtx ))
where
popsCtxOf :: Guarded P_Context ->IO(Guarded P_Context)
popsCtxOf gp =
(case gp of
Errors _ -> return (Errors [])
Checked pCtx
-> case pCtx2aCtx pCtx of
(Errors err ) -> return (Errors err)
(Checked aCtx)
-> do let fspc = makeFspec flags aCtx
popScript = meatGrinder flags fspc
when (genMeat flags)
(do let (nm,content) = popScript
outputFile = combine (dirOutput flags) $ replaceExtension nm ".adl"
writeFile outputFile content
verboseLn flags $ "Meta population written into " ++ outputFile ++ "."
)
case parse1File2pContext popScript of
(Errors err) -> fatal 64 ("MeatGrinder has errors!"
++ intercalate "\n"(map showErr err))
(Checked (pctx,[])) -> return (Checked pctx)
(Checked _ ) -> fatal 67 "Meatgrinder returns included file????"
)
type FileContent = (FilePath, String)
type ParseResult = (P_Context, [FilePath])
parseWithIncluded :: Options -> FilePath -> IO(Guarded P_Context)
parseWithIncluded flags fp = tailRounds [] (emptyContext,[fp])
where
tailRounds :: [FileContent]
-> ParseResult
-> IO(Guarded P_Context)
tailRounds dones (pCtx, names) =
do let filesToProcessThisRound = [f | f<-names, f `notElem` map fst dones]
case filesToProcessThisRound of
[] -> do return (Checked pCtx)
newNs -> do fs <- readFiles newNs
res <- oneRound fs dones pCtx
case res of
Errors err -> return (Errors err)
Checked (pCtx',included)
-> tailRounds (nub ( dones++fs)) (pCtx', included)
readFiles :: [FilePath] -> IO [FileContent]
readFiles fs = mapM readFile' fs
where
readFile' f =
do verboseLn flags ("reading "++f)
content <- Basics.readFile f
return (f,content)
oneRound :: [FileContent]
-> [FileContent]
-> P_Context
-> IO(Guarded ParseResult)
oneRound todos dones pCtx = pure parseNext
where
parseNext :: Guarded ParseResult
parseNext =
case nub [f | f <- todos, f `notElem` dones] of
[] -> Checked (pCtx,[])
fs -> case sequenceA (map parse1File2pContext fs) of
Checked prs -> Checked ( foldl mergeContexts pCtx (map fst prs)
, concatMap snd prs)
Errors errs -> Errors errs
parse1File2pContext :: FileContent -> Guarded ParseResult
parse1File2pContext (fPath, fContent) =
let scanner = scan keywordstxt keywordsops specialchars opchars fPath initPos
steps :: Steps (Pair ParseResult (Pair [Token] a)) Token
steps = parse pContext (scanner fContent)
in case getMsgs steps of
[] -> let Pair (pCtx,includes) _ = evalSteps steps
in Checked (pCtx,map normalize includes)
msgs-> Errors (map PE msgs)
where
normalize ::FilePath -> FilePath
normalize name = takeDirectory fPath </> name
emptyContext :: P_Context
emptyContext = PCtx "" [] Nothing Nothing [] [] [] [] [] [] [] [] [] [] [] [] [] [] []
mergeContexts :: P_Context -> P_Context -> P_Context
mergeContexts (PCtx nm1 pos1 lang1 markup1 thms1 pats1 pprcs1 rs1 ds1 cs1 ks1 vs1 gs1 ifcs1 ps1 pops1 sql1 php1 metas1)
(PCtx nm2 pos2 lang2 markup2 thms2 pats2 pprcs2 rs2 ds2 cs2 ks2 vs2 gs2 ifcs2 ps2 pops2 sql2 php2 metas2) =
PCtx{ ctx_nm = if null nm1 then nm2 else nm1
, ctx_pos = pos1 ++ pos2
, ctx_lang = lang1 `orElse` lang2 `orElse` Nothing
, ctx_markup = markup1 `orElse` markup2 `orElse` Nothing
, ctx_thms = thms1 ++ thms2
, ctx_pats = pats1 ++ pats2
, ctx_PPrcs = pprcs1 ++ pprcs2
, ctx_rs = rs1 ++ rs2
, ctx_ds = ds1 ++ ds2
, ctx_cs = cs1 ++ cs2
, ctx_ks = ks1 ++ ks2
, ctx_vs = vs1 ++ vs2
, ctx_gs = gs1 ++ gs2
, ctx_ifcs = ifcs1 ++ ifcs2
, ctx_ps = ps1 ++ ps2
, ctx_pops = pops1 ++ pops2
, ctx_sql = sql1 ++ sql2
, ctx_php = php1 ++ php2
, ctx_metas = metas1 ++ metas2
}
orElse :: Maybe a -> Maybe a -> Maybe a
x `orElse` y = case x of
Just _ -> x
Nothing -> y