diff --git a/ruler.cabal b/ruler.cabal --- a/ruler.cabal +++ b/ruler.cabal @@ -1,17 +1,17 @@ Name: ruler -Version: 0.4.0.2 -Copyright: Utrecht University, Department of Information and Computing Sciences, Software Technology group +Version: 0.4.1.0 +Copyright: Utrecht University, Department of Information and Computing Sciences, Software Technology group, Atze Dijkstra Description: Ruler tool used by UHC (Utrecht Haskell Compiler) Synopsis: Ruler tool for UHC Homepage: https://github.com/UU-ComputerScience/ruler Bug-Reports: https://github.com/UU-ComputerScience/ruler/issues License: BSD3 License-file: LICENSE -Author: UHC Team -Maintainer: uhc-developers@lists.science.uu.nl +Author: Atze Dijkstra +Maintainer: atzedijkstra@gmail.com Category: Development Build-Type: Custom -Cabal-Version: >= 1.8 +Cabal-Version: >= 1.23 Extra-Source-Files: demo/RulerDemoUtils.chs demo/RulerDemoMain.cag demo/rulerDemoRL.crl2 @@ -29,7 +29,9 @@ executable ruler main-is: Ruler.hs hs-source-dirs: src - extensions: FlexibleContexts, TypeSynonymInstances, FlexibleInstances, RankNTypes, MultiParamTypeClasses + default-language: Haskell2010 + default-extensions: FlexibleContexts, TypeSynonymInstances, FlexibleInstances, RankNTypes, MultiParamTypeClasses + other-modules: Paths_ruler x-shuffle-hs: --gen-reqm=1 --preamble=no --lhs2tex=no --variant-order="1" x-shuffle-ag: --gen-reqm=1 --preamble=no --lhs2tex=no --variant-order="1" x-shuffle-ag-d: data, rename @@ -68,5 +70,13 @@ mtl >= 2 && < 3, uhc-util >= 0.1.3.0, uuagc >= 0.9.42.2, - uuagc-cabal >= 1.0.4.0, - shuffle >= 0.1.0.2 + uuagc-cabal >= 1.1.0.0, + shuffle >= 0.1.0.2, + Cabal >= 2.0.0.2 + +custom-setup + setup-depends: base >= 4 && < 5, + uuagc-cabal >= 1.1.0.0, + uuagc >= 0.9.42.2, + shuffle >= 0.1.0.2, + Cabal >= 2.0.0.2 diff --git a/src/Admin.chs b/src/Admin.chs --- a/src/Admin.chs +++ b/src/Admin.chs @@ -58,9 +58,9 @@ data DtFldInfo = DtFldInfo - { dfNm :: Nm - , dfTy :: Ty - , dfSeqNr :: Int + { dfNm :: Nm + , dfTy :: Ty + , dfSeqNr :: Int } emptyDtFldInfo :: DtFldInfo @@ -80,10 +80,10 @@ data DtAltInfo = DtAltInfo - { daNm :: Nm - , daRlNm :: Nm + { daNm :: Nm + , daRlNm :: Nm , daMbOnNm :: Maybe Nm - , daFldGam :: DtFldGam + , daFldGam :: DtFldGam } emptyDtAltInfo :: DtAltInfo @@ -103,9 +103,9 @@ data DtVwInfo = DtVwInfo - { vdNm :: Nm - , vdAltGam :: DtAltGam - , vdFullAltGam :: DtAltGam + { vdNm :: Nm + , vdAltGam :: DtAltGam + , vdFullAltGam :: DtAltGam } emptyDtVwInfo :: DtVwInfo @@ -125,9 +125,9 @@ data DtInfo = DtInfo - { dtNm :: Nm - , dtScNmL :: [Nm] - , dtVwGam :: DtVwGam + { dtNm :: Nm + , dtScNmL :: [Nm] + , dtVwGam :: DtVwGam } emptyDtInfo :: DtInfo @@ -174,8 +174,8 @@ data DtAltInvInfo = DtAltInvInfo - { daiNm :: Nm - , daiAGNm :: Nm + { daiNm :: Nm + , daiAGNm :: Nm , daiMbOnNm :: Maybe Nm , daiChOrdGam :: ChOrdGam } @@ -197,8 +197,8 @@ data DtVwInvInfo = DtVwInvInfo - { vdiNm :: Nm - , vdiFullAltGam :: DtAltInvGam + { vdiNm :: Nm + , vdiFullAltGam :: DtAltInvGam } emptyDtVwInvInfo :: DtVwInvInfo @@ -218,9 +218,9 @@ data DtInvInfo = DtInvInfo - { dtiNm :: Nm - , dtiAGNm :: Nm - , dtiVwGam :: DtVwInvGam + { dtiNm :: Nm + , dtiAGNm :: Nm + , dtiVwGam :: DtVwInvGam } emptyDtInvInfo :: DtInvInfo @@ -370,8 +370,8 @@ data BldRename = BldRename - { brNmFrom :: Nm - , brNmTo :: Nm + { brNmFrom :: Nm + , brNmTo :: Nm } instance Show BldRename where @@ -633,15 +633,15 @@ data RlJdBld e = RlJdBldDirect - { rjbExtNmS :: Set.Set Nm - , rjbPreGam :: REGam e - , rjbPostGam :: REGam e + { rjbExtNmS :: Set.Set Nm + , rjbPreGam :: REGam e + , rjbPostGam :: REGam e } | RlJdBldFromRuleset - { rjbPos :: SPos - , rjbRsNm :: Nm - , rjbRlNm :: Nm - , rjbScRenameL :: [BldRename] + { rjbPos :: SPos + , rjbRsNm :: Nm + , rjbRlNm :: Nm + , rjbScRenameL :: [BldRename] } instance Show (RlJdBld e) where @@ -657,14 +657,14 @@ data VwRlInfo e = VwRlInfo - { vwrlNm :: Nm - , vwrlPos :: SPos - , vwrlJdBldL :: [RlJdBld e] - , vwrlJdBldOnAL, vwrlJdBldOnBL :: [RlJdBld e] -- for debug - , vwrlFullNoDfltPreGam, vwrlFullNoDfltPostGam :: REGam e - , vwrlFullPreGam, vwrlFullPostGam :: REGam e - , vwrlPreScc :: [[Nm]] - , vwrlMbChGam :: Maybe RlChGam + { vwrlNm :: Nm + , vwrlPos :: SPos + , vwrlJdBldL :: [RlJdBld e] + , vwrlJdBldOnAL, vwrlJdBldOnBL :: [RlJdBld e] -- for debug + , vwrlFullNoDfltPreGam, vwrlFullNoDfltPostGam :: REGam e + , vwrlFullPreGam, vwrlFullPostGam :: REGam e + , vwrlPreScc :: [[Nm]] + , vwrlMbChGam :: Maybe RlChGam , vwrlAuxGroups :: [[Nm]] } diff --git a/src/Common.chs b/src/Common.chs --- a/src/Common.chs +++ b/src/Common.chs @@ -101,11 +101,11 @@ -- Names ------------------------------------------------------------------------- -strUnd = "_" -strOverl = "_" +strUnd = "_" +strOverl = "_" strOverVec = ">" -strLhs = "lhs" -strLoc = "loc" +strLhs = "lhs" +strLoc = "loc" nmOverl, nmOverVec, nmUnk, nmApp, nmWild, nmNone, nmEql, nmComma, nmOParen, nmCParen, nmLhs, nmAny, nmSp1 :: Nm nmOverl = Nm strOverl diff --git a/src/KeywParser.chs b/src/KeywParser.chs --- a/src/KeywParser.chs +++ b/src/KeywParser.chs @@ -14,9 +14,12 @@ %%[1 hs export (keywordsOpsExplainEsc, keywordsOpsParenEsc, keywordsOps) %%] -%%[1 hs export (mkScan, mkHScan, mkOffScan) +%%[1 hs export (mkScan', mkScan, mkHScan, mkOffScan) %%] +%%[1111 hs export(patchScanOptsOption) +%%] + %%[1 hs export (pKeySPos, pNmStr, pNmStrSPos, pNmStrI, pNmStrISPos, pSymEscStr, pSymEscStrSPos, pSymStr, pSymStrSPos) %%] @@ -90,8 +93,19 @@ , scoOffsideClose = "" } +{- +patchScanOptsOption o + = o { scoOpChars = Set.delete eq $ scoOpChars o + , scoSpecChars = Set.insert eq $ scoSpecChars o + } + where eq = '=' +-} + +mkScan' :: (ScanOpts -> ScanOpts) -> FilePath -> String -> [Token] +mkScan' patch fn txt = scan (patch rulerScanOpts) (initPos fn) txt + mkScan :: FilePath -> String -> [Token] -mkScan fn txt = scan rulerScanOpts (initPos fn) txt +mkScan = mkScan' id mkHScan :: FilePath -> Handle -> IO [Token] mkHScan fn fh diff --git a/src/MkAdmin.chs b/src/MkAdmin.chs --- a/src/MkAdmin.chs +++ b/src/MkAdmin.chs @@ -36,12 +36,12 @@ %%[1 hs data BldDtState = BldDtState - { bdDtAltGam :: DtAltGam + { bdDtAltGam :: DtAltGam } emptyBldDtState = BldDtState - { bdDtAltGam = emptyGam + { bdDtAltGam = emptyGam } bldDtInfo :: DpdGr Nm -> DtInfo -> (DtInfo,[Err]) diff --git a/src/Opts.chs b/src/Opts.chs --- a/src/Opts.chs +++ b/src/Opts.chs @@ -5,14 +5,10 @@ %%[1 hs module (Opts) %%] -%%[1 hs export (Opts(..), defaultOpts, cmdLineOpts) -%%] - -%%[1 hs import (System.Console.GetOpt, UHC.Util.ParseUtils, Common, ViewSel.ViewSel, ViewSel.Self, ViewSel.Parser) +%%[1 hs import (System.Console.GetOpt, UHC.Util.ParseUtils, Common, Err, ViewSel.ViewSel, ViewSel.Self, ViewSel.Parser) %%] -%%[1 hs - +%%[1 hs export (Opts(..), defaultOpts) ------------------------------------------------------------------------- -- Options ------------------------------------------------------------------------- @@ -21,7 +17,7 @@ = Opts { optGenFM :: FmKind , optGenExpl :: Bool - , optGenV2 :: Bool + , optGenV2 :: Bool , optGenAGAttr :: Bool , optGenAGData :: Bool , optDot2Dash :: Bool @@ -36,11 +32,11 @@ , optSvnVersion :: Bool , optFragWrap :: Bool , optAGCopyElim :: Bool - , optMbMarkChange :: Maybe ViewSels - , optMbRlSel :: Maybe RlSel + , optMbMarkChange':: Maybe (ViewSels,[Err]) + , optMbRlSel' :: Maybe (RlSel,[Err]) , optBaseNm :: String , optSearchPath :: [String] - , optDefs :: [(String,String)] + , optDefs :: [(String,String)] } deriving Show @@ -63,13 +59,20 @@ , optSvnVersion = False , optFragWrap = False , optAGCopyElim = True - , optMbMarkChange = Nothing - , optMbRlSel = Nothing + , optMbMarkChange'= Nothing + , optMbRlSel' = Nothing , optBaseNm = rulesCmdPre , optSearchPath = [] - , optDefs = [] + , optDefs = [] } +%%] +%%[1 hs export(optMbRlSel, optMbMarkChange) +optMbRlSel = fmap fst . optMbRlSel' +optMbMarkChange = fmap fst . optMbMarkChange' +%%] + +%%[1 hs export(cmdLineOpts) cmdLineOpts = [ Option "a" ["ag"] (NoArg oGenAG) "generate code for AG, default=no" @@ -144,8 +147,14 @@ oDef s o = case break (\c -> c == ':' || c == '=') s of (s1,(_:s2)) -> o {optDefs = (s1,s2) : optDefs o} _ -> o - oMarkCh ms o = o {optMbMarkChange = fmap (viewSelsSelfT . fst . parseToResMsgs pViewSels . mkScan "") ms} - oRlSel ms o = o {optMbRlSel = fmap (rlSelSelfT . fst . parseToResMsgs pRlSel . mkScan "") ms} + -- oMarkCh ms o = o {optMbMarkChange = fmap (viewSelsSelfT . fst . parseToResMsgs pViewSels . mkScan "") ms} + oMarkCh ms o = o {optMbMarkChange' = parseWithErr pViewSels viewSelsSelfT ms} + -- oRlSel ms o = o {optMbRlSel = fmap (rlSelSelfT . fst . parseToResMsgs pRlSel . mkScan "") ms} + oRlSel ms o = o {optMbRlSel' = parseWithErr pRlSel rlSelSelfT ms} + parseWithErr p upd ms = do + s <- ms + let (r,e) = parseToResMsgs p $ mkScan "" s + return (upd r, map mkPPErr e) yesno updO ms o = case ms of Just "yes" -> updO True o Just "no" -> updO False o diff --git a/src/Parser.chs b/src/Parser.chs --- a/src/Parser.chs +++ b/src/Parser.chs @@ -30,7 +30,7 @@ ------------------------------------------------------------------------- type RulerParser ep - = (IsParser (OffsideParser i o Token p) Token,InputState i Token p, OutputState o, Position p) + = forall i o p . (IsParser (OffsideParser i o Token p) Token,InputState i Token p, OutputState o, Position p) => OffsideParser i o Token p ep {- type RulerParser ep diff --git a/src/Ruler.chs b/src/Ruler.chs deleted file mode 100644 --- a/src/Ruler.chs +++ /dev/null @@ -1,338 +0,0 @@ -------------------------------------------------------------------------- --- Main -------------------------------------------------------------------------- - -%%[1 hs module(Main) -%%] - -%%[1 hs import (System.IO, System.Environment, System.Exit, Control.Monad.State, qualified Data.Map as Map) -%%] - -%%[1 hs import (System.Console.GetOpt, UHC.Util.Pretty, UHC.Util.Utils( panicJust )) -%%] - -%%[1 hs import (UHC.Util.ParseUtils, UHC.Util.ParseErrPrettyPrint, UHC.Util.CompileRun) -%%] - -%%[1 hs import (Version, Err, Gam( emptyGam ), Common, Opts) -%%] - -%%[1 hs import (qualified AbsSyn.AbsSyn1 as AS1) -%%] - -%%[1 hs import (qualified Main1AG as M1) -%%] - -%%[1 hs import (qualified Main2AG as M2) -%%] - -%%[1 hs import (AS1.Imports, TrfAS2.GenARule, TrfAS2.GenLaTeX, KeywParser) -%%] - -%%[1 hs import (Parser, Expr.Expr, FmGam) -%%] - - -%%[1 hs - -------------------------------------------------------------------------- --- 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) - 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 - ; 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 null errs - -- then doCompile (if null n then emptyFPath else mkFPath (head n)) opts - then compileTopLevel (if null n then emptyFPath else mkFPath (head n)) opts - else do hPutStr stderr (head errs) - exitFailure - } - -{- -doCompile :: FPath -> Opts -> IO () -doCompile fp opts - = do { (fn,fb,fh) - <- if fpathIsEmpty fp - then return ("","",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 ()) --} - -%%] diff --git a/src/Ruler.hs b/src/Ruler.hs new file mode 100644 --- /dev/null +++ b/src/Ruler.hs @@ -0,0 +1,348 @@ +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) + 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) + 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 ()) +-} + +