ruler 0.4.0.2 → 0.4.1.0
raw patch · 9 files changed
+449/−406 lines, 9 filesdep +Cabaldep ~uuagc-cabal
Dependencies added: Cabal
Dependency ranges changed: uuagc-cabal
Files
- ruler.cabal +18/−8
- src/Admin.chs +36/−36
- src/Common.chs +4/−4
- src/KeywParser.chs +16/−2
- src/MkAdmin.chs +2/−2
- src/Opts.chs +24/−15
- src/Parser.chs +1/−1
- src/Ruler.chs +0/−338
- src/Ruler.hs +348/−0
ruler.cabal view
@@ -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
src/Admin.chs view
@@ -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]] }
src/Common.chs view
@@ -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
src/KeywParser.chs view
@@ -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
src/MkAdmin.chs view
@@ -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])
src/Opts.chs view
@@ -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
src/Parser.chs view
@@ -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
− src/Ruler.chs
@@ -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>","<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- ; 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>","<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 ())--}--%%]
+ src/Ruler.hs view
@@ -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>","<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 ())+-}++