ruler-0.4.1.0: src/Ruler.hs
module Main (main) where
import System.IO
import System.Environment
import System.Exit
import Control.Monad.State
import qualified Data.Map as Map
import System.Console.GetOpt
import UHC.Util.Pretty
import UHC.Util.Utils( panicJust )
import UHC.Util.ParseUtils
import UHC.Util.ParseErrPrettyPrint
import UHC.Util.CompileRun
import Version
import Err
import Gam( emptyGam )
import Common
import Opts
import qualified AbsSyn.AbsSyn1 as AS1
import qualified Main1AG as M1
import qualified Main2AG as M2
import AS1.Imports
import TrfAS2.GenARule
import TrfAS2.GenLaTeX
import KeywParser
import Parser
import Expr.Expr
import FmGam
-------------------------------------------------------------------------
-- Compile run state
-------------------------------------------------------------------------
data RCompileUnitState
= RCUSUnknown | RCUSRuler | RCUSFail
deriving (Show,Eq)
data RCompileUnit
= RCompileUnit
{ rcuFilePath :: FPath
, rcuModNm :: Nm
, rcuMbOut :: Maybe AS1.AGItf
, rcuImpNmL :: [Nm]
, rcuState :: RCompileUnitState
}
emptyRCU :: RCompileUnit
emptyRCU
= RCompileUnit
{ rcuFilePath = emptyFPath
, rcuModNm = nmUnk
, rcuMbOut = Nothing
, rcuImpNmL = []
, rcuState = RCUSUnknown
}
rcuStoreMbOut x rcu = rcu {rcuMbOut = x}
rcuStoreImpNmL x rcu = rcu {rcuImpNmL = x}
data RCompileRunStateInfo
= RCompileRunStateInfo
{ crsiOpts :: Opts
, crsiImpPosMp :: ImpModMp
}
instance FileLocatable RCompileUnit String where
fileLocation _ = "unknown"
noFileLocation = "unknown"
instance CompileUnitState RCompileUnitState where
cusDefault = RCUSRuler
cusUnk = RCUSUnknown
cusIsUnk = (==RCUSUnknown)
cusIsImpKnown s = s /= RCUSUnknown
instance CompileUnit RCompileUnit Nm String RCompileUnitState where
cuDefault = emptyRCU
cuFPath = rcuFilePath
cuLocation = fileLocation
cuKey = rcuModNm
cuState = rcuState
cuUpdFPath fp u = u {rcuFilePath = fp}
cuUpdLocation _ u = u
cuUpdState st u = u {rcuState = st}
cuUpdKey nm u = u {rcuModNm = nm}
cuImports = rcuImpNmL
instance FPathError Err
instance CompileRunError Err SPos where
crePPErrL = ppErrPPL
creMkNotFoundErrL p fp sp sufs = [Err_FileNotFound p fp sp]
creAreFatal = errLIsFatal
instance CompileRunStateInfo RCompileRunStateInfo Nm SPos where
crsiImportPosOfCUKey n i = Map.findWithDefault emptySPos n (crsiImpPosMp i)
instance CompileModName Nm where
mkCMNm = Nm
type RCompileRun = CompileRun Nm RCompileUnit RCompileRunStateInfo Err
type RCompilePhase a = CompilePhase Nm RCompileUnit RCompileRunStateInfo Err a
-------------------------------------------------------------------------
-- Pretty printing
-------------------------------------------------------------------------
instance PP RCompileUnitState where
pp = pp . show
instance Show RCompileUnit where
show _ = "RCU"
instance PP RCompileUnit where
pp u = "RCU:" >#< pp (show $ rcuFilePath $ u) >#< ": state " >#< pp (rcuState u) >#< ": impL " >#< pp (show $ rcuImpNmL u)
-------------------------------------------------------------------------
-- File suffix
-------------------------------------------------------------------------
type FileSuffMp = [(FileSuffix,RCompileUnitState)]
fileSuffMp :: FileSuffMp
fileSuffMp = [ ( Just "rul", RCUSRuler ), ( Just "", RCUSRuler ), ( Just "*", RCUSRuler ) ]
-------------------------------------------------------------------------
-- Compile run actions
-------------------------------------------------------------------------
cpParseCU :: Nm -> RCompilePhase ()
cpParseCU modNm
= do { cr <- get
; let cu = crCU modNm cr
fp = cuFPath cu
fNm = fpathToStr fp
; (fn,fb,fh)
<- if fpathIsEmpty fp
then return ("<stdin>","<stdin>",stdin)
else do { let fn = fpathToStr fp
; h <- lift $ openFile fn ReadMode
; return (fn,fpathToStr (fpathRemoveSuff fp),h)
}
-- ; cpPP "crParseCU"
; tokens <- lift $ mkHScan fn fh
; let (pres,perrs) = parseToResMsgs pAGItf tokens
; if null perrs
then do { let impMp = as1Imports pres
info = crStateInfo cr
; cpUpdCU modNm (rcuStoreMbOut (Just pres) . rcuStoreImpNmL (Map.keys impMp))
; modify (\cr -> (cr {crStateInfo = info {crsiImpPosMp = impMp `Map.union` crsiImpPosMp info}}))
}
else cpSetLimitErrs 5 "" (map mkPPErr perrs)
}
cpFindAndParseCU :: Maybe FPath -> Nm -> RCompilePhase ()
cpFindAndParseCU mbFp modNm
= do { cr <- get
; let opts = crsiOpts (crStateInfo cr)
cpFind mn mbFp
= do { _ <- cpFindFileForFPath fileSuffMp (optSearchPath opts) (Just mn) mbFp ; return ()}
; cpSeq [cpFind modNm mbFp, cpParseCU modNm]
}
cpFlattenAndCompileAllCU :: RCompilePhase ()
cpFlattenAndCompileAllCU
= do { cr <- get
-- ; lift $ hPutStrLn stderr (show $ crCompileOrder cr)
; let opts = crsiOpts (crStateInfo cr)
isAS2 = fmAS2Fm (optGenFM opts) /= optGenFM opts
parseRes = as1JoinAGItfs [ panicJust ("crFlattenAndCompileAllCU: " ++ show n) $ rcuMbOut $ crCU n $ cr | ns <- crCompileOrder cr, n <- ns ]
sem1Res
= M1.wrap_AGItf (M1.sem_AGItf parseRes)
(M1.Inh_AGItf
{ M1.opts_Inh_AGItf = opts {optGenFM = fmAS2Fm (optGenFM opts)}
, M1.fmGam_Inh_AGItf = fmGamFromList' FmFmtCmd [ (Nm n,Expr_Var (Nm v)) | (n,v) <- optDefs opts ]
})
hPutBld f h b = if f then hPutPPFile h b 2000 else return ()
putBld f b = hPutBld f stdout b
cpPutBld f b = lift $ putBld f b
cpPutDbg = cpPutBld (optDebug opts) (M1.pp_Syn_AGItf sem1Res)
cpMk1
= do { let t1 = M1.as2_Syn_AGItf sem1Res
((t2,_,t2errL),doPrint)
= case optGenFM opts of
FmTeX -> bld as2LaTeX
FmAG -> bld as2ARule
FmHS -> ((t1,empty,[]),True)
_ | optGenExpl opts -> ((t1,empty,[]),True)
| otherwise -> ((t1,empty,[]),False)
where bld f = (f opts (M1.dtInvGam_Syn_AGItf sem1Res) (M1.scGam_Syn_AGItf sem1Res) (M1.fmGam_Syn_AGItf sem1Res) (M1.rwGam_Syn_AGItf sem1Res) t1,True)
; cpSeq [cpSetErrs t2errL, cpPutBld doPrint (M2.ppAS2 opts (M1.fmGam_Syn_AGItf sem1Res) t2)]
}
{-
cpMk2
= cpSeq [ cpPutBld True (M1.mkPP_Syn_AGItf sem1Res (optGenFM opts))
, cpPutBld (optGenExpl opts) (M1.scExplPP_Syn_AGItf sem1Res)
]
cpMk3 f
= do { let t1 = M1.as2_Syn_AGItf sem1Res
(t2,t2ppDbg,t2errL)
= case f of
FmTeX -> as2LaTeX opts (M1.scGam_Syn_AGItf sem1Res) (M1.fmGam_Syn_AGItf sem1Res) (M1.rwGam_Syn_AGItf sem1Res) t1
FmAG -> as2ARule opts (M1.scGam_Syn_AGItf sem1Res) (M1.fmGam_Syn_AGItf sem1Res) (M1.rwGam_Syn_AGItf sem1Res) t1
; cpSeq [ cpSetErrs t2errL
, cpPutBld True t2ppDbg
, cpPutBld True (M2.ppAS2 opts t2)
, cpPutBld True (M1.mkPP_Syn_AGItf sem1Res f)
]
}
-}
; cpSeq [ cpPutDbg
, cpSetErrs (M1.errL_Syn_AGItf sem1Res)
, cpMk1
{-
, if optGenV2 opts && not isAS2
then cpMk1
else if not isAS2
then cpMk2
else case optGenFM opts of
FmAS2 f -> cpMk3 f
_ -> liftCR id
-}
]
}
compileTopLevel :: FPath -> Opts -> IO ()
compileTopLevel fp opts
= do { let topModNm = Nm (fpathBase fp)
opts' = opts { optSearchPath = mkInitSearchPath fp ++ optSearchPath opts }
cr = mkEmptyCompileRun topModNm (RCompileRunStateInfo opts' Map.empty)
; _ <- runStateT (cpSeq [ cpFindAndParseCU (Just fp) topModNm
-- , crPP "crCompileTopLevel 1"
, cpImportGather (cpFindAndParseCU Nothing) topModNm
-- , crPP "crCompileTopLevel 2"
, cpFlattenAndCompileAllCU
])
cr
; return ()
}
-------------------------------------------------------------------------
-- main
-------------------------------------------------------------------------
main :: IO ()
main
= do { args <- getArgs
; let oo@(o,n,errs) = getOpt Permute cmdLineOpts args
opts = foldr ($) defaultOpts o
optParseErrs = optErrs opts
; if optHelp opts
then putStrLn (usageInfo ("version: " ++ versionInfo ++ "\n\nUsage ruler [options] [file]\n\noptions:") cmdLineOpts)
else if optVersion opts || optSvnVersion opts
then do { let s = (if optVersion opts then versionDist else "")
++ (if optVersion opts && optSvnVersion opts then ", " else "")
++ (if optSvnVersion opts then versionSvn else "")
; putStr s
}
else if not (null errs)
then do { hPutStr stderr (head errs)
; exitFailure
}
else if not (null optParseErrs)
then do { sequence_ optParseErrs
; exitFailure
}
else compileTopLevel (if null n then emptyFPath else mkFPath (head n)) opts
}
where optErrs o = catMaybes $ map (uncurry extr) [("selrule", fmap snd . optMbRlSel'), ("markchanges", fmap snd . optMbMarkChange')]
where extr msg fld = do
e <- fld o
if null e then Nothing else return $ do
hPutPPLn stderr $ "Option '" ++ msg ++ "' parsing errors" >-< indent 2 (ppErrPPL e)
{-
doCompile :: FPath -> Opts -> IO ()
doCompile fp opts
= do { (fn,fb,fh)
<- if fpathIsEmpty fp
then return ("<stdin>","<stdin>",stdin)
else do { let fn = fpathToStr fp
; h <- openFile fn ReadMode
; return (fn,fpathToStr (fpathRemoveSuff fp),h)
}
; tokens <- mkOffScan fn fh
; let (pres,perrs) = parseOffsideToResMsgs pAGItf tokens
(showErrs,omitErrs) = splitAt 5 perrs
; putErr' (if null omitErrs then return () else hPutStrLn stderr "... and more parsing errors") (map mkPPErr showErrs)
; let res = M1.wrap_AGItf (M1.sem_AGItf pres)
(M1.Inh_AGItf
{ M1.opts_Inh_AGItf = opts {optGenFM = fmAS2Fm (optGenFM opts)}
})
putDbg = putBld (optDebug opts) (M1.pp_Syn_AGItf res)
errL = M1.errL_Syn_AGItf res
; putDbg
; putErr errL
; let isAS2 = fmAS2Fm (optGenFM opts) /= optGenFM opts
; if optGenV2 opts && not isAS2
then do { let t1 = M1.as2_Syn_AGItf res
((t2,_,t2errL),doPrint)
= case optGenFM opts of
FmTeX -> bld as2LaTeX
FmAG -> bld as2ARule
_ -> ((t1,empty,[]),False)
where bld f = (f opts (M1.scGam_Syn_AGItf res) (M1.fmGam_Syn_AGItf res) (M1.rwGam_Syn_AGItf res) t1,True)
; putErr t2errL
; putBld doPrint (M2.ppAS2 opts t2)
}
else if not isAS2
then do { putBld True (M1.mkPP_Syn_AGItf res (optGenFM opts))
; putBld (optGenExpl opts) (M1.scExplPP_Syn_AGItf res)
}
else case optGenFM opts of
FmAS2 f
-> do { putErr t2errL
; putBld True t2ppDbg
; putBld True (M2.ppAS2 opts t2)
; putBld True (M1.mkPP_Syn_AGItf res f)
}
where t1 = M1.as2_Syn_AGItf res
(t2,t2ppDbg,t2errL)
= case f of
FmTeX -> as2LaTeX opts (M1.scGam_Syn_AGItf res) (M1.fmGam_Syn_AGItf res) (M1.rwGam_Syn_AGItf res) t1
FmAG -> as2ARule opts (M1.scGam_Syn_AGItf res) (M1.fmGam_Syn_AGItf res) (M1.rwGam_Syn_AGItf res) t1
_ -> return ()
}
where hPutBld f h b = if f then hPutPPFile h b 2000 else return ()
putBld f b = hPutBld f stdout b
-- putErr' :: IO () -> [Err] -> IO ()
putErr' m e = if null e
then return ()
else do { hPutBld True stderr (ppErrPPL e)
; m
; if errLIsFatal e then exitFailure else return ()
}
-- putErr :: [Err] -> IO ()
putErr = putErr' (return ())
-}