diff --git a/hat.cabal b/hat.cabal --- a/hat.cabal +++ b/hat.cabal @@ -1,6 +1,6 @@ name: hat -version: 2.9.0.0 +version: 2.9.1 synopsis: The Haskell tracer, generating and viewing Haskell execution traces description: hat-trans transforms Module.hs into Hat/Module.hs such that when the program is @@ -48,11 +48,11 @@ homepage: http://projects.haskell.org/hat/ license: OtherLicense license-file: docs/copyright.html -copyright: (c) 2000-2015 Hat team +copyright: (c) 2000-2017 Hat team author: Hat team maintainer: oc@kent.ac.uk stability: provisional -tested-with: GHC ==7.8.3 +tested-with: GHC ==8.0.1 bug-reports: oc@kent.ac.uk category: Development build-type: Simple @@ -68,19 +68,20 @@ library exposed-modules: Hat.Array, Hat.Char, Hat.Complex, Hat.CPUTime, Hat.Directory, Hat.Hack, Hat.Hat, Hat.IO, Hat.Ix, Hat.List, Hat.Locale, Hat.Maybe, Hat.Monad, Hat.Numeric, Hat.Prelude, Hat.PreludeBasic, Hat.PreludeBuiltinTypes, Hat.Random, Hat.Ratio, Hat.System, Hat.Time, Hat.Control.Monad, Hat.Data.Char, Hat.Data.Maybe, Hat.Data.List, Hat.System.Environment, Hat.System.Exit, Hat.System.IO - build-depends: base >=4.5 && < 5, directory >=1.1, random >=1.0, process >=1.1, old-time >=1.1, old-locale >=1.0 + build-depends: base >=4.9 && < 5, directory >=1.1, random >=1.0, process >=1.1, old-time >=1.1, old-locale >=1.0 other-modules: Hat.DirectoryBuiltin, Hat.DirectoryBuiltinTypes, Hat.IOBuiltin, Hat.IOBuiltinTypes, Hat.PreludeBuiltin, Hat.RandomBuiltin, Hat.SystemBuiltin, Hat.SystemBuiltinTypes, Hat.TimeBuiltin, Hat.TimeBuiltinTypes extensions: ForeignFunctionInterface includes: hat-c.h, art.h, ntohl.h include-dirs: include, Hat c-sources: Hat/hat-c.c cc-options: -DFILEVERSION="2.08" + ghc-options: -w executable hat-trans main-is: HatTrans.hs hs-source-dirs: trans other-modules: Wired, SynHelp, Relation, Wrap, Flags, Environment, AuxFile, Derive, TraceTrans, HatTrans - build-depends: base >=4.5, bytestring >=0.9, directory >=1.1, haskell-src-exts >= 1.16, containers >= 0.5.2, filepath >= 1.3 + build-depends: base >=4.9, bytestring >=0.9, directory >=1.1, haskell-src-exts >= 1.18 && < 1.19, containers >= 0.5.2, filepath >= 1.3 includes: hat-c.h, art.h, ntohl.h include-dirs: include, Hat c-sources: Hat/hat-c.c @@ -90,7 +91,7 @@ main-is: HatTrail.hs hs-source-dirs: tools other-modules: LowLevel, SrcRef, Ident, SExp, PrettyLibHighlight, HighlightStyle, CommonUI - build-depends: base >=4.5, containers >=0.4, directory >=1.1, process >=1.1 + build-depends: base >=4.9, containers >=0.4, directory >=1.1, process >=1.1 extensions: ForeignFunctionInterface includes: art.h include-dirs: include @@ -101,7 +102,7 @@ main-is: HatObserve.hs hs-source-dirs: tools other-modules: Observe, LowLevel, SExp, Ident, PrettyLibHighlight, HighlightStyle, Pattern, Idents, CmdLine, CommonUI, SrcRef, Trie, TExp - build-depends: base >=4.5, process >=1.1, haskeline >=0.6, polyparse >= 1.11 + build-depends: base >=4.9, process >=1.1, haskeline >=0.6, polyparse >= 1.11 extensions: ForeignFunctionInterface includes: art.h include-dirs: include @@ -112,7 +113,7 @@ main-is: HatStackText.hs hs-source-dirs: tools other-modules: HatStack, LowLevel, SExp, PrettyLibHighlight, HighlightStyle, Ident, SrcRef, CommonUI - build-depends: base >=4.5, process >=1.1 + build-depends: base >=4.9, process >=1.1 extensions: ForeignFunctionInterface includes: art.h include-dirs: include @@ -123,7 +124,7 @@ main-is: HatExplore.hs hs-source-dirs: tools other-modules: Explore, CommonUI, HighlightStyle, LowLevel, Ident, SrcRef, SExp, Detect, NodeExp, Slice, ADT, Detect, PrettyLibHighlight - build-depends: base >=4.5, process >=1.1 + build-depends: base >=4.9, process >=1.1 extensions: ForeignFunctionInterface includes: art.h include-dirs: include @@ -134,8 +135,8 @@ -- currently just calls hat-delta; was a separate tool main-is: HatDetect.hs hs-source-dirs: tools - other-modules: LowLevel, SExp, TExp, HighlightStyle, CommonUI, SrcRef - build-depends: base >=4.5, directory >=1.1, process >=1.1, haskeline >=0.6 + other-modules: LowLevel, SExp, TExp, HighlightStyle, CommonUI, SrcRef, CmdLine, Detect, Ident, PrettyLibHighlight + build-depends: base >=4.9, directory >=1.1, process >=1.1, haskeline >=0.6 extensions: ForeignFunctionInterface includes: art.h, ntohl.h include-dirs: include @@ -145,7 +146,7 @@ executable hat-check main-is: HatCheck.hs hs-source-dirs: tools - build-depends: base >=4.5, process >=1.1 + build-depends: base >=4.9, process >=1.1 extensions: ForeignFunctionInterface includes: art.h, ntohl.h include-dirs: include @@ -156,7 +157,7 @@ main-is: SrcRefViewer.hs hs-source-dirs: tools other-modules: HighlightStyle, Run - build-depends: base >=4.5, process >=1.1, directory >=1.1 + build-depends: base >=4.9, process >=1.1, directory >=1.1 extensions: ForeignFunctionInterface includes: art.h, ntohl.h include-dirs: include @@ -165,8 +166,8 @@ -- builds, but doesn't seem to work main-is: HatCoverText.hs hs-source-dirs: tools - other-modules: HatCover, LowLevel, SrcRef, HighlightStyle - build-depends: base >=4.5, process >=1.1 + other-modules: HatCover, LowLevel, SrcRef, HighlightStyle, Ident + build-depends: base >=4.9, process >=1.1 extensions: ForeignFunctionInterface includes: art.h, ntohl.h include-dirs: include @@ -176,8 +177,8 @@ executable black-hat main-is: BlackHat.hs hs-source-dirs: tools - other-modules: LowLevel, SExp, PrettyLibHighlight, HighlightStyle, Run, NonTermLib - build-depends: base >=4.5, process >=1.1 + other-modules: LowLevel, SExp, PrettyLibHighlight, HighlightStyle, Run, NonTermLib, CommonUI, Ident, SrcRef + build-depends: base >=4.9, process >=1.1, directory >= 1.2 extensions: ForeignFunctionInterface includes: art.h, ntohl.h include-dirs: include @@ -187,8 +188,8 @@ executable hat-nonterm main-is: HatNonTerm.hs hs-source-dirs: tools - other-modules: LowLevel, SExp, PrettyLibHighlight, HighlightStyle, Run, NonTermLib - build-depends: base >=4.5, process >=1.1 + other-modules: LowLevel, SExp, PrettyLibHighlight, HighlightStyle, Run, NonTermLib, CommonUI, Ident, SrcRef + build-depends: base >=4.9, process >=1.1 extensions: ForeignFunctionInterface includes: art.h, ntohl.h include-dirs: include @@ -198,8 +199,8 @@ executable hat-anim main-is: HatAnim.hs hs-source-dirs: tools - other-modules: NodeExp, Pretty, CommonUI, LowLevel, HighlightStyle - build-depends: base >=4.5, process >=1.1, containers >=0.4 + other-modules: NodeExp, Pretty, CommonUI, LowLevel, HighlightStyle, ADT, Delta, EDT, Explore, Ident, PrettyLibHighlight, SExp, Slice, SrcRef + build-depends: base >=4.9, process >=1.1, containers >=0.4 extensions: ForeignFunctionInterface includes: art.h, ntohl.h include-dirs: include @@ -209,8 +210,8 @@ executable pretty-hat main-is: PrettyHat.hs hs-source-dirs: tools - other-modules: Pretty, NodeExp, EDT, HighlightStyle, Delta, Slice, ADT, Explore, SExp, CommonUI, SrcRef, Ident, LowLevel, PrettyLibHighlight - build-depends: base >=4.5, process >=1.1, containers >=0.4 + other-modules: Pretty, NodeExp, EDT, HighlightStyle, Delta, Slice, ADT, Explore, SExp, CommonUI, SrcRef, Ident, LowLevel, PrettyLibHighlight, Detect + build-depends: base >=4.9, process >=1.1, containers >=0.4 extensions: ForeignFunctionInterface includes: art.h, ntohl.h include-dirs: include @@ -221,7 +222,7 @@ main-is: HatDelta.hs hs-source-dirs: tools other-modules: Pretty, Slice, LowLevel, CommonUI, NodeExp, SExp, ADT, EDT, SrcRef, FDT, Delta, Explore, HighlightStyle, PrettyLibHighlight, Ident - build-depends: base >=4.5, process >=1.1, containers >=0.4 + build-depends: base >=4.9, process >=1.1, containers >=0.4 extensions: ForeignFunctionInterface includes: art.h, ntohl.h include-dirs: include @@ -232,4 +233,4 @@ executable hat-make main-is: HatMake.hs hs-source-dirs: tools - build-depends: base >=4.5, process >=1.1, directory >=1.1 + build-depends: base >=4.9, process >=1.1, directory >=1.1 diff --git a/include/ntohl.h b/include/ntohl.h --- a/include/ntohl.h +++ b/include/ntohl.h @@ -2,6 +2,7 @@ #if defined(WIN32) /* Windows does not have ntohl, so define it here */ +#include #define htonl(x) ntohl(x) uint32_t ntohl(uint32_t x); diff --git a/tools/BlackHat.hs b/tools/BlackHat.hs --- a/tools/BlackHat.hs +++ b/tools/BlackHat.hs @@ -35,11 +35,11 @@ where showPath state | bhpath == [] = do putStr (progname state) - putStrLn (": no black hole found") + putStrLn (": no black hole found") exitWith (ExitFailure 1) - | (showNode state) = mapIO putStrLn - (inter (map (showSctx state) bhpath) - (map show bhpath) ) + | (showNode state) = mapIO putStrLn + (inter (map (showSctx state) bhpath) + (map show bhpath) ) | otherwise = mapIO (putStrLn . showSctx state ) bhpath where bhpath = blackHoleSearch state getRootNode @@ -52,7 +52,7 @@ | msg `isPrefixOf` "<>" = return () | otherwise = do hPutStrLn stderr ((progname state) ++": error is not a loop") - exitWith (ExitFailure 1) + exitWith (ExitFailure 1) checkHelp args | member "--help" args = do showHelp exitWith ExitSuccess @@ -61,16 +61,16 @@ getHatName args = case args of (f:_) -> return f _ -> do hPutStrLn stderr - ("black-hat: no trace file") - showHelpShort + ("black-hat: no trace file") + showHelpShort exitWith (ExitFailure 1) showHelpShort = putStrLn "Usage: black-hat [PROGNAME] [OPTIONS]..." showHelp = do showHelpShort putStrLn " --showqual={t,f} Show function module names" - putStrLn " --showrt={t,f} Show all nodes from the root node" - putStrLn " --srcref={t,f} Show source references for nodes" + putStrLn " --showrt={t,f} Show all nodes from the root node" + putStrLn " --srcref={t,f} Show source references for nodes" putStrLn " --cutoff= Cutoff expression at depth " @@ -119,7 +119,7 @@ incMember m [] = False incMember m (y:ys) | (showCount state) && incrementCount 1 && m == y = True - | m == y = True + | m == y = True | otherwise = incMember m ys -- call the function on the node's result @@ -133,36 +133,36 @@ searchChildren (ch:rest) | childpath /= [] = (childnode, childpath) | otherwise = searchChildren rest where - (childnode, childpath) = blackHoleSearchAux state chsctx path - chsctx = (ch:currnode:stack) + (childnode, childpath) = blackHoleSearchAux state chsctx path + chsctx = (ch:currnode:stack) -- This function indicates if the search process should fail and -- backtrack when it reaches a node. -haltAtNode node | node <= (FileNode 4) = True - | ntype == ExpApp = False - | ntype == ExpValueApp = False - | ntype == ExpValueUse = False - | ntype == ExpConstUse = False - | ntype == ExpConstDef = False - | ntype == ExpGuard = False - | ntype == ExpCase = False - | ntype == ExpIf = False - | ntype == ExpForward = False - | ntype == ExpProjection = False - | ntype == Module = True - | ntype == SrcPos = True - | ntype == ExpChar = True - | ntype == ExpInt = True - | ntype == ExpInteger = True - | ntype == ExpRat = True - | ntype == ExpRational = True - | ntype == ExpFloat = True - | ntype == ExpDouble = True - | ntype == ExpFieldUpdate = True - | ntype == ExpHidden = True - | ntype == ExpDoStmt = True - | ntype == AtomVariable = True - | ntype == AtomConstructor = True - | ntype == AtomAbstract = True +haltAtNode node | node <= (FileNode 4) = True + | ntype == ExpApp = False + | ntype == ExpValueApp = False + | ntype == ExpValueUse = False + | ntype == ExpConstUse = False + | ntype == ExpConstDef = False + | ntype == ExpGuard = False + | ntype == ExpCase = False + | ntype == ExpIf = False + | ntype == ExpForward = False + | ntype == ExpProjection = False + | ntype == Module = True + | ntype == SrcPos = True + | ntype == ExpChar = True + | ntype == ExpInt = True + | ntype == ExpInteger = True + | ntype == ExpRat = True + | ntype == ExpRational = True + | ntype == ExpFloat = True + | ntype == ExpDouble = True + | ntype == ExpFieldUpdate = True + | ntype == ExpHidden = True + | ntype == ExpDoStmt = True + | ntype == AtomVariable = True + | ntype == AtomConstructor = True + | ntype == AtomAbstract = True where ntype = nodeType node diff --git a/tools/CommonUI.hs b/tools/CommonUI.hs --- a/tools/CommonUI.hs +++ b/tools/CommonUI.hs @@ -8,11 +8,11 @@ , optionsUpdate, showOption, showOnOff ) where -import Data.List (isPrefixOf,isSuffixOf,intersperse) -import Data.Char (isDigit,digitToInt) -import Numeric (readDec) -import LowLevel (FileNode(..)) -import HighlightStyle (highlight,Highlight(..)) +import Data.List (isPrefixOf,isSuffixOf,intersperse) +import Data.Char (isDigit,digitToInt) +import Numeric (readDec) +import LowLevel (FileNode(..)) +import HighlightStyle (highlight,Highlight(..)) import SrcRef (SrcRef(..)) -- Links to other hat-tools @@ -61,33 +61,33 @@ -- User-changeable display options data Options = Options - { cutoffDepth :: Int -- expression auto-cutoff depth - , unevalMode :: Bool -- show unevaluated stuff in full? - , stringSugar :: Bool -- show strings with sugar? - , listSugar :: Bool -- show lists with sugar? - , recursiveMode :: Bool -- - , colourBracks :: Bool - , equations :: Bool -- always show equations? - , showQual :: Bool -- show identifiers qualified? - , filterMode :: Keep -- show duplicate equations? - } + { cutoffDepth :: Int -- expression auto-cutoff depth + , unevalMode :: Bool -- show unevaluated stuff in full? + , stringSugar :: Bool -- show strings with sugar? + , listSugar :: Bool -- show lists with sugar? + , recursiveMode :: Bool -- + , colourBracks :: Bool + , equations :: Bool -- always show equations? + , showQual :: Bool -- show identifiers qualified? + , filterMode :: Keep -- show duplicate equations? + } initialOptions = Options - { cutoffDepth = 10 - , unevalMode = False - , stringSugar = True - , listSugar = True - , recursiveMode = True - , colourBracks = False - , equations = True - , showQual = False - , filterMode = Unique - } + { cutoffDepth = 10 + , unevalMode = False + , stringSugar = True + , listSugar = True + , recursiveMode = True + , colourBracks = False + , equations = True + , showQual = False + , filterMode = Unique + } -- Command interpreter for setting display options data OptionCmd - = Uneval Bool | Strings Bool | Lists Bool | Recursive Bool - | CutOff Int | Deeper Int | Shallower Int | Qualify Bool - | Filter Keep | Equations Bool + = Uneval Bool | Strings Bool | Lists Bool | Recursive Bool + | CutOff Int | Deeper Int | Shallower Int | Qualify Bool + | Filter Keep | Equations Bool optionCmd :: [String] -> Maybe OptionCmd optionCmd (s:ss) @@ -134,7 +134,7 @@ optionsUpdate (CutOff n) opts = opts { cutoffDepth = n } optionsUpdate (Deeper n) opts = opts { cutoffDepth = cutoffDepth opts + n } optionsUpdate (Shallower n) opts = opts { cutoffDepth = - max (cutoffDepth opts - n) 1 } + max (cutoffDepth opts - n) 1 } optionsUpdate (Qualify b) opts = opts { showQual = b } optionsUpdate (Filter k) opts = opts { filterMode = k } optionsUpdate (Equations b) opts = opts { equations = b } diff --git a/tools/Delta.hs b/tools/Delta.hs --- a/tools/Delta.hs +++ b/tools/Delta.hs @@ -35,7 +35,7 @@ import NodeExp (NodeExp(..),fullEval,flatEval,getNode,nodeExp2SExp ,removeResultCycles,nodeExpForNode,removeNonResultCycles ,fullEvalText,flatEvalText,children,finalResult,children) -import SrcRef (readSrcRef) +import SrcRef (readSrcRef) import Slice (Slice(..),sliceStartLine,sliceEndLine,sliceFile,offsetSlice ,highlightSlice,makeSlice,srcRef2Slice,RangeOrd(..)) @@ -332,7 +332,7 @@ candidate ps = do c <- nextChild ps -- putStrLn ("edtNextChild: "++showHex (int c) "") - if c==LowLevel.unevaluated -- actually EOF + if c==LowLevel.unevaluated -- actually EOF then return LowLevel.nil else if c==LowLevel.nil then candidate ps diff --git a/tools/Detect.hs b/tools/Detect.hs --- a/tools/Detect.hs +++ b/tools/Detect.hs @@ -39,7 +39,7 @@ candidate ps = do c <- nextChild ps -- putStrLn ("edtNextChild: "++showHex (int c) "") - if c==LowLevel.unevaluated -- actually EOF + if c==LowLevel.unevaluated -- actually EOF then return LowLevel.nil else if c==LowLevel.nil then candidate ps diff --git a/tools/HatAnim.hs b/tools/HatAnim.hs --- a/tools/HatAnim.hs +++ b/tools/HatAnim.hs @@ -1,4 +1,4 @@ -module Main where -- HatAnim main program +module Main where -- HatAnim main program import Data.Char (toLower) import LowLevel (openHatFile,getBridgeValue,hatVersionNumber diff --git a/tools/HatCover.hs b/tools/HatCover.hs --- a/tools/HatCover.hs +++ b/tools/HatCover.hs @@ -86,8 +86,8 @@ let srs = [ convert sr | (fn,nt) <- nodes, isCover nt, let srn = getSrcRef fn, srn /= FileNode 0, - let sr = readSrcRef srn, line sr /= 0, - null moduleNames || filename sr `elem` moduleNames ] + let sr = readSrcRef srn, line sr /= 0, + null moduleNames || filename sr `elem` moduleNames ] return [(a, flatten b) | (a,b) <- addAll srs []] diff --git a/tools/HatDetect.hs b/tools/HatDetect.hs --- a/tools/HatDetect.hs +++ b/tools/HatDetect.hs @@ -1,18 +1,18 @@ -import LowLevel (FileNode(..),nil,hatVersionNumber,openHatFile - ,getSrcRef,getDefnRef) +import LowLevel (FileNode(..),nil,hatVersionNumber,openHatFile + ,getSrcRef,getDefnRef) import qualified SrcRef (SrcRef(..), readSrcRef) -import SExp (prettyEquation) -import TExp (TExp,linearise) -import HighlightStyle (highlight,Highlight(..),Colour(..),getTerminalSize) +import SExp (prettyEquation) +import TExp (TExp,linearise) +import HighlightStyle (highlight,Highlight(..),Colour(..),getTerminalSize) import Foreign.C.String (withCString) import Numeric (showHex) import System.IO.Unsafe (unsafePerformIO) -import Detect (findMain,edtNextChild,ParentSet,newParentSet,anySuspect) -import CmdLine (initialize,cmdline) -import CommonUI (hatObserve,hatTrail,hatAnim,hatView,shortHelpText - ,Options(..),initialOptions,Keep(..) - ,OptionCmd(..),optionCmd,onOff,number,safeReadInt - ,optionsUpdate,showOption,showOnOff) +import Detect (findMain,edtNextChild,ParentSet,newParentSet,anySuspect) +import CmdLine (initialize,cmdline) +import CommonUI (hatObserve,hatTrail,hatAnim,hatView,shortHelpText + ,Options(..),initialOptions,Keep(..) + ,OptionCmd(..),optionCmd,onOff,number,safeReadInt + ,optionsUpdate,showOption,showOnOff) import Data.Maybe import System.Environment (getArgs,getProgName) import System.Exit (exitWith,ExitCode(..)) @@ -36,34 +36,34 @@ ----------------------------------------------------------------------- -- type for state of session data State = State - { filename :: FilePath -- .hat file name - , treePath :: [ParentSet] -- path to here through EDT (head=here) - , currentNode :: FileNode -- location of current equation --- , children :: [FileNode] -- current EDT children --- , recentNodes :: [(FileNode, LinExpr, Bool)] -- already considered nodes - , trusted :: [FileNode] -- trusted fun-identifiers - , postponed :: [(Int,FileNode)]-- postponed questions - , questnumber :: Int -- current question number - , screenWidth :: Int -- for pretty-printing - , options :: Options -- user-configurable display options - , memoMode :: Bool -- memoizeMode - , reconsider :: Bool -- True when reconsidering a - } -- postponed question + { filename :: FilePath -- .hat file name + , treePath :: [ParentSet] -- path to here through EDT (head=here) + , currentNode :: FileNode -- location of current equation +-- , children :: [FileNode] -- current EDT children +-- , recentNodes :: [(FileNode, LinExpr, Bool)] -- already considered nodes + , trusted :: [FileNode] -- trusted fun-identifiers + , postponed :: [(Int,FileNode)]-- postponed questions + , questnumber :: Int -- current question number + , screenWidth :: Int -- for pretty-printing + , options :: Options -- user-configurable display options + , memoMode :: Bool -- memoizeMode + , reconsider :: Bool -- True when reconsidering a + } -- postponed question initialState :: FilePath -> ParentSet -> State initialState file start = State - { filename = file - , treePath = [start] - , currentNode = LowLevel.nil --- , children = [start] --- , recentNodes = [] - , trusted = [] - , postponed = [] - , questnumber = 1 - , screenWidth = 80 - , options = initialOptions - , memoMode = True - , reconsider = False - } + { filename = file + , treePath = [start] + , currentNode = LowLevel.nil +-- , children = [start] +-- , recentNodes = [] + , trusted = [] + , postponed = [] + , questnumber = 1 + , screenWidth = 80 + , options = initialOptions + , memoMode = True + , reconsider = False + } setState :: Mode -> State -> State setState (O o) state = state {options=optionsUpdate o (options state)} @@ -86,7 +86,7 @@ putStrLn ("\n hat-detect "++hatVersionNumber ++" ("++shortHelpText++")\n") (width,_) <- getTerminalSize - CmdLine.initialize -- for readline functionality + CmdLine.initialize -- for readline functionality let hatFile = rectify (arguments!!0) prog <- System.Environment.getProgName withCString prog (\p-> withCString hatFile (openHatFile p)) @@ -164,7 +164,7 @@ (options state) c) interactive node ps state { currentNode = c - , questnumber = questnumber state +1 } + , questnumber = questnumber state +1 } {- interactive :: State -> IO (Bool,Int,State) @@ -215,7 +215,7 @@ , O (CutOff 0), O (Filter All) ] interactive n ps state doCommand (Set mode) n ps state = - do let state' = setState mode state + do let state' = setState mode state putStrLn (showState mode state') interactive n ps state' ---- @@ -229,13 +229,13 @@ putStrLn (showExpression trustFun " Ok, \"" ++ "\" is trusted from now on.") (b,q,state') <- interactive n ps state - {recentNodes = addToRecentNodes + {recentNodes = addToRecentNodes (recentNodes state) child True - ,trusted = trustFun:trusted state - ,questnumber = questnumber state + 1 - ,reconsider = False - } + ,trusted = trustFun:trusted state + ,questnumber = questnumber state + 1 + ,reconsider = False + } if q/=questnumber state then return (b,q,state') else interactive n ps state { options = options state' , memoMode = memoMode state' @@ -248,64 +248,64 @@ ---- answering the question: yes, no, ?yes, or ?no doCommand (Answer Yes) n ps state = - askQuestion n ps state -- look for next sibling + askQuestion n ps state -- look for next sibling doCommand (Answer No) n ps state = do let c = currentNode state - p <- newParentSet c -- descend into this subtree + p <- newParentSet c -- descend into this subtree askQuestion c p state {treePath=(p:treePath state)} {- doCommand (Answer Yes) n ps state = do let child = head (children state) (b,q,state') <- interactive n ps state - { children = tail (children state) - , recentNodes = addToRecentNodes - (recentNodes state) - child True - , questnumber = questnumber state + 1 - , reconsider = False - } + { children = tail (children state) + , recentNodes = addToRecentNodes + (recentNodes state) + child True + , questnumber = questnumber state + 1 + , reconsider = False + } if q/=questnumber state then return (b,q,state') - else interactive n ps state { options = state' + else interactive n ps state { options = state' , memoMode = memoMode state' , reconsider = False } doCommand (Answer QueryYes) n ps state = do let child = head (children state) (b,q,state') <- interactive n ps state - { children = tail (children state) - , postponed = postponed state ++ - [(questnumber state,child)] - , questnumber = questnumber state + 1 - , reconsider = False - } + { children = tail (children state) + , postponed = postponed state ++ + [(questnumber state,child)] + , questnumber = questnumber state + 1 + , reconsider = False + } if q/=questnumber state then return (b,q,state') - else interactive n state ps { options = options state' + else interactive n state ps { options = options state' , memoMode = memoMode state' , reconsider = False } doCommand (Answer No) n ps state = do let child = head (children state) - newchildren = edtChildren child + newchildren = edtChildren child (b,q,state') <- interactive n ps state - { children = newchildren - , recentNodes = addToRecentNodes - (recentNodes state) - child False - , postponed = [] - , questnumber = questnumber state + 1 - , reconsider = False - } + { children = newchildren + , recentNodes = addToRecentNodes + (recentNodes state) + child False + , postponed = [] + , questnumber = questnumber state + 1 + , reconsider = False + } if q==questnumber state then - interactive n ps state { options = options state' + interactive n ps state { options = options state' , memoMode = memoMode state' , reconsider = False } else if b && q==0 then do let lmo = hatLeftmost child - src = if isInvalidNode lmo then HatNoSourceRef + src = if isInvalidNode lmo then HatNoSourceRef else hatSourceRef lmo putStrLn ("\nErroneous reduction:\n" - ++ highlight [Foreground Blue] + ++ highlight [Foreground Blue] (prettyEquation "" "" (screenWidth state) (options state) @@ -313,70 +313,70 @@ ++ showExpression lmo "\nBug found within the body of function: \"" ++ "\"\n" - ++ "line "++show (row src)++", column " - ++ show (column src) - ++ " in module \"" ++ moduleName src - ++ "\", file: \"" ++ moduleFile src ++"\"") - putStr ("\n:q to quit, any other key to go back to question " + ++ "line "++show (row src)++", column " + ++ show (column src) + ++ " in module \"" ++ moduleName src + ++ "\", file: \"" ++ moduleFile src ++"\"") + putStr ("\n:q to quit, any other key to go back to question " ++ show (questnumber state) ++": ") - cmd <- getCommand "hat-detect> " - case cmd of + cmd <- getCommand "hat-detect> " + case cmd of Quit -> return (False,-1,state') _ -> interactive state - else return (b,q,state') + else return (b,q,state') doCommand (Answer QueryNo) n ps state | not (reconsider state) = do let child = head (children state) - newchildren = edtChildren child + newchildren = edtChildren child (b,q,state') <- interactive n ps state - { children = newchildren - , recentNodes = addToRecentNodes - (recentNodes state) - child False - , postponed = [] - , questnumber = questnumber state + 1 - , reconsider = False - } + { children = newchildren + , recentNodes = addToRecentNodes + (recentNodes state) + child False + , postponed = [] + , questnumber = questnumber state + 1 + , reconsider = False + } if q==questnumber state then - interactive n ps state { options = options state' + interactive n ps state { options = options state' , memoMode = memoMode state' , reconsider = False } else if b && q==0 then - interactive n ps state { options = options state' + interactive n ps state { options = options state' , trusted = trusted state' , memoMode = memoMode state' , reconsider = True } - else return (b,q,state') + else return (b,q,state') doCommand (Answer QueryNo) n ps state | reconsider state = do putStrLn ("The question has already been deferred once.\n\ \You must answer it now with y/y?/n ") interactive n ps state doCommand (AskQuestion q) n ps state = if q>0 && q return Quit | cmd `isPrefixOf` "help" -> return (Help (unwords ss)) | cmd `isPrefixOf` "observe" -> - return (StartTool (Observe (unwords ss))) + return (StartTool (Observe (unwords ss))) | cmd `isPrefixOf` "trail" -> - return (StartTool Trail) + return (StartTool Trail) | cmd `isPrefixOf` "animate" -> - return (StartTool Anim) + return (StartTool Anim) | cmd `isPrefixOf` "detect" -> - return (number (StartTool . Detect) ss 0) + return (number (StartTool . Detect) ss 0) | cmd `isPrefixOf` "trust" -> return Trust | cmd `isPrefixOf` "untrust" -> return Untrust | cmd `isPrefixOf` "children" -> return Children diff --git a/tools/HatMake.hs b/tools/HatMake.hs --- a/tools/HatMake.hs +++ b/tools/HatMake.hs @@ -8,13 +8,16 @@ import System.Exit (ExitCode(..), exitFailure) import Data.List (nub, partition, isPrefixOf, intersperse, concat) import Data.Char (isSpace) +import Data.Maybe (fromJust) import System.Directory (doesFileExist, findExecutable) import Control.Monad (when) main = do x <- getArgs - Just hatPath <- findExecutable "hat-make" - let hatFolder = dropFilename hatPath + hatPath <- findExecutable "hat-make" + when (hatPath == Nothing) $ do + error("Cannot find hat-make in system path. Aborting!") + let hatFolder = dropFilename (fromJust hatPath) when (null x) (error "Please give the name of the file to hat-make on the command line") let opts = init x let optStr = concat (intersperse " " opts) diff --git a/tools/HatNonTerm.hs b/tools/HatNonTerm.hs --- a/tools/HatNonTerm.hs +++ b/tools/HatNonTerm.hs @@ -52,15 +52,15 @@ | otherwise = putStrLn ("suspicious function is " ++ getFuncName targetfunc ++ " in module " - ++ getFuncModule targetfunc) + ++ getFuncModule targetfunc) -- show the non-termination path, if one can be found showPath state | funcpath == [] = do putStrLn ("hat-nonterm: no path found") exitWith (ExitFailure 1) | (showNode state) = do mapIO putStrLn - (inter (map (showSctx state) funcpath) - (map show funcpath) ) + (inter (map (showSctx state) funcpath) + (map show funcpath) ) | otherwise = do mapIO (putStrLn . showSctx state ) funcpath where funcpath = nAppSearch state getRootNode targetfunc @@ -71,8 +71,8 @@ checkError :: String -> IO () checkError msg | msg `isPrefixOf` "Interrupted (^C)"= return () | otherwise = - do hPutStrLn stderr ("hat-nonterm: not interrupted") - exitWith (ExitFailure 1) + do hPutStrLn stderr ("hat-nonterm: not interrupted") + exitWith (ExitFailure 1) checkHelp args | member "--help" args = do showHelp exitWith ExitSuccess @@ -81,15 +81,15 @@ getHatName args = case args of (f:_) -> return f _ -> do hPutStrLn stderr ("hat-nonterm: no trace file") - showHelpShort + showHelpShort exitWith (ExitFailure 1) showHelpShort = do putStrLn "Usage: hat-nonterm [PROG] [OPTIONS]..." showHelp = do showHelpShort putStrLn " --showqual={t,f} Show function module names" - putStrLn " --showrt={t,f} Show all nodes from the root node" - putStrLn " --srcref={t,f} Show source references for nodes" + putStrLn " --showrt={t,f} Show all nodes from the root node" + putStrLn " --srcref={t,f} Show source references for nodes" putStrLn " --cutoff= Cutoff expression at depth " putStrLn " --numfn= Show instances of the function" @@ -138,7 +138,7 @@ nodepeek = peekResultMod (getResultHT currnode True) nodeistarget = (nodeType currnode) == ExpApp && (getFuncPtr currnode) == func - && nodepeek == interrupted + && nodepeek == interrupted -- call the function on the node result, remembering to decrement the -- counter if the current node is an call to the target function @@ -157,38 +157,38 @@ | otherwise = searchChildren rest where chfunc = getFuncPtr ch - chsctx = (ch:currnode:stack) + chsctx = (ch:currnode:stack) childpathapp = nAppSearchAux chsctx (n-1) func path - childpathnoapp = nAppSearchAux chsctx n func path + childpathnoapp = nAppSearchAux chsctx n func path -- Check if its ok to keep following this node path -haltAtNode node | node <= (FileNode 4) = True - | ntype == ExpApp = False - | ntype == ExpValueApp = False - | ntype == ExpValueUse = False - | ntype == ExpConstUse = False - | ntype == ExpConstDef = False - | ntype == ExpGuard = False - | ntype == ExpCase = False - | ntype == ExpIf = False - | ntype == ExpForward = False - | ntype == ExpProjection = False - | ntype == Module = True - | ntype == SrcPos = True - | ntype == ExpChar = True - | ntype == ExpInt = True - | ntype == ExpInteger = True - | ntype == ExpRat = True - | ntype == ExpRational = True - | ntype == ExpFloat = True - | ntype == ExpDouble = True - | ntype == ExpFieldUpdate = True - | ntype == ExpHidden = True - | ntype == ExpDoStmt = True - | ntype == AtomVariable = True - | ntype == AtomConstructor = True - | ntype == AtomAbstract = True +haltAtNode node | node <= (FileNode 4) = True + | ntype == ExpApp = False + | ntype == ExpValueApp = False + | ntype == ExpValueUse = False + | ntype == ExpConstUse = False + | ntype == ExpConstDef = False + | ntype == ExpGuard = False + | ntype == ExpCase = False + | ntype == ExpIf = False + | ntype == ExpForward = False + | ntype == ExpProjection = False + | ntype == Module = True + | ntype == SrcPos = True + | ntype == ExpChar = True + | ntype == ExpInt = True + | ntype == ExpInteger = True + | ntype == ExpRat = True + | ntype == ExpRational = True + | ntype == ExpFloat = True + | ntype == ExpDouble = True + | ntype == ExpFieldUpdate = True + | ntype == ExpHidden = True + | ntype == ExpDoStmt = True + | ntype == AtomVariable = True + | ntype == AtomConstructor = True + | ntype == AtomAbstract = True where ntype = nodeType node @@ -212,7 +212,7 @@ maxdist (fn1, s1, e1) (fn2, s2, e2) | (fnDist s1 e1) >= (fnDist s2 e2) = (fn1, s1, e1) | otherwise = (fn2, s2, e2) - + -- This function builds a list of functions that were interrupted, -- along with pointers to their first and last applications It scans diff --git a/tools/HatObserve.hs b/tools/HatObserve.hs --- a/tools/HatObserve.hs +++ b/tools/HatObserve.hs @@ -1,64 +1,64 @@ -- hat-observe Main import Data.Maybe -import Data.List (sort,isPrefixOf,isSuffixOf,intersperse) -import Control.Monad (when,liftM) +import Data.List (sort,isPrefixOf,isSuffixOf,intersperse) +import Control.Monad (when,liftM) -- import System import System.Process (system) import System.Exit (ExitCode(..), exitWith) import System.Environment (getArgs, getProgName) -import Data.Char (isDigit,digitToInt,isUpper,toUpper,isAlphaNum,isSpace) -import System.IO (hFlush,stdout,hSetBuffering,BufferMode(..)) -import Foreign.C.String (withCString) +import Data.Char (isDigit,digitToInt,isUpper,toUpper,isAlphaNum,isSpace) +import System.IO (hFlush,stdout,hSetBuffering,BufferMode(..)) +import Foreign.C.String (withCString) -import Observe (ObserveResult(..) - ,isFound,isNotFound,isInterrupted,fromFound - ,newObservation,newObservationSrc) -import Ident (Ident(..),getIdentAt) -import Idents (collateIdents,getAllIdents,sortIdents,showInfo) -import LowLevel (FileNode(..),nil,openHatFile,getResult,hatVersionNumber - ,getSrcRef,getDefnRef) -import SrcRef (SrcRef(..),readSrcRef,defnSrcRef) -import SExp (SExp(..),Label,prettyEquation,prettyExpression - ,fileNode2SExp,funId,label,QName(..)) -import HighlightStyle (cursorUp,cleareol,highlight,Highlight(..),Colour(..) - ,getTerminalSize, hasEscapes) -import Trie (Trie,Search(..),emptyTrie,match) -import TExp (linearise) -import Pattern (topMatchPat,parsePat,lexPat) -import CmdLine (initialize,cmdline) -import CommonUI (hatObserve,hatTrail,hatAnim,hatDetect,hatExplore +import Observe (ObserveResult(..) + ,isFound,isNotFound,isInterrupted,fromFound + ,newObservation,newObservationSrc) +import Ident (Ident(..),getIdentAt) +import Idents (collateIdents,getAllIdents,sortIdents,showInfo) +import LowLevel (FileNode(..),nil,openHatFile,getResult,hatVersionNumber + ,getSrcRef,getDefnRef) +import SrcRef (SrcRef(..),readSrcRef,defnSrcRef) +import SExp (SExp(..),Label,prettyEquation,prettyExpression + ,fileNode2SExp,funId,label,QName(..)) +import HighlightStyle (cursorUp,cleareol,highlight,Highlight(..),Colour(..) + ,getTerminalSize, hasEscapes) +import Trie (Trie,Search(..),emptyTrie,match) +import TExp (linearise) +import Pattern (topMatchPat,parsePat,lexPat) +import CmdLine (initialize,cmdline) +import CommonUI (hatObserve,hatTrail,hatAnim,hatDetect,hatExplore ,hatView - ,shortHelpText - ,Keep(..),Options(..),initialOptions - ,OptionCmd(..),optionCmd,onOff,number,safeReadInt - ,optionsUpdate,showOption) + ,shortHelpText + ,Keep(..),Options(..),initialOptions + ,OptionCmd(..),optionCmd,onOff,number,safeReadInt + ,optionsUpdate,showOption) ---- data InteractiveState = State - { lastObserved :: [FileNode] - , more :: Bool - , equationsPerPage :: Int - , hatFile :: String - , currentPos :: Int - , showRHS :: Bool - , options :: Options - , screenWidth :: Int - , symbolTable :: ([Ident],[Ident],[Ident]) - } + { lastObserved :: [FileNode] + , more :: Bool + , equationsPerPage :: Int + , hatFile :: String + , currentPos :: Int + , showRHS :: Bool + , options :: Options + , screenWidth :: Int + , symbolTable :: ([Ident],[Ident],[Ident]) + } initialState :: FilePath -> Int -> InteractiveState initialState file width = State - { lastObserved = [] - , more = False - , equationsPerPage = 10 - , hatFile = file - , currentPos = 0 - , showRHS = True - , options = initialOptions - , screenWidth = width - , symbolTable = ([],[],[]) - } + { lastObserved = [] + , more = False + , equationsPerPage = 10 + , hatFile = file + , currentPos = 0 + , showRHS = True + , options = initialOptions + , screenWidth = width + , symbolTable = ([],[],[]) + } ---- ----------------------------------------------------------------------- @@ -75,7 +75,7 @@ putStrLn ("\n hat-observe "++hatVersionNumber ++" ("++shortHelpText++")\n") (width,_) <- getTerminalSize - CmdLine.initialize -- for readline functionality + CmdLine.initialize -- for readline functionality let hatFile = rectify (arguments!!0) state = initialState hatFile width prog <- System.Environment.getProgName @@ -84,7 +84,7 @@ collateIdents syms <- getAllIdents let state' = state { symbolTable = syms } - putStr clearLine -- delayed until next output appears + putStr clearLine -- delayed until next output appears case numArgs of 1 -> interactive state' 2 -> doCommand (Pattern (arguments!!1)) state' @@ -107,9 +107,9 @@ -- arguments to showObservationList are: --- i :: Int numbered equation --- max :: Int how many equations to show at once --- exprs :: [FileNode] roots of equations +-- i :: Int numbered equation +-- max :: Int how many equations to show at once +-- exprs :: [FileNode] roots of equations -- result is number of equations that have been shown showObservationList :: InteractiveState -> Int -> Int -> [FileNode] -> IO Int showObservationList state _ _ [] = do putStr clearLine; return 0 @@ -181,7 +181,7 @@ in do beginSearching count <- showObservationList state (currentPos state + 1) - (equationsPerPage state) showNowList + (equationsPerPage state) showNowList return (count + currentPos state, hasMore) beginSearching :: IO () @@ -206,8 +206,8 @@ let nodes = drop (n-1) lastObserved in if n>0 then if null nodes then do -- This test may take a while! - putStrLn "No equation with this number" - return Nothing + putStrLn "No equation with this number" + return Nothing else return (Just (head nodes)) else return Nothing @@ -234,27 +234,27 @@ if more state then do putStr clearLine (newPos,newMore) <- showSomeMore state - interactive (state {more=newMore,currentPos=newPos}) + interactive (state {more=newMore,currentPos=newPos}) else do when (currentPos state>0) (putStrLn "No more applications observed.") interactive state doCommand (Info mod) state = do let (glob,_,_) = symbolTable state putStr (showInfo mod (sortIdents glob) "") - interactive state + interactive state doCommand (InfoC mod) state = do let (_,_,constrs) = symbolTable state putStr (showInfo mod (sortIdents constrs) "") - interactive state + interactive state doCommand Resize state = do (width,_) <- getTerminalSize interactive (state{screenWidth=width}) doCommand Count state = do when (more state) (putStrLn "One moment, this may take a while...") - putStrLn ("Number of (all,unique) matching applications: " - ++(show (length (lastObserved state)))) - interactive state + putStrLn ("Number of (all,unique) matching applications: " + ++(show (length (lastObserved state)))) + interactive state doCommand Status state = do mapM_ (\m-> putStrLn (showState m state)) @@ -269,22 +269,22 @@ doCommand (StartTool tool) state = do startExternalTool tool state - interactive state + interactive state doCommand (Source n) state = do node <- getEquationNumber n (lastObserved state) let sr = getSrcRef (fromJust node) - when (isJust node && sr /= LowLevel.nil) + when (isJust node && sr /= LowLevel.nil) (do system (hatView (readSrcRef sr)) return ()) - interactive state + interactive state doCommand (Definition n) state = do node <- getEquationNumber n (lastObserved state) let atom = getDefnRef (fromJust node) - when (isJust node) + when (isJust node) (do defnSR <- liftM defnSrcRef (getIdentAt atom) system (hatView defnSR) return ()) - interactive state + interactive state doCommand (Pattern s) state = let (pat, ctx) = parsePat (lexPat s) in @@ -303,12 +303,12 @@ then do putStrLn (clearLine ++ "no match found") interactive state - else do + else do putStr clearLine (newPos,newMore) <- showSomeMore (state { currentPos=0 , showRHS=not (isCon fun) - , lastObserved=fromFound newObserved}) + , lastObserved=fromFound newObserved}) interactive (state { lastObserved=fromFound newObserved , more=newMore , showRHS=not (isCon fun) @@ -326,7 +326,7 @@ (newPos,newMore) <- showSomeMore (state { currentPos=0 , showRHS=True - , lastObserved=fromFound newObserved}) + , lastObserved=fromFound newObserved}) interactive (state {lastObserved=fromFound newObserved ,more=newMore ,showRHS=True @@ -523,15 +523,15 @@ | cmd `isPrefixOf` "help" -> return (Help (unwords ss)) | cmd `isPrefixOf` "location" -> return (Location ss) | cmd `isPrefixOf` "detect" -> - return (number (StartTool . Detect) ss 0) + return (number (StartTool . Detect) ss 0) | cmd `isPrefixOf` "explore" -> - return (number (StartTool . Explore) ss 0) + return (number (StartTool . Explore) ss 0) | cmd `isPrefixOf` "trail" -> - return (number (StartTool . Trail) ss 0) + return (number (StartTool . Trail) ss 0) | cmd `isPrefixOf` "animate" -> - return (number (StartTool . Anim) ss 0) + return (number (StartTool . Anim) ss 0) | cmd `isPrefixOf` "observe" -> - return (StartTool (Observe (unwords ss))) + return (StartTool (Observe (unwords ss))) | cmd `isPrefixOf` "source" -> return (number Source ss 0) | cmd `isPrefixOf` "Source" -> return (number Definition ss 0) | cmd `isPrefixOf` "info" -> return (Info (unwords ss)) diff --git a/tools/HatStack.hs b/tools/HatStack.hs --- a/tools/HatStack.hs +++ b/tools/HatStack.hs @@ -1,9 +1,9 @@ -module HatStack(hatStack) where -- HatStack main program +module HatStack(hatStack) where -- HatStack main program import LowLevel (openHatFile,FileNode(..),nil,getParentNode ,getErrorLoc,getErrorMessage ,getSrcRef) -import SrcRef (SrcRef(..),readSrcRef) +import SrcRef (SrcRef(..),readSrcRef) import SExp (SExp(..),Label,fileNode2SExp,sExp2Doc,prune) import System.Environment (getProgName) import Foreign.C.String (withCString) diff --git a/tools/HatStackText.hs b/tools/HatStackText.hs --- a/tools/HatStackText.hs +++ b/tools/HatStackText.hs @@ -1,9 +1,9 @@ -module Main where -- HatStack main program +module Main where -- HatStack main program import LowLevel (openHatFile,FileNode(..),nil,getParentNode ,getErrorLoc,getErrorMessage ,getSrcRef) -import SrcRef (SrcRef(..),readSrcRef) +import SrcRef (SrcRef(..),readSrcRef) import SExp (SExp(..),Label,fileNode2SExp,sExp2Doc,prune) import PrettyLibHighlight (Doc,pretty,nest,text,(<>),parens) import HighlightStyle (getTerminalSize) diff --git a/tools/HatTrail.hs b/tools/HatTrail.hs --- a/tools/HatTrail.hs +++ b/tools/HatTrail.hs @@ -1,51 +1,51 @@ -module Main where -- HatTrail main program +module Main where -- HatTrail main program -import LowLevel (openHatFile,getBridgeValue,hatVersionNumber - ,FileNode(..),nil,peekTrace,getResult,getParentNode - ,getErrorLoc,getErrorMessage - ,getSrcRef,getDefnRef) -import SrcRef (SrcRef(..),readSrcRef,defnSrcRef) -import Ident (Ident,getIdentAt) -import SExp (SExp(..),Label,fileNode2SExp,sExp2Doc,arity,child - ,label,rebuild,children,parent,prune,funId,funLabel - ,QName(..),showQN) +import LowLevel (openHatFile,getBridgeValue,hatVersionNumber + ,FileNode(..),nil,peekTrace,getResult,getParentNode + ,getErrorLoc,getErrorMessage + ,getSrcRef,getDefnRef) +import SrcRef (SrcRef(..),readSrcRef,defnSrcRef) +import Ident (Ident,getIdentAt) +import SExp (SExp(..),Label,fileNode2SExp,sExp2Doc,arity,child + ,label,rebuild,children,parent,prune,funId,funLabel + ,QName(..),showQN) import PrettyLibHighlight (Doc,pretty,nest,text,(<>)) import qualified PrettyLibHighlight as Pretty (highlight) -import HighlightStyle (goto,cls,clearDown,clearUp,cleareol,highlightOff - ,highlight,Highlight(..),Colour(..) - ,enableScrollRegion,getTerminalSize - ,savePosition,restorePosition) +import HighlightStyle (goto,cls,clearDown,clearUp,cleareol,highlightOff + ,highlight,Highlight(..),Colour(..) + ,enableScrollRegion,getTerminalSize + ,savePosition,restorePosition) import qualified Control.Exception(catch,IOException) -import Control.Monad (when,liftM) +import Control.Monad (when,liftM) import System.Process (system) import System.Environment (getArgs,getProgName,getEnv) import System.Exit (exitWith,ExitCode(..)) -import System.Directory (doesFileExist) -import Data.List (isPrefixOf,isSuffixOf,group,groupBy) -import System.IO (hSetBuffering,BufferMode(..),stdin,stdout,stderr - ,hPutStrLn,hFlush) -import Numeric (showHex) +import System.Directory (doesFileExist) +import Data.List (isPrefixOf,isSuffixOf,group,groupBy) +import System.IO (hSetBuffering,BufferMode(..),stdin,stdout,stderr + ,hPutStrLn,hFlush) +import Numeric (showHex) import Foreign.C.String (withCString) -import CommonUI (hatTrail,hatObserve,hatDetect,hatAnim,hatView +import CommonUI (hatTrail,hatObserve,hatDetect,hatAnim,hatView ,hatExplore - ,Options(..),initialOptions - ,OptionCmd(..),optionCmd,onOff,number - ,optionsUpdate,showOption,showOnOff) + ,Options(..),initialOptions + ,OptionCmd(..),optionCmd,onOff,number + ,optionsUpdate,showOption,showOnOff) -- The recurring state within the main loop of the program contains -- the .hat filename, the terminal width and height, preferred -- highlighting styles, etc. data State = State - { file :: FilePath -- .hat filename - , width :: Int -- terminal screen size - , height :: Int -- terminal screen size - , startLine :: Int -- first line of the trail pane - , styleNew :: [Highlight] -- highlight for current subexpr - , styleOld :: [Highlight] -- highlight for previous subexprs - , srcrefs :: Bool -- always show src references? - , options :: Options -- common configurable display options - } + { file :: FilePath -- .hat filename + , width :: Int -- terminal screen size + , height :: Int -- terminal screen size + , startLine :: Int -- first line of the trail pane + , styleNew :: [Highlight] -- highlight for current subexpr + , styleOld :: [Highlight] -- highlight for previous subexprs + , srcrefs :: Bool -- always show src references? + , options :: Options -- common configurable display options + } setState :: Mode -> State -> State setState (O o) state = state {options=optionsUpdate o (options state)} @@ -79,7 +79,7 @@ , [Bold,Foreground Magenta] )) (columns,lines) <- getTerminalSize let state = State { file=hatfile, width=columns, height=lines, startLine=0 - , srcrefs=True, styleOld=style0, styleNew=style1 + , srcrefs=True, styleOld=style0, styleNew=style1 , options=initialOptions {equations=False} } hSetBuffering stdin NoBuffering hSetBuffering stdout NoBuffering @@ -244,7 +244,7 @@ size | isError && i<=chunkSize = lenError+chunkSize | otherwise = chunkSize in - concatMap (\n-> goto 1 n ++ cleareol) -- clean output window + concatMap (\n-> goto 1 n ++ cleareol) -- clean output window [2+lenError .. startLine-2] ++ goto 1 2 -- previously had safeUnlines (width state) ... @@ -540,9 +540,9 @@ -- Paint a single stack element (Int,Sctx) to a String. While we're -- at it, most callers want to know how many lines are used by the string. paintOne :: State - -> (State -> Label -> Label -> Doc -> Doc) -- subexpr highlighter - -> Sctx -- abstract expression - -> (Int,String,SExp Label) -- (length, text, squashed expr) + -> (State -> Label -> Label -> Doc -> Doc) -- subexpr highlighter + -> Sctx -- abstract expression + -> (Int,String,SExp Label) -- (length, text, squashed expr) paintOne state high ctx@(Sctx node _) = -- Find the root of the S-expr, then make it fit on the screen (squash state (high state (label node)) (cutoffDepth (options state)) @@ -555,10 +555,10 @@ squash state high cut s = let -- cut-down the expression to size exp = prune cut s - -- paint SExp as a Doc, highlighting current subtree node + -- paint SExp as a Doc, highlighting current subtree node doc = sExp2Doc False (listSugar (options state)) (showQual (options state)) high exp - -- and then pretty-print it, with introductory marker + -- and then pretty-print it, with introductory marker str = pretty (width state - 2) (text "<- " <> nest 3 doc) len = length (lines str) in -- now does it fit? @@ -593,7 +593,7 @@ repaint state ((expBegin,exp):stack) = do putStr (goto 1 start ++ clearDown) putStr (goto 1 (expBegin-(offset`max`0)) ++ str) - if offset <= 0 -- everything fits on screen? + if offset <= 0 -- everything fits on screen? then do putStr (goto 1 expBegin ++ str) mapM_ paintAll stack else do putStr (goto 1 (expBegin-offset) ++ str) @@ -602,7 +602,7 @@ where start = startLine state extent = expBegin + len - offset = extent - height state -- reduce absolute linenums to fit + offset = extent - height state -- reduce absolute linenums to fit (len,str,_) = paintOne state highlightNewSelection exp -- most recent item paintAll i@(lineno,exp) = @@ -616,9 +616,9 @@ partial [] = "" partial ((lineno,exp):rest) = let adjusted = lineno - offset in - if adjusted > start then partial rest -- keep looking - else if adjusted == start then "" -- no partial trail - else ( unlines -- partial trail + if adjusted > start then partial rest -- keep looking + else if adjusted == start then "" -- no partial trail + else ( unlines -- partial trail . drop (start - adjusted) . lines . (\(_,x,_)->x) @@ -643,8 +643,8 @@ extent = lineno + len in do if (extent < height state) - then putStrLn (goto 1 lineno ++ str) -- either careful placement - else putStrLn str -- or allow bottom of screen to scroll + then putStrLn (goto 1 lineno ++ str) -- either careful placement + else putStrLn str -- or allow bottom of screen to scroll paint state extent ((lineno,ctx):acc) stack @@ -724,8 +724,8 @@ '=' -> return Result '<' -> return (Movement JumpL) '>' -> return (Movement JumpR) - ',' -> return (Movement JumpL) -- unshifted < - '.' -> return (Movement JumpR) -- unshifted > + ',' -> return (Movement JumpL) -- unshifted < + '.' -> return (Movement JumpR) -- unshifted > '[' -> return (Movement JumpL) ']' -> return (Movement JumpR) -- '[' -> return (Movement ListLeft) diff --git a/tools/HighlightStyle.hs b/tools/HighlightStyle.hs --- a/tools/HighlightStyle.hs +++ b/tools/HighlightStyle.hs @@ -13,7 +13,7 @@ , enableScrollRegion, scrollUp, scrollDown , lineWrap - , getTerminalSize -- :: IO (Int,Int) (width,height) + , getTerminalSize -- :: IO (Int,Int) (width,height) , hasEscapes ) where diff --git a/tools/Ident.hs b/tools/Ident.hs --- a/tools/Ident.hs +++ b/tools/Ident.hs @@ -1,28 +1,28 @@ module Ident ( Ident(..) - , getIdentAt -- :: FileNode -> IO Ident + , getIdentAt -- :: FileNode -> IO Ident ) where -import LowLevel (FileNode(..)) +import LowLevel (FileNode(..)) import System.IO.Unsafe (unsafePerformIO) import Foreign.Ptr (Ptr) import Foreign.Marshal.Alloc (free) -import Foreign.C.String (CString, peekCString) +import Foreign.C.String (CString, peekCString) --foreign import ccall "malloc.h &free" finaliserFree :: FunPtr (Ptr a -> IO ()) -- All possible relevant information about an identifier data Ident = Ident - { i_name :: String - , i_modname :: String - , i_srcfile :: String - , i_fixity :: Int - , i_arity :: Int - , i_defnline :: Int - , i_defncol :: Int + { i_name :: String + , i_modname :: String + , i_srcfile :: String + , i_fixity :: Int + , i_arity :: Int + , i_defnline :: Int + , i_defncol :: Int , i_defnlineend :: Int , i_defncolend :: Int - , i_isTraced :: Bool + , i_isTraced :: Bool , i_caf :: Bool , i_uses :: Int , i_pending :: Int @@ -43,7 +43,7 @@ getIdentAt :: FileNode -> IO Ident getIdentAt n = do - p <- readAtomAt n -- p is malloc'ed in C land + p <- readAtomAt n -- p is malloc'ed in C land nm <- identName p mod <- identModName p src <- identSrcFile p @@ -57,22 +57,22 @@ snm <- peekCString nm smod <- peekCString mod ssrc <- peekCString src - free p -- dispose of p again + free p -- dispose of p again return Ident - { i_name = snm - , i_modname = smod - , i_srcfile = ssrc - , i_fixity = fix - , i_arity = ar - , i_defnline = dl - , i_defncol = dc + { i_name = snm + , i_modname = smod + , i_srcfile = ssrc + , i_fixity = fix + , i_arity = ar + , i_defnline = dl + , i_defncol = dc , i_defnlineend = dle , i_defncolend = dce - , i_isTraced = tr + , i_isTraced = tr , i_caf = error "Ident.getIdentAt i_caf" , i_uses = error "Ident.getIdentAt i_uses" , i_pending = error "Ident.getIdentAt i_pending" , i_thunks = error "Ident.getIdentAt i_thunks" - } + } --------------------------------------------------------------------- diff --git a/tools/Idents.hs b/tools/Idents.hs --- a/tools/Idents.hs +++ b/tools/Idents.hs @@ -2,19 +2,19 @@ module Idents ( Ident(..) - , collateIdents -- :: IO () - , getAllIdents -- :: IO ([Ident],[Ident],[Ident]) - , AllInfo -- type AllInfo = [(String,[(String,Ident)])] - , sortIdents -- :: [Ident] -> AllInfo - , showInfo -- :: String -> AllInfo -> ShowS + , collateIdents -- :: IO () + , getAllIdents -- :: IO ([Ident],[Ident],[Ident]) + , AllInfo -- type AllInfo = [(String,[(String,Ident)])] + , sortIdents -- :: [Ident] -> AllInfo + , showInfo -- :: String -> AllInfo -> ShowS ) where -import LowLevel (FileNode(..)) +import LowLevel (FileNode(..)) import Foreign.Ptr (Ptr) import Foreign.C.String (CString, peekCString) import System.IO.Unsafe (unsafePerformIO) import Foreign.Marshal.Alloc (free) -import Ident (Ident(..),getIdentAt) +import Ident (Ident(..),getIdentAt) import Data.List import HighlightStyle @@ -22,7 +22,7 @@ data Item foreign import ccall "hat-names.h" getItemPtr :: Ptr (Ptr Item) -> Int - -> IO (Ptr Item) + -> IO (Ptr Item) foreign import ccall "hat-names.h" itemIdent :: Ptr Item -> IO FileNode foreign import ccall "hat-names.h" itemArity :: Ptr Item -> IO Int foreign import ccall "hat-names.h" itemUses :: Ptr Item -> IO Int @@ -40,11 +40,11 @@ ident <- getIdentAt atom free p return ident - { i_caf = arity==0 - , i_uses = uses - , i_pending = pend - , i_thunks = th - } + { i_caf = arity==0 + , i_uses = uses + , i_pending = pend + , i_thunks = th + } foreign import ccall "hat-names.h" collateIdents :: IO () @@ -82,14 +82,14 @@ -} -- --- [(modulename, [(idname,identifier info)])] +-- [(modulename, [(idname,identifier info)])] type AllInfo = [(String,[(String,Ident)])] sortIdents :: [Ident] -> AllInfo sortIdents is = foldr insMod [] is where insMod i [] - -- exclude identifiers with zero counts + -- exclude identifiers with zero counts | (i_uses i == 0) && (i_pending i == 0) = [] | otherwise = [(i_modname i, [(i_name i, i)])] insMod i xs@(o@(x,ys):rest) diff --git a/tools/LowLevel.hs b/tools/LowLevel.hs --- a/tools/LowLevel.hs +++ b/tools/LowLevel.hs @@ -1,60 +1,60 @@ {-# LANGUAGE EmptyDataDecls #-} module LowLevel - ( openHatFile -- :: CString -> CString -> IO () + ( openHatFile -- :: CString -> CString -> IO () , closeHatFile -- :: IO () - , getBridgeValue -- :: IO FileNode - , getErrorLoc -- :: IO FileNode - , getErrorMessage -- :: IO CString - , hatVersionNumber -- :: String + , getBridgeValue -- :: IO FileNode + , getErrorLoc -- :: IO FileNode + , getErrorMessage -- :: IO CString + , hatVersionNumber -- :: String , FileNode(..) - , nil -- :: FileNode - , unevaluated -- :: FileNode - , entered -- :: FileNode - , interrupted -- :: FileNode - , lambda -- :: FileNode - , dolambda -- :: FileNode + , nil -- :: FileNode + , unevaluated -- :: FileNode + , entered -- :: FileNode + , interrupted -- :: FileNode + , lambda -- :: FileNode + , dolambda -- :: FileNode , NodeType(..) - , nodeType -- :: FileNode -> NodeType + , nodeType -- :: FileNode -> NodeType , SimpleNodeType(..) - , simpleNodeType -- :: FileNode -> SimpleNodeType + , simpleNodeType -- :: FileNode -> SimpleNodeType - , getParentNode -- :: FileNode -> FileNode - , getResult -- :: FileNode -> Bool -> FileNode - , peekResult -- :: FileNode -> FileNode + , getParentNode -- :: FileNode -> FileNode + , getResult -- :: FileNode -> Bool -> FileNode + , peekResult -- :: FileNode -> FileNode - , getValue -- :: FileNode -> String - , getValueMod -- :: FileNode -> String - , getFixity -- :: FileNode -> Int - , isLiteral -- :: FileNode -> Bool - , isConstructor -- :: FileNode -> Bool - , isConstrFields -- :: FileNode -> Bool - , isLambda -- :: FileNode -> Bool - , isDoLambda -- :: FileNode -> Bool + , getValue -- :: FileNode -> String + , getValueMod -- :: FileNode -> String + , getFixity -- :: FileNode -> Int + , isLiteral -- :: FileNode -> Bool + , isConstructor -- :: FileNode -> Bool + , isConstrFields -- :: FileNode -> Bool + , isLambda -- :: FileNode -> Bool + , isDoLambda -- :: FileNode -> Bool - , getAtom -- :: FileNode -> String - , getAtomMod -- :: FileNode -> String - , getAtomFixity -- :: FileNode -> Int + , getAtom -- :: FileNode -> String + , getAtomMod -- :: FileNode -> String + , getAtomFixity -- :: FileNode -> Int - , getSubExprs -- :: FileNode -> [FileNode] + , getSubExprs -- :: FileNode -> [FileNode] , peekSubExprs -- :: FileNode -> [FileNode] , peekExpArg -- :: FileNode -> Int -> FileNode - , getFieldLabels -- :: FileNode -> [String] + , getFieldLabels -- :: FileNode -> [String] - , getSrcRef -- :: FileNode -> FileNode - , getDefnRef -- :: FileNode -> FileNode + , getSrcRef -- :: FileNode -> FileNode + , getDefnRef -- :: FileNode -> FileNode - , peekTrace -- :: FileNode -> FileNode + , peekTrace -- :: FileNode -> FileNode - , nodeSequence -- :: IO [(FileNode,NodeType)] + , nodeSequence -- :: IO [(FileNode,NodeType)] , hiddenChildren -- :: FileNode -> [FileNode] ) where import Foreign.Ptr (Ptr) -import Foreign.C.String (CString, peekCString) +import Foreign.C.String (CString, peekCString) import System.IO.Unsafe (unsafePerformIO) import Numeric (showHex) @@ -141,16 +141,16 @@ -- For most purposes, we don't care about the exact node type, and a -- simplified division of nodes into kinds is useful. data SimpleNodeType - = NodeModule -- Module - | NodeSrcPos -- SrcPos - | NodeApplication -- ExpApp, ExpValueApp - | NodeBasicValue -- ExpChar, ExpInt, ..., ExpDouble - | NodeIdentifier -- ExpValueUse - | NodeCAF -- ExpConstUse, ExpConstDef - | NodeConditional -- ExpGuard, ExpCase, ExpIf - | NodeSugar -- ExpFieldUpdate, ExpDoStmt - | NodeSpecial -- ExpProjection, ExpHidden, ExpForward - | NodeAtom -- AtomVariable, AtomConstructor, AtomAbstract + = NodeModule -- Module + | NodeSrcPos -- SrcPos + | NodeApplication -- ExpApp, ExpValueApp + | NodeBasicValue -- ExpChar, ExpInt, ..., ExpDouble + | NodeIdentifier -- ExpValueUse + | NodeCAF -- ExpConstUse, ExpConstDef + | NodeConditional -- ExpGuard, ExpCase, ExpIf + | NodeSugar -- ExpFieldUpdate, ExpDoStmt + | NodeSpecial -- ExpProjection, ExpHidden, ExpForward + | NodeAtom -- AtomVariable, AtomConstructor, AtomAbstract | NodeList -- ListCons deriving (Eq) @@ -288,7 +288,7 @@ c' <- q_peek c <- q_tag q_skipNode c' - if c=='\31' then return [] -- end of file + if c=='\31' then return [] -- end of file else return ((FileNode n, toEnum (fromEnum c)) : unsafePerformIO (list c)) foreign import ccall "artutils.h" q_init :: IO () diff --git a/tools/NonTermLib.hs b/tools/NonTermLib.hs --- a/tools/NonTermLib.hs +++ b/tools/NonTermLib.hs @@ -80,46 +80,46 @@ where arity = getExpArity n foreign import ccall "nontermutils.h" - getImmediateExpArg :: FileNode -> Int -> FileNode + getImmediateExpArg :: FileNode -> Int -> FileNode foreign import ccall "nontermutils.h" - getExpArity :: FileNode -> Int + getExpArity :: FileNode -> Int foreign import ccall "nontermutils.h" - getRootNode :: FileNode + getRootNode :: FileNode foreign import ccall "nontermutils.h" - peekResultMod :: FileNode -> FileNode + peekResultMod :: FileNode -> FileNode foreign import ccall "nontermutils.h" - getResultHT :: FileNode -> Bool -> FileNode + getResultHT :: FileNode -> Bool -> FileNode foreign import ccall "nontermutils.h" - nextFileNode :: FileNode -> FileNode + nextFileNode :: FileNode -> FileNode -- Show the type of a node -showNodeType node | node <= (FileNode 4) = "special" - | ntype == ExpApp = "ExpApp" - | ntype == ExpValueApp = "ExpValueApp" - | ntype == ExpValueUse = "ExpValueUse" - | ntype == ExpConstUse = "ExpConstUse" - | ntype == ExpConstDef = "ExpConstDef" - | ntype == ExpGuard = "ExpGuard" - | ntype == ExpCase = "ExpCase" - | ntype == ExpIf = "ExpIf" - | ntype == ExpForward = "ExpForward" - | ntype == ExpProjection = "ExpProjection" - | ntype == Module = "Module" - | ntype == SrcPos = "SrcPos" - | ntype == ExpChar = "ExpChar" - | ntype == ExpInt = "ExpInt" - | ntype == ExpInteger = "ExpInteger" - | ntype == ExpRat = "ExpRat" - | ntype == ExpRational = "ExpRational" - | ntype == ExpFloat = "ExpFloat" - | ntype == ExpDouble = "ExpDouble" - | ntype == ExpFieldUpdate = "ExpFieldUpdate" - | ntype == ExpHidden = "ExpHidden" - | ntype == ExpDoStmt = "ExpDoStmt" - | ntype == AtomVariable = "AtomVariable" - | ntype == AtomConstructor = "AtomConstructor" - | ntype == AtomAbstract = "AtomAbstract" +showNodeType node | node <= (FileNode 4) = "special" + | ntype == ExpApp = "ExpApp" + | ntype == ExpValueApp = "ExpValueApp" + | ntype == ExpValueUse = "ExpValueUse" + | ntype == ExpConstUse = "ExpConstUse" + | ntype == ExpConstDef = "ExpConstDef" + | ntype == ExpGuard = "ExpGuard" + | ntype == ExpCase = "ExpCase" + | ntype == ExpIf = "ExpIf" + | ntype == ExpForward = "ExpForward" + | ntype == ExpProjection = "ExpProjection" + | ntype == Module = "Module" + | ntype == SrcPos = "SrcPos" + | ntype == ExpChar = "ExpChar" + | ntype == ExpInt = "ExpInt" + | ntype == ExpInteger = "ExpInteger" + | ntype == ExpRat = "ExpRat" + | ntype == ExpRational = "ExpRational" + | ntype == ExpFloat = "ExpFloat" + | ntype == ExpDouble = "ExpDouble" + | ntype == ExpFieldUpdate = "ExpFieldUpdate" + | ntype == ExpHidden = "ExpHidden" + | ntype == ExpDoStmt = "ExpDoStmt" + | ntype == AtomVariable = "AtomVariable" + | ntype == AtomConstructor = "AtomConstructor" + | ntype == AtomAbstract = "AtomAbstract" where ntype = nodeType node @@ -151,27 +151,27 @@ -- The state datatype holds all of the configuration data for the tools data State = State - { progname :: String -- program name - , file :: FilePath -- .hat filename - , width :: Int -- terminal screen size - , height :: Int -- terminal screen size - , strSugar :: Bool -- show strings with sugar? - , listSugar :: Bool -- show lists with sugar? - , srcrefs :: Bool -- always show src references? - , showQual :: Bool -- show identifiers qualified? - , cutoff :: Int -- expression cutoff depth - , numFn :: Int -- how many instances of fn - , showRoot :: Bool -- cut off the head of the trail? - , showNode :: Bool -- show the trail nodes? - , showSrcRef:: Bool -- show source ref? - , showCount :: Bool -- show number of nodes visited - } + { progname :: String -- program name + , file :: FilePath -- .hat filename + , width :: Int -- terminal screen size + , height :: Int -- terminal screen size + , strSugar :: Bool -- show strings with sugar? + , listSugar :: Bool -- show lists with sugar? + , srcrefs :: Bool -- always show src references? + , showQual :: Bool -- show identifiers qualified? + , cutoff :: Int -- expression cutoff depth + , numFn :: Int -- how many instances of fn + , showRoot :: Bool -- cut off the head of the trail? + , showNode :: Bool -- show the trail nodes? + , showSrcRef:: Bool -- show source ref? + , showCount :: Bool -- show number of nodes visited + } -- the emptyState function gives a state with all the defaults set emptyState :: State emptyState = State { strSugar=True, listSugar=True, srcrefs=True ,showQual=False, cutoff=10, numFn=3, showRoot=False - ,showNode=False,showSrcRef=False,showCount=False + ,showNode=False,showSrcRef=False,showCount=False ,progname="", file="", width=80, height=25} -- set state options from a list of command-line arguments @@ -182,13 +182,13 @@ setOpt (x:xs) | "--showqual" `isPrefixOf` x = state {showQual = bool} | "--cutoff" `isPrefixOf` x = state {cutoff = num} | "--numfn" `isPrefixOf` x = state {numFn = num} - | "--showrt" `isPrefixOf` x = state {showRoot = bool} - | "--shownode" `isPrefixOf` x = state {showNode = bool} - | "--srcref" `isPrefixOf` x = state {showSrcRef = bool} - | "--showcount" `isPrefixOf` x = state {showCount = bool} + | "--showrt" `isPrefixOf` x = state {showRoot = bool} + | "--shownode" `isPrefixOf` x = state {showNode = bool} + | "--srcref" `isPrefixOf` x = state {showSrcRef = bool} + | "--showcount" `isPrefixOf` x = state {showCount = bool} | otherwise = setOpt xs where bool = if (val /= [] && ((head val) == 'f' || (head val) == 'F')) - then False else True + then False else True num = decimalStringToInt val val = breakAfter ('='==) x state = setOpt xs @@ -220,7 +220,7 @@ -- create a source reference string srcref | line == 0 && col == 0 = " " ++ (showNodeType (snd (label root))) ++ " (no ref)" | otherwise = " (L" ++ (show col) - ++ ",C" ++ (show line) ++ ")" + ++ ",C" ++ (show line) ++ ")" where sr = readSrcRef (expSrcRef root) line = SrcRef.line sr col = SrcRef.column sr @@ -297,15 +297,15 @@ case go cutoff uneval strings toplevelLHS [] label of (e,_,_) -> e where simple e = (e,[],[]) - go :: Int -- cutoff depth - -> Bool -- show unevaluated args in full? - -> Bool -- sugar character strings? - -> Bool -- top-level LHS? (implies uneval to one level) - -> [(FileNode,String)] -- enclosing nodes w/ variable name for `where' - -> Label -- root node of expression - -> ( SExp Label -- expression - , [FileNode] -- nodes that start cycle - , [String] ) -- variable names occurring (except for cycles) + go :: Int -- cutoff depth + -> Bool -- show unevaluated args in full? + -> Bool -- sugar character strings? + -> Bool -- top-level LHS? (implies uneval to one level) + -> [(FileNode,String)] -- enclosing nodes w/ variable name for `where' + -> Label -- root node of expression + -> ( SExp Label -- expression + , [FileNode] -- nodes that start cycle + , [String] ) -- variable names occurring (except for cycles) go 0 uneval strings top nodesAbove label = simple (SCut label) go depth uneval strings top nodesAbove label@(lab,node) = if node == LowLevel.nil then simple $ SUnevaluated label @@ -359,9 +359,9 @@ lbl c n = (c:lab, n) -- To do strings right, need to peek one level inside a cons. z1 = go 1 uneval strings False newNodesAbove - ('1':lab, subExps!!1) -- only used in string cutoff case + ('1':lab, subExps!!1) -- only used in string cutoff case z2 = go 3 uneval strings False newNodesAbove - ('2':lab, subExps!!2) -- only used in string cutoff case + ('2':lab, subExps!!2) -- only used in string cutoff case sexp = case fun of -- convert the representation of constructors with fields @@ -377,7 +377,7 @@ -> SString label (init (tail c)) False SString _ s d -> SString label (init (tail c)++s) d _ -> SApp label (fun:args) - SCut _ -> -- peek beyond the cut + SCut _ -> -- peek beyond the cut case fst3 z1 of SLiteral _ c | not (null c) && head c == '\'' -> case fst3 z2 of @@ -524,7 +524,7 @@ decimalStringToInt' (d:digits) acc | d >= '0' && d <= '9' = decimalStringToInt' digits ((10 * acc) + (ord d - ord '0')) - | otherwise = -1 + | otherwise = -1 -- cut everything up to and including whatever matches condition f diff --git a/tools/Observe.hs b/tools/Observe.hs --- a/tools/Observe.hs +++ b/tools/Observe.hs @@ -4,10 +4,10 @@ , isNotFound , isInterrupted , fromFound - , newObservation -- :: QName -> Maybe QName -> Bool -> Int - -- -> ObserveResult - , newObservationSrc -- :: String -> Int -> Int -> ObserveResult --- , observableInfo -- :: Int -> IO () + , newObservation -- :: QName -> Maybe QName -> Bool -> Int + -- -> ObserveResult + , newObservationSrc -- :: String -> Int -> Int -> ObserveResult +-- , observableInfo -- :: Int -> IO () ) where import LowLevel diff --git a/tools/Pattern.hs b/tools/Pattern.hs --- a/tools/Pattern.hs +++ b/tools/Pattern.hs @@ -9,8 +9,8 @@ ) where import Prelude hiding (lex) -import Data.List (isPrefixOf) -import Data.Char (isDigit,isAlphaNum,isSpace,isUpper,isLower) +import Data.List (isPrefixOf) +import Data.Char (isDigit,isAlphaNum,isSpace,isUpper,isLower) import SExp (SExp(..),SFixity(..),QName(..),showQN) import Text.ParserCombinators.Poly @@ -35,7 +35,7 @@ (zip f's v's) matchPat (SFieldExpr _ e fs vs) (SApp _ (a:as)) = matchPat e a && and (zipWith matchPat vs as) - -- above is only correct if applied field order matches pattern order + -- above is only correct if applied field order matches pattern order matchPat (SFieldExpr _ e fs vs) b@(SId _ _ _)= matchPat e b matchPat _ _ = False @@ -115,7 +115,7 @@ = In: lexPat (drop 2 xs) | isSpace x = lexPat xs | isDigit x = gather (not.isNumeric) Numeric lexPat [x] xs - | isLower x || x=='_' -- already checked for wildcard above + | isLower x || x=='_' -- already checked for wildcard above = gather (not.isVariable) (plain Variable) lexPat [x] xs | isUpper x = gather (not.isQVariable) qname lexPat [x] xs | isSymbol x = gather (not.isSymbol) (plain InfixVariable) lexPat [x] xs diff --git a/tools/PrettyLibHighlight.hs b/tools/PrettyLibHighlight.hs --- a/tools/PrettyLibHighlight.hs +++ b/tools/PrettyLibHighlight.hs @@ -115,7 +115,7 @@ data Token = Text String Int | Delimiter String Int Int | FDelimiter String Int Int | Line Int - | Open | Close -- doc grouping + | Open | Close -- doc grouping | StartHiLite [Highlight] | EndHiLite [Highlight] deriving Show diff --git a/tools/SExp.hs b/tools/SExp.hs --- a/tools/SExp.hs +++ b/tools/SExp.hs @@ -55,38 +55,38 @@ showQN False (Qualified q n) = showString n "" showQN True (Qualified q n) = (showString q . showChar '.' . showString n) "" -type Label = (String,FileNode) -- The label on an SExp contains two components, - -- a unique string, and the file pointer. - -- The former enables unique highlighting, and - -- the latter enables highlighting of sharing. +type Label = (String,FileNode) -- The label on an SExp contains two components, + -- a unique string, and the file pointer. + -- The former enables unique highlighting, and + -- the latter enables highlighting of sharing. data SExp a - = SApp a [SExp a] -- n-ary application of at least 2 expressions - | SId a QName SFixity -- an identifier (variable or constructor) - | SLiteral a String -- any other kind of basic value - | SString a String Ellipsis -- character strings have special sugar - | SWithin a [SExp a] -- chains of if/case/guard inside an expression - | SLambda a -- a lambda expression - | SDoLambda a -- (internal) the lambda binding in a do stmt + = SApp a [SExp a] -- n-ary application of at least 2 expressions + | SId a QName SFixity -- an identifier (variable or constructor) + | SLiteral a String -- any other kind of basic value + | SString a String Ellipsis -- character strings have special sugar + | SWithin a [SExp a] -- chains of if/case/guard inside an expression + | SLambda a -- a lambda expression + | SDoLambda a -- (internal) the lambda binding in a do stmt | SDoStmt a a (SExp a) (SExp a) -- do { val <- stmt } - | SIf a (SExp a) (Maybe (SExp a)) -- possibly contains result + | SIf a (SExp a) (Maybe (SExp a)) -- possibly contains result | SCase a (SExp a) (Maybe (SExp a)) | SGuard a (SExp a) (Maybe (SExp a)) | SFieldExpr a (SExp a) [String] [SExp a] - -- constructor value, or update - | SCut a -- cut off subexpression (to limit depth) - | SUnevaluated a -- underscore - | SInterrupted a -- ^C (expr entered but never completed) - | SBottom a -- _|_ (expr entered but never completed) - | SCycle a String (SExp a) -- cyclic expression shown as `id where id = ..' + -- constructor value, or update + | SCut a -- cut off subexpression (to limit depth) + | SUnevaluated a -- underscore + | SInterrupted a -- ^C (expr entered but never completed) + | SBottom a -- _|_ (expr entered but never completed) + | SCycle a String (SExp a) -- cyclic expression shown as `id where id = ..' | SEquation a (SExp a) (SExp a) - -- an equation only makes sense as the root of an SExp - | SParens a (SExp a) Int -- parenthesised expr + -- an equation only makes sense as the root of an SExp + | SParens a (SExp a) Int -- parenthesised expr | SInfinite a | SFiniteMap a [([SExp a],SExp a)] - deriving Show -- only for testing/debugging + deriving Show -- only for testing/debugging -type Ellipsis = Bool -- is a character string truncated? +type Ellipsis = Bool -- is a character string truncated? data SFixity = SInfix Int | SInfixL Int | SInfixR Int | SAssoc Int String | SInfixDefault @@ -245,7 +245,7 @@ case go cutoff uneval strings toplevelLHS [] labl of (e,_,_) -> e where simple e = (e,[],[]) - go :: Int -- cutoff depth + go :: Int -- cutoff depth -> Bool -- show unevaluated args in full? -> Bool -- sugar character strings? -> Bool -- top-level LHS? (implies uneval to one level) @@ -305,9 +305,9 @@ lbl c n = (c:lab, n) -- To do strings right, need to peek one level inside a cons. z1 = go 1 uneval strings False newNodesAbove - ('1':lab, subExps!!1) -- only used in string cutoff case + ('1':lab, subExps!!1) -- only used in string cutoff case z2 = go 3 uneval strings False newNodesAbove - ('2':lab, subExps!!2) -- only used in string cutoff case + ('2':lab, subExps!!2) -- only used in string cutoff case sexp = case fun of -- convert the representation of constructors with fields @@ -323,7 +323,7 @@ -> SString labl (init (tail c)) False SString _ s d -> SString labl (init (tail c)++s) d _ -> SApp labl (fun:args) - SCut _ -> -- peek beyond the cut + SCut _ -> -- peek beyond the cut case fst3 z1 of SLiteral _ c | not (null c) && head c == '\'' -> case fst3 z2 of @@ -402,7 +402,7 @@ within :: Label -> (SExp Label->Maybe (SExp Label)->SExp Label) -> SExp Label -> SExp Label -> SExp Label within labl kind parent exp = - case parent of -- eliminate chains of SWithin + case parent of -- eliminate chains of SWithin SWithin _ ps -> SWithin labl (ps++[kind exp Nothing]) _ -> SWithin labl [parent,kind exp Nothing] in simple $ @@ -470,7 +470,7 @@ isOpSym :: String -> Bool -isOpSym "" = True -- representation of the unit value () +isOpSym "" = True -- representation of the unit value () isOpSym sym = let c = head sym in not (isAlpha c || c `elem` "[_{" || sym == "(\\..)") @@ -719,7 +719,7 @@ ambiguous (SInterrupted _) = True ambiguous (SInfinite _) = True ambiguous (SBottom _) = True - ambiguous _ = True -- shouldn't happen! + ambiguous _ = True -- shouldn't happen! -- Sets goDoc surFixity aPos ((SApp va [SId vf (Qualified "Data.Set" "MkSet") ownFixity,s])) = high va $ setDoc qual high surFixity aPos s diff --git a/tools/SrcRef.hs b/tools/SrcRef.hs --- a/tools/SrcRef.hs +++ b/tools/SrcRef.hs @@ -2,24 +2,24 @@ module SrcRef ( SrcRef(..) - , readSrcRef -- :: FileNode -> SrcRef - , defnSrcRef -- :: Ident -> SrcRef + , readSrcRef -- :: FileNode -> SrcRef + , defnSrcRef -- :: Ident -> SrcRef ) where -import LowLevel (FileNode(..)) +import LowLevel (FileNode(..)) import System.IO.Unsafe (unsafePerformIO) import Foreign.Ptr (Ptr) import Foreign.Marshal.Alloc (free) -import Foreign.C.String (CString, peekCString) -import Ident (Ident(..)) +import Foreign.C.String (CString, peekCString) +import Ident (Ident(..)) -- Contents of a SrcRef node. data SrcRef = SrcRef - { filename :: String - , line :: Int - , column :: Int - , lineend :: Int - , columnend :: Int + { filename :: String + , line :: Int + , column :: Int + , lineend :: Int + , columnend :: Int } deriving (Eq,Show) data SR; @@ -33,28 +33,28 @@ readSrcRef :: FileNode -> SrcRef readSrcRef n = unsafePerformIO $ do - p <- readSRAt n -- p is malloc'ed in C land + p <- readSRAt n -- p is malloc'ed in C land nm <- srFile p l <- srLine p c <- srColumn p le <- srLineEnd p ce <- srColumnEnd p snm <- peekCString nm - free p -- dispose of p again + free p -- dispose of p again return SrcRef - { filename = snm - , line = l - , column = c - , lineend = le - , columnend = ce - } + { filename = snm + , line = l + , column = c + , lineend = le + , columnend = ce + } --------------------------------------------------------------------- defnSrcRef :: Ident -> SrcRef defnSrcRef i = SrcRef - { filename = i_srcfile i - , line = i_defnline i - , column = i_defncol i - , lineend = i_defnlineend i - , columnend = i_defncolend i - } + { filename = i_srcfile i + , line = i_defnline i + , column = i_defncol i + , lineend = i_defnlineend i + , columnend = i_defncolend i + } diff --git a/tools/TExp.hs b/tools/TExp.hs --- a/tools/TExp.hs +++ b/tools/TExp.hs @@ -33,7 +33,7 @@ -- pre-order traversal linearise :: SExp a -> [TExp] linearise (SEquation x lhs rhs) = TEquation: linearise lhs - ++ TRHS: linearise rhs + ++ TRHS: linearise rhs linearise (SApp _ es) = TOpen: TApp: concatMap linearise es ++ [TClose] linearise (SId _ s _) = [TId s] linearise (SLiteral _ s) = [TLiteral s] diff --git a/tools/Trie.hs b/tools/Trie.hs --- a/tools/Trie.hs +++ b/tools/Trie.hs @@ -12,10 +12,10 @@ -- ----------------------------------------------------------------------------- module Trie - ( Trie -- type exported abstract - , emptyTrie -- :: Trie a - , Search(..) -- data Search a = Exists | New a - , match -- :: [a] -> Trie a -> Search (Trie a) + ( Trie -- type exported abstract + , emptyTrie -- :: Trie a + , Search(..) -- data Search a = Exists | New a + , match -- :: [a] -> Trie a -> Search (Trie a) ) where -- | A Trie is a lookup structure for strings of tokens. @@ -28,9 +28,9 @@ -- or FoundAnd, means that the corresponding string is not stored. data Trie a = Trie [(a,Trie a)] | Found | FoundAnd [(a,Trie a)] - deriving Show + deriving Show data Search a = Exists | New {fromNew::a} - deriving Show + deriving Show emptyTrie :: Trie a emptyTrie = Trie [] diff --git a/trans/AuxFile.hs b/trans/AuxFile.hs --- a/trans/AuxFile.hs +++ b/trans/AuxFile.hs @@ -3,7 +3,7 @@ import Flags(Flags,sIncludes,sPreludes,sDbgTrusted) import Environment(Environment,Entity,HxEntity,exports,imports,hxEnvironmentToList,listToHxEnvironment) import Relation(unionRelations) -import Language.Haskell.Exts.Annotated +import Language.Haskell.Exts (Module(..),ModuleHead(..),ExportSpecList(..),ExportSpec(..) ,ImportDecl(..),ModuleName(..),QName(..),SrcSpanInfo) import SynHelp (mkQName,Id(getId),getModuleNameFromModule) diff --git a/trans/Derive.hs b/trans/Derive.hs --- a/trans/Derive.hs +++ b/trans/Derive.hs @@ -3,7 +3,7 @@ -- produce all the instances demanded. module Derive (derive) where -import Language.Haskell.Exts.Annotated +import Language.Haskell.Exts import Wired (mkExpDeriveEqualEqual,mkExpDeriveAndAnd,mkExpDeriveTrue,mkExpDeriveFalse,qNameBuiltinIdent) import SynHelp (Id(getId),appN,tyAppN,litInt,litString,litChar,conDeclName,conDeclArity ,mkQName, fieldDeclNames diff --git a/trans/Environment.hs b/trans/Environment.hs --- a/trans/Environment.hs +++ b/trans/Environment.hs @@ -17,10 +17,12 @@ ,wiredEnv ) where -import Language.Haskell.Exts.Annotated hiding (Var,Con,Fixity,EVar) -import qualified Language.Haskell.Exts.Annotated as Syntax (Exp(Var,Con),Fixity(Fixity),ExportSpec(EVar) - ,Namespace(NoNamespace,TypeNamespace)) -import qualified Language.Haskell.Exts as Short(Assoc(..),QName(..),Name(..),SpecialCon(Cons)) +import Language.Haskell.Exts hiding (Var,Con,Fixity,EVar,TApp) +import qualified Language.Haskell.Exts as + Syntax (Exp(Var,Con),Fixity(Fixity),ExportSpec(EVar) + ,Namespace(NoNamespace,TypeNamespace)) +-- import qualified Language.Haskell.Exts as +-- Short(Assoc(..),QName(..),Name(..),SpecialCon(Cons)) import SynHelp (Id(getId),getQualified,mkQual,qual,isQual,isUnQual,notSupported ,tyVarBind2Name,declHeadTyVarBinds,declHeadName,instRuleQName,getArityFromConDecl ,getConDeclFromQualConDecl,getConstructorFromConDecl,eqName,mkName,mkQName @@ -52,10 +54,10 @@ -- conids back to the type they belong to. It also relates methods -- to their class. data Identifier = Var String | Con TypeSort String{-type-} String{-con-} - | Field String{-type-} String{-field-} - | Method String{-class-} String{-method-} + | Field String{-type-} String{-field-} + | Method String{-class-} String{-method-} | TypeClass String - deriving (Show,Read,Eq,Ord) + deriving (Show,Read,Eq,Ord) data TypeSort = Data | Newtype deriving (Show,Read,Eq,Ord) toTypeSort :: DataOrNew l -> TypeSort @@ -65,10 +67,10 @@ -- AuxiliaryInfo is the extra information we need to know about identifiers. data AuxiliaryInfo = Value {- variable or constructor -} - { args :: Int - , fixity :: Fixity - , priority :: Int - , letBound :: Bool + { args :: Int + , fixity :: Fixity + , priority :: Int + , letBound :: Bool , traced :: Bool} | TyCls TyCls -- needed for im/export of (..) deriving (Eq,Ord,Show,Read) @@ -341,8 +343,10 @@ where tyName = declHeadName declHead Syn n body = splitSynonym fullEnv (map tyVarBind2Name (declHeadTyVarBinds declHead)) ty -declEnv _ _ (TypeFamDecl l declHead _) = +declEnv _ _ (TypeFamDecl l declHead _ _) = notSupported l "type family declaration" +declEnv _ _ (ClosedTypeFamDecl l _ _ _ _) = + notSupported l "closed type family declaration" declEnv tracing _ (DataDecl _ ts _ declHead qualConDecls _) = fromList (eType (getId name) (map getId consNames) (map getId fieldNames) : [eCon (getId consName) (ann consName) (getArityFromConDecl conDecl) (getId name) @@ -384,8 +388,8 @@ getDecl :: ClassDecl SrcSpanInfo -> Decl SrcSpanInfo getDecl (ClsDecl _ decl) = decl getDecl (ClsDataFam l _ _ _) = notSupported l "associated data type declaration" - getDecl (ClsTyFam l _ _) = notSupported l "associated type synonym declaration" - getDecl (ClsTyDef l _ _) = notSupported l + getDecl (ClsTyFam l _ _ _) = notSupported l "associated type synonym declaration" + getDecl (ClsTyDef l _) = notSupported l "default choice for an associated type synonym" declEnv _ _ (InstDecl _ _ _ Nothing) = emptyRelation declEnv tracing finalEnv (InstDecl _ _ instHead (Just instDecls)) = emptyRelation @@ -513,7 +517,7 @@ exports :: Bool -> Module SrcSpanInfo -> Environment -> HxEnvironment exports tracing mod@(Module l maybeModuleHead _ _ _) env = case maybeModuleHead of - Nothing -> exportList [Syntax.EVar l (Syntax.NoNamespace l) (UnQual l (Ident l "main"))] + Nothing -> exportList [Syntax.EVar l (UnQual l (Ident l "main"))] Just (ModuleHead _ _ _ Nothing) -> getQualified `mapDom` moduleDefines tracing env mod Just (ModuleHead _ _ _ (Just (ExportSpecList _ list))) -> exportList list where @@ -536,12 +540,13 @@ subs = restrictRng (`isOwned` allOwners) env qNameT = dropAnn qName (qName,mSub) = case eSpec of - Syntax.EVar _ (Syntax.NoNamespace _) qName -> (qName, emptyRelation) - Syntax.EVar _ (Syntax.TypeNamespace l) _ -> notSupported l "type namespace in export" - EAbs _ qName -> (qName, emptyRelation) - EThingAll _ qName -> (qName, subs) - EThingWith _ qName cNames -> + Syntax.EVar _ qName -> (qName, emptyRelation) + EAbs _ (Syntax.NoNamespace _) qName -> (qName, emptyRelation) + EAbs _ _ qName -> notSupported () "type or pattern namespace in export" + EThingWith _ (NoWildcard _) qName cNames -> (qName, restrictDom ((`elem` map getId cNames) . getId) subs) + EThingWith _ _ qName cNames -> notSupported () "wildcard in export" + EModuleContents _ mName -> notSupported () "module name in export" -- Assumes that list is in ascending order without duplicate names. listToHxEnvironment :: [HxEntity] -> HxEnvironment @@ -585,9 +590,9 @@ subs = restrictRng (`isOwned` allOwners) exports nameT = dropAnn name (name,fSub,noSubSpec) = case iSpec of - IVar _ (NoNamespace _) name -> (name, emptyRelation, True) - IVar _ (TypeNamespace l) _ -> notSupported l "type name space in import" - IAbs _ name -> (name, emptyRelation, True) + IVar _ name -> (name, emptyRelation, True) + IAbs _ (NoNamespace _) name -> (name, emptyRelation, True) + IAbs _ _ name -> notSupported () "type or pattern name space in import" IThingAll _ name -> (name, subs, False) IThingWith _ name cNames -> (name, restrictDom ((`elem` map getId cNames) . getId) subs, False) @@ -775,13 +780,13 @@ makeFixity :: Entity -> Syntax.Fixity makeFixity e = Syntax.Fixity (transFixity (eFixity e)) (ePriority e) (mkName (eId e)) where - transFixity :: Fixity -> Short.Assoc - transFixity None = Short.AssocNone - transFixity L = Short.AssocLeft - transFixity R = Short.AssocRight + transFixity :: Fixity -> Assoc () + transFixity None = AssocNone () + transFixity L = AssocLeft () + transFixity R = AssocRight () transFixity _ = error "Environment.env2Fixities: unexpected associativity." - mkName :: String -> Short.QName - mkName s = Short.UnQual (if isAlpha (head s) then Short.Ident s else Short.Symbol s) + mkName :: String -> QName () + mkName s = UnQual () (if isAlpha (head s) then Ident () s else Symbol () s) -- Intentionally never create a special name, because fixities must be UnQual. diff --git a/trans/Flags.hs b/trans/Flags.hs --- a/trans/Flags.hs +++ b/trans/Flags.hs @@ -34,15 +34,15 @@ ,sSrcDir :: String --v Flags to control compilation - ,sPrelude :: Bool -- keep prelude defns in interface file + ,sPrelude :: Bool -- keep prelude defns in interface file --v Flags to control compilation for tracing - ,sDbgTrusted :: Bool -- trust this module - ,sWrap :: Bool -- wrap original defns rather than transforming + ,sDbgTrusted :: Bool -- trust this module + ,sWrap :: Bool -- wrap original defns rather than transforming --v debugging flags - show program / import tables (after each compiler phase) - ,sParse :: Bool -- ast after parsing - ,sIBound :: Bool -- environment + ,sParse :: Bool -- ast after parsing + ,sIBound :: Bool -- environment ,sFixities :: Bool -- fixity declarations in top-level scope --v pretty-printing flags @@ -107,13 +107,13 @@ where (rootdir,filename) = splitFileName sourcefile flags = FF - {sSourceFile = sourcefile -- original name + {sSourceFile = sourcefile -- original name ,sHatAuxFile = rootdir replaceExtension filename "hx" ,sHatTransFile = rootdir "Hat" replaceExtension filename "hs" ,sIncludes = [] ,sPreludes = [] ,sSrcDir = rootdir "Hat" -- directory for transformed sources - ,sPrelude = False + ,sPrelude = False ,sDbgTrusted = False ,sWrap = False ,sParse = False diff --git a/trans/HatTrans.hs b/trans/HatTrans.hs --- a/trans/HatTrans.hs +++ b/trans/HatTrans.hs @@ -17,7 +17,7 @@ import Flags(processArgs,Flags,sSourceFile,sParse,sFixities,sPrelude,sPreludes,sIncludes,sDbgTrusted ,sWrap,sIBound,sShowWidth,sHatAuxFile,sHatTransFile,sSrcDir) import System.FilePath(FilePath(..),splitDirectories,combine) -import Language.Haskell.Exts.Annotated(ParseMode(..),Language(..),Extension(..),KnownExtension(..) +import Language.Haskell.Exts(ParseMode(..),Language(..),Extension(..),KnownExtension(..) ,ParseResult ,fromParseResult,parseFileWithMode ,Module(..),ImportDecl(..),ModuleName(..),applyFixities) @@ -47,7 +47,8 @@ ,EnableExtension NPlusKPatterns] ,ignoreLanguagePragmas = False ,ignoreLinePragmas = True - ,fixities = Nothing} + ,fixities = Nothing + ,ignoreFunctionArity = False} parseResult <- parseFileWithMode parseMode filePath let moduleAST = fromParseResult parseResult dumpIntermediate (sParse flags) "Parse" (pretty moduleAST) diff --git a/trans/SynHelp.hs b/trans/SynHelp.hs --- a/trans/SynHelp.hs +++ b/trans/SynHelp.hs @@ -4,7 +4,7 @@ module SynHelp (module SynHelp, noSpan) where -import Language.Haskell.Exts.Annotated +import Language.Haskell.Exts import Wired (nameTransModule,tracingModuleNameShort,Arity(..),noSpan) import Data.Char (isAlpha) import Data.List (stripPrefix) diff --git a/trans/TraceTrans.hs b/trans/TraceTrans.hs --- a/trans/TraceTrans.hs +++ b/trans/TraceTrans.hs @@ -17,7 +17,7 @@ module TraceTrans (traceTrans, Tracing(..)) where -import Language.Haskell.Exts.Annotated +import Language.Haskell.Exts import System.FilePath (FilePath,takeBaseName) import Data.Maybe (fromMaybe,isNothing,isJust,fromJust) import Data.List (stripPrefix,nubBy,partition) @@ -164,23 +164,23 @@ String -> -- name of *this* module, being transformed ExportSpec SrcSpanInfo -> [ExportSpec SrcSpanInfo] -tExportSpec env _ _ (EVar span nameSpace qname) = - map (EVar span nameSpace) (tEntityVar env qname) -tExportSpec env _ _ (EAbs span qname) = - map (EAbs span) qnames' +tExportSpec env _ _ (EVar span qname) = + map (EVar span) (tEntityVar env qname) +tExportSpec env _ _ (EAbs span namespace qname) = + map (EAbs span namespace) qnames' where qnames' = tEntityAbs env qname -tExportSpec env decls thisModule (EThingAll span qName) - | isClass e = [EThingAll span (nameTransCls qName)] - | isType e = tExportSpec env decls thisModule - (EThingWith span qName (map conName (eCons e) ++ map fieldName (eFields e))) - | otherwise = error "TraceTrans.tExportSpec: type synonym with (..)." - where - e = lookupTypeEnv env qName - conName str = ConName span (Symbol span str) - fieldName str = VarName span (Ident span str) -tExportSpec env _ _ (EThingWith span qname cnames) = - EThingWith span qname' cnames' : map (EVar span (NoNamespace span)) qnames' +-- tExportSpec env decls thisModule (EThingAll span qName) +-- | isClass e = [EThingAll span (nameTransCls qName)] +-- | isType e = tExportSpec env decls thisModule +-- (EThingWith span qName (map conName (eCons e) ++ map fieldName (eFields e))) +-- | otherwise = error "TraceTrans.tExportSpec: type synonym with (..)." +-- where +-- e = lookupTypeEnv env qName +-- conName str = ConName span (Symbol span str) +-- fieldName str = VarName span (Ident span str) +tExportSpec env _ _ (EThingWith span wildcard qname cnames) = + EThingWith span wildcard qname' cnames' : map (EVar span) qnames' where (qname', cnames', qnames') = tEntityThingWith env qname cnames tExportSpec env decls thisModuleId @@ -193,21 +193,21 @@ -- These are all entities defined in this module and meant for export. makeExport :: Decl SrcSpanInfo -> [ExportSpec SrcSpanInfo] makeExport (TypeDecl l declHead _) = - [EAbs l (UnQual l (getDeclHeadName declHead))] -makeExport (TypeFamDecl l declHead _) = - [EAbs l (UnQual l (getDeclHeadName declHead))] + [EVar l (UnQual l (getDeclHeadName declHead))] +makeExport (TypeFamDecl l declHead _ _) = + [EVar l (UnQual l (getDeclHeadName declHead))] makeExport (DataDecl l _ _ declHead _ _) = - [EThingAll l (UnQual l (getDeclHeadName declHead))] + [EThingWith l (EWildcard l 0) (UnQual l (getDeclHeadName declHead)) []] makeExport (GDataDecl l _ _ declHead _ _ _) = - [EThingAll l (UnQual l (getDeclHeadName declHead))] + [EThingWith l (EWildcard l 0) (UnQual l (getDeclHeadName declHead)) []] makeExport (ClassDecl l _ declHead _ _) = - [EThingAll l (UnQual l (getDeclHeadName declHead))] + [EThingWith l (EWildcard l 0) (UnQual l (getDeclHeadName declHead)) []] makeExport (FunBind l matches) = - if exportedTransName name then [EVar l (NoNamespace l) (UnQual l name)] else [] + if exportedTransName name then [EVar l (UnQual l name)] else [] where name = getMatchName (head matches) makeExport (PatBind l (PVar l' name) _ _) = - if exportedTransName name then [EVar l (NoNamespace l) (UnQual l name)] else [] + if exportedTransName name then [EVar l (UnQual l name)] else [] makeExport _ = [] -- Checks whether this is the name of a function that should be exported @@ -285,12 +285,12 @@ -- Nearly identical with tExportSpec except for the types. tImportSpec :: Environment -> ImportSpec SrcSpanInfo -> [ImportSpec SrcSpanInfo] -tImportSpec env (IVar span nameSpace name) = - map (IVar span nameSpace . qName2Name) qnames' +tImportSpec env (IVar span name) = + map (IVar span . qName2Name) qnames' where qnames' = tEntityVar env (UnQual (ann name) name) -tImportSpec env (IAbs span name) = - map (IAbs span . qName2Name) qnames' +tImportSpec env (IAbs span namespace name) = + map (IAbs span namespace . qName2Name) qnames' where qnames' = tEntityAbs env (UnQual (ann name) name) tImportSpec env (IThingAll span name) @@ -304,7 +304,7 @@ fieldName str = VarName span (mkName span str) tImportSpec env (IThingWith span name cnames) = IThingWith span (qName2Name qname') cnames' : - map (IVar span (NoNamespace span) . qName2Name) qnames' + map (IVar span . qName2Name) qnames' where (qname', cnames', qnames') = tEntityThingWith env (UnQual (ann name) name) cnames @@ -573,7 +573,7 @@ tTypeSynonym :: Decl SrcSpanInfo -> Decl SrcSpanInfo tTypeSynonym (TypeDecl span declHead ty) = TypeDecl span (declHead) (tType ty) -tDecl _ _ _ (TypeFamDecl l _ _) = +tDecl _ _ _ (TypeFamDecl l _ _ _) = notSupported l "type family declaration" tDecl env Global tracing d@(DataDecl span dataOrNew maybeContext declHead qualConDecls maybeDeriving) = @@ -1246,9 +1246,9 @@ (decls', moduleConsts) = tClassInstDecl env tracing decl tClassDecl env tracing (ClsDataFam l _ _ _) = notSupported l "declaration of an associated data type" -tClassDecl env tracing (ClsTyFam l _ _) = +tClassDecl env tracing (ClsTyFam l _ _ _) = notSupported l "declaration of an associated type synonym" -tClassDecl env tracing (ClsTyDef l _ _) = +tClassDecl env tracing (ClsTyDef l _) = notSupported l "default choice for an associated type synonym" -- Transform a standard declaration inside a class or instance declaration. diff --git a/trans/Wired.hs b/trans/Wired.hs --- a/trans/Wired.hs +++ b/trans/Wired.hs @@ -1,6 +1,6 @@ module Wired where -import Language.Haskell.Exts.Annotated +import Language.Haskell.Exts import Data.Maybe (fromMaybe) import Data.List (stripPrefix) diff --git a/trans/Wrap.hs b/trans/Wrap.hs --- a/trans/Wrap.hs +++ b/trans/Wrap.hs @@ -38,7 +38,7 @@ --------------------------------------------------------------------------- -} module Wrap (wrap) where -import Language.Haskell.Exts.Annotated +import Language.Haskell.Exts import System.FilePath(FilePath) import SynHelp (nameFromOp,mkQual,declHeadName,declHeadTyVarBinds,getId ,isUnQual,getModuleNameFromModule,tyVarBind2Type,notSupported) @@ -67,11 +67,11 @@ \name -> (name `within`) `any` exportSpecs where within :: SrcInfo l2 => Name l1 -> ExportSpec l2 -> Bool - name `within` (EVar l (NoNamespace _) qname) = same modName name qname - name `within` (EVar l (TypeNamespace _) _) = notSupported l "type namespace in export specification" - name `within` (EAbs l qname) = same modName name qname - name `within` (EThingAll l qname) = same modName name qname - name `within` (EThingWith l qname cnames) = same modName name qname + name `within` (EVar l qname) = same modName name qname + name `within` (EAbs l (NoNamespace _) qname) = same modName name qname + name `within` (EAbs l _ qname) = notSupported l "type or pattern namespace in export specification" + name `within` (EThingWith l (NoWildcard _) qname cnames) = same modName name qname + name `within` (EThingWith l _ qname cnames) = notSupported l "wildcard in export specification" name `within` (EModuleContents l eModName) = getId modName == getId eModName same :: ModuleName l1 -> Name l2 -> QName l3 -> Bool same mod n q = getId n == getId q && (isUnQual q || (\(Qual _ qm qn) -> getId qm == getId mod) q)