diff --git a/Hat/Hat.hs b/Hat/Hat.hs --- a/Hat/Hat.hs +++ b/Hat/Hat.hs @@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-} -{-# OPTIONS -#include "hat-c.h" #-} -- ---------------------------------------------------------------------------- -- Library used by all programs transformed for tracing by Hat. -- Combinators in Haskell and interfaces to C-functions. diff --git a/Hat/System.hs b/Hat/System.hs --- a/Hat/System.hs +++ b/Hat/System.hs @@ -12,7 +12,7 @@ import Hat.PreludeBuiltinTypes as T import Hat.SystemBuiltinTypes as T import Hat.SystemBuiltin as T -import qualified System.Cmd as Cmd +import qualified System.Process as Process import qualified System.Environment as Environment import qualified System.Exit as Exit @@ -48,7 +48,7 @@ gsystem psystem p = T.ufun1 asystem psystem p hsystem hsystem z1system ksystem = T.fromIO T.fromExitCode ksystem - (Cmd.system (T.toString ksystem z1system)) + (Process.system (T.toString ksystem z1system)) gexitWith :: T.RefSrcPos -> diff --git a/hat.cabal b/hat.cabal --- a/hat.cabal +++ b/hat.cabal @@ -1,6 +1,6 @@ name: hat -version: 2.8.0.0 +version: 2.9.0.0 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 @@ -8,23 +8,25 @@ Various tools (hat-trail, hat-observe, hat-explore ...) then allow viewing the trace file in different ways, to locate a bug or understand how a program works. - Hat 2.8 uses the haskell-src-exts parser and other Hackage libraries to + Hat 2.9 uses the haskell-src-exts parser and other Hackage libraries to reduce its own size and simplify extensions. Module imports and exports have also been improved to handle nearly all kinds of renaming, hiding, etc. - Hat 2.8 works only with ghc for Haskell 98 (plus a few extensions) and + Hat 2.9 works only with ghc for Haskell 98 (plus a few extensions) and the standard Haskell 98 libraries plus some Haskell 2010 libraries. Although it should build on any operating system, most viewing tools use ASCII console escape sequences and they open xterms; hence they will only work well under Unix and X11. - Tested on MacOS X 10.8.4. + Tested on MacOS X 10.9.5. Installation: > cabal -v install Flag -v allows you to see what is going on. Building takes a long time - (one module has 25.000 lines of code). Don't worry about numerous warning messages. + (one module has 25.000 lines of code). + Don't worry about numerous warning messages. The tracing transformation does produce + code with lots of overlapping patterns. Use: @@ -46,11 +48,11 @@ homepage: http://projects.haskell.org/hat/ license: OtherLicense license-file: docs/copyright.html -copyright: (c) 2000-2013 Hat team +copyright: (c) 2000-2015 Hat team author: Hat team maintainer: oc@kent.ac.uk stability: provisional -tested-with: GHC ==7.4.1 +tested-with: GHC ==7.8.3 bug-reports: oc@kent.ac.uk category: Development build-type: Simple @@ -78,11 +80,11 @@ 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.13, containers >= 0.5.2, filepath >= 1.3 + build-depends: base >=4.5, bytestring >=0.9, directory >=1.1, haskell-src-exts >= 1.16, 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 - cc-options: -DFILEVERSION="2.08" -DVERSION="2.08" + cc-options: -DFILEVERSION="2.08" -DVERSION="2.9" executable hat-trail main-is: HatTrail.hs @@ -93,18 +95,18 @@ includes: art.h include-dirs: include c-sources: tools/pathutils.c, tools/artutils.c, tools/finitemap.c - cc-options: -DFILEVERSION="2.08" -DVERSION="2.08" + cc-options: -DFILEVERSION="2.08" -DVERSION="2.9" executable hat-observe main-is: HatObserve.hs hs-source-dirs: tools - other-modules: Observe, LowLevel, SExp, Ident, PrettyLibHighlight, HighlightStyle, Pattern, ParseLib, Idents, CmdLine, CommonUI, SrcRef, Trie, TExp - build-depends: base >=4.5, process >=1.1, haskeline >=0.6 + 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 extensions: ForeignFunctionInterface includes: art.h include-dirs: include c-sources: tools/pathutils.c, tools/artutils.c, tools/finitemap.c, tools/hat-names.c, tools/observeutils.c - cc-options: -DFILEVERSION="2.08" -DVERSION="2.08" + cc-options: -DFILEVERSION="2.08" -DVERSION="2.9" executable hat-stack main-is: HatStackText.hs @@ -115,7 +117,7 @@ includes: art.h include-dirs: include c-sources: tools/pathutils.c, tools/artutils.c, tools/finitemap.c - cc-options: -DFILEVERSION="2.08" -DVERSION="2.08" + cc-options: -DFILEVERSION="2.08" -DVERSION="2.9" executable hat-explore main-is: HatExplore.hs @@ -126,7 +128,7 @@ includes: art.h include-dirs: include c-sources: tools/parentset.c, tools/detectutils.c, tools/pathutils.c, tools/artutils.c, tools/finitemap.c - cc-options: -DFILEVERSION="2.08" -DVERSION="2.08" + cc-options: -DFILEVERSION="2.08" -DVERSION="2.9" executable hat-detect -- currently just calls hat-delta; was a separate tool @@ -138,7 +140,7 @@ includes: art.h, ntohl.h include-dirs: include c-sources: tools/detectutils.c, tools/parentset.c, tools/pathutils.c, tools/artutils.c, tools/finitemap.c - cc-options: -DFILEVERSION="2.08" -DVERSION="2.08" + cc-options: -DFILEVERSION="2.08" -DVERSION="2.9" executable hat-check main-is: HatCheck.hs @@ -148,7 +150,7 @@ includes: art.h, ntohl.h include-dirs: include c-sources: tools/hat-check.c - cc-options: -DFILEVERSION="2.08" -DVERSION="2.08" + cc-options: -DFILEVERSION="2.08" -DVERSION="2.9" executable hat-view main-is: SrcRefViewer.hs @@ -169,7 +171,7 @@ includes: art.h, ntohl.h include-dirs: include c-sources: tools/pathutils.c, tools/artutils.c, tools/finitemap.c - cc-options: -DFILEVERSION="2.08" -DVERSION="2.08" + cc-options: -DFILEVERSION="2.08" -DVERSION="2.9" executable black-hat main-is: BlackHat.hs @@ -180,7 +182,7 @@ includes: art.h, ntohl.h include-dirs: include c-sources: tools/nontermutils.c, tools/pathutils.c, tools/artutils.c, tools/finitemap.c - cc-options: -DFILEVERSION="2.08" -DVERSION="2.08" + cc-options: -DFILEVERSION="2.08" -DVERSION="2.9" executable hat-nonterm main-is: HatNonTerm.hs @@ -191,7 +193,7 @@ includes: art.h, ntohl.h include-dirs: include c-sources: tools/nontermutils.c, tools/pathutils.c, tools/artutils.c, tools/finitemap.c - cc-options: -DFILEVERSION="2.08" -DVERSION="2.08" + cc-options: -DFILEVERSION="2.08" -DVERSION="2.9" executable hat-anim main-is: HatAnim.hs @@ -202,7 +204,7 @@ includes: art.h, ntohl.h include-dirs: include c-sources: tools/detectutils.c, tools/parentset.c, tools/pathutils.c, tools/artutils.c, tools/finitemap.c - cc-options: -DFILEVERSION="2.08" -DVERSION="2.08" + cc-options: -DFILEVERSION="2.08" -DVERSION="2.9" executable pretty-hat main-is: PrettyHat.hs @@ -213,7 +215,7 @@ includes: art.h, ntohl.h include-dirs: include c-sources: tools/detectutils.c, tools/parentset.c, tools/pathutils.c, tools/artutils.c, tools/finitemap.c - cc-options: -DFILEVERSION="2.08" -DVERSION="2.08" + cc-options: -DFILEVERSION="2.08" -DVERSION="2.9" executable hat-delta main-is: HatDelta.hs @@ -224,7 +226,8 @@ includes: art.h, ntohl.h include-dirs: include c-sources: tools/detectutils.c, tools/parentset.c, tools/pathutils.c, tools/artutils.c, tools/finitemap.c - cc-options: -DFILEVERSION="2.08" -DVERSION="2.08" + cc-options: -DFILEVERSION="2.08" -DVERSION="2.9" + executable hat-make main-is: HatMake.hs diff --git a/libraries/System.hs b/libraries/System.hs --- a/libraries/System.hs +++ b/libraries/System.hs @@ -6,7 +6,7 @@ import PreludeBuiltinTypes as NotHat.T import SystemBuiltinTypes as NotHat.T import SystemBuiltin as NotHat.T -import qualified NotHat.System.Cmd as NotHat.Cmd +import qualified NotHat.System.Process as NotHat.Process import qualified NotHat.System.Environment as NotHat.Environment import qualified NotHat.System.Exit as NotHat.Exit @@ -16,7 +16,7 @@ getProgName :: IO String foreign import ccall "NotHat.Environment.getEnv" getEnv :: String -> IO String -foreign import ccall "NotHat.Cmd.system" +foreign import ccall "NotHat.Process.system" system :: String -> IO ExitCode foreign import ccall "NotHat.Exit.exitWith" exitWith :: ExitCode -> IO a diff --git a/tools/BlackHat.hs b/tools/BlackHat.hs --- a/tools/BlackHat.hs +++ b/tools/BlackHat.hs @@ -3,7 +3,7 @@ import NonTermLib import LowLevel import SExp -import System.Cmd (system) +import System.Process (system) import System.Environment (getArgs,getProgName,getEnv) import System.Exit (exitWith,ExitCode(..)) import Data.List (isPrefixOf,isSuffixOf,group,groupBy) diff --git a/tools/Delta.hs b/tools/Delta.hs --- a/tools/Delta.hs +++ b/tools/Delta.hs @@ -13,7 +13,7 @@ ) where import Data.Char (toLower,ord) -import System.Cmd (system) +import System.Process (system) import System.Environment (getArgs,getProgName) import System.Exit (exitWith,ExitCode(..)) import Control.Monad (when) diff --git a/tools/HatAnim.hs b/tools/HatAnim.hs --- a/tools/HatAnim.hs +++ b/tools/HatAnim.hs @@ -15,7 +15,7 @@ ,highlight,Highlight(..),Colour(..) ,enableScrollRegion,getTerminalSize ,savePosition,restorePosition) -import System.Cmd (system) +import System.Process (system) import System.Environment (getArgs,getProgName,getEnv) import System.Exit (exitWith,ExitCode(..)) import Data.List (isPrefixOf,isSuffixOf,group,groupBy) @@ -54,7 +54,7 @@ _ -> (0,0) hSetBuffering stdin NoBuffering hSetBuffering stdout NoBuffering - System.Cmd.system ("stty -icanon min 1 -echo") + system ("stty -icanon min 1 -echo") (columns,lines) <- getTerminalSize putStr (show start) let startExp = (removeNonResultCycles diff --git a/tools/HatDelta.hs b/tools/HatDelta.hs --- a/tools/HatDelta.hs +++ b/tools/HatDelta.hs @@ -5,7 +5,7 @@ import Data.List (isSuffixOf, intersperse, nubBy, delete, minimumBy ,isPrefixOf, sortBy) import Data.Char (toLower) -import System.Cmd (system) +import System.Process (system) import System.Environment (getArgs,getProgName) import System.Exit (exitWith,ExitCode(..)) import Foreign.C.String (withCString) diff --git a/tools/HatDetect.hs b/tools/HatDetect.hs --- a/tools/HatDetect.hs +++ b/tools/HatDetect.hs @@ -16,7 +16,7 @@ import Data.Maybe import System.Environment (getArgs,getProgName) import System.Exit (exitWith,ExitCode(..)) -import System.Cmd (system) +import System.Process (system) import Control.Monad (when) import Data.List (isPrefixOf,isSuffixOf,intersperse) import Data.Char (isDigit,digitToInt,toLower,isSpace) diff --git a/tools/HatExplore.hs b/tools/HatExplore.hs --- a/tools/HatExplore.hs +++ b/tools/HatExplore.hs @@ -17,7 +17,7 @@ import Foreign.C.String (withCString) import Numeric (showHex) import System.IO.Unsafe (unsafePerformIO) -import System.Cmd (system) +import System.Process (system) import System.Environment (getArgs,getProgName,getEnv) import System.Exit (exitWith,ExitCode(..)) import Data.List (isSuffixOf,sortBy,partition,union) @@ -652,22 +652,22 @@ then loop state{message = "There is only one module."} else loop state{modules = rotateRight (modules state)} 'o' -> do - System.Cmd.system (hatObserve + system (hatObserve (dropHS (filename (cur (modules state)))) (head (words (removeHighlights -- crude approximation (prettyEquation2 initialOptions (cur (redexes state))))))) loop state{message = "Spawned hat-observe"} 'l' -> do - System.Cmd.system (hatTrail (dropHS (filename (cur (modules state)))) + system (hatTrail (dropHS (filename (cur (modules state)))) (cur (redexes state))) loop state{message = "Spawned hat-trail"} 'e' -> do - System.Cmd.system (hatDetect + system (hatDetect (dropHS (filename (cur (modules state)))) (cur (redexes state))) loop state{message = "Spawned hat-detect"} 'i' -> do - System.Cmd.system (hatAnim (dropHS (filename (cur (modules state)))) + system (hatAnim (dropHS (filename (cur (modules state)))) (cur (redexes state))) loop state{message = "Spawned hat-anim"} 'h' -> help >> loop state diff --git a/tools/HatMake.hs b/tools/HatMake.hs --- a/tools/HatMake.hs +++ b/tools/HatMake.hs @@ -4,7 +4,7 @@ module Main where import System.Environment (getArgs) -import System.Cmd (system) +import System.Process (system) import System.Exit (ExitCode(..), exitFailure) import Data.List (nub, partition, isPrefixOf, intersperse, concat) import Data.Char (isSpace) @@ -19,7 +19,8 @@ let opts = init x let optStr = concat (intersperse " " opts) let y = last x - systemTry $ "ghc -M -dep-makefile .depend " ++ y ++ " " ++ optStr + systemTry $ "ghc -M -dep-makefile .depend -dep-suffix \"\" " + ++ y ++ " " ++ optStr mak <- readFile ".depend" let (files,depends) = parseMakefile mak translate hatFolder files depends diff --git a/tools/HatNonTerm.hs b/tools/HatNonTerm.hs --- a/tools/HatNonTerm.hs +++ b/tools/HatNonTerm.hs @@ -10,7 +10,7 @@ ,enableScrollRegion,getTerminalSize ,savePosition,restorePosition) import Control.Monad (when) -import System.Cmd (system) +import System.Process (system) import System.Environment (getArgs,getProgName,getEnv) import System.Exit (exitWith,ExitCode(..)) import Data.List (isPrefixOf,isSuffixOf,group,groupBy) diff --git a/tools/HatObserve.hs b/tools/HatObserve.hs --- a/tools/HatObserve.hs +++ b/tools/HatObserve.hs @@ -4,7 +4,7 @@ import Data.List (sort,isPrefixOf,isSuffixOf,intersperse) import Control.Monad (when,liftM) -- import System -import System.Cmd (system) +import System.Process (system) import System.Exit (ExitCode(..), exitWith) import System.Environment (getArgs, getProgName) import Data.Char (isDigit,digitToInt,isUpper,toUpper,isAlphaNum,isSpace) @@ -274,7 +274,7 @@ do node <- getEquationNumber n (lastObserved state) let sr = getSrcRef (fromJust node) when (isJust node && sr /= LowLevel.nil) - (do System.Cmd.system (hatView (readSrcRef sr)) + (do system (hatView (readSrcRef sr)) return ()) interactive state doCommand (Definition n) state = @@ -282,7 +282,7 @@ let atom = getDefnRef (fromJust node) when (isJust node) (do defnSR <- liftM defnSrcRef (getIdentAt atom) - System.Cmd.system (hatView defnSR) + system (hatView defnSR) return ()) interactive state diff --git a/tools/HatTrail.hs b/tools/HatTrail.hs --- a/tools/HatTrail.hs +++ b/tools/HatTrail.hs @@ -17,7 +17,7 @@ ,savePosition,restorePosition) import qualified Control.Exception(catch,IOException) import Control.Monad (when,liftM) -import System.Cmd (system) +import System.Process (system) import System.Environment (getArgs,getProgName,getEnv) import System.Exit (exitWith,ExitCode(..)) import System.Directory (doesFileExist) @@ -83,7 +83,7 @@ , options=initialOptions {equations=False} } hSetBuffering stdin NoBuffering hSetBuffering stdout NoBuffering - System.Cmd.system ("stty -icanon min 1 -echo") + system ("stty -icanon min 1 -echo") case args of [f,"-remote",n] -> remote state (read n) _ -> begin state errloc errmsg output (map peekTrace bridge) @@ -162,7 +162,7 @@ resetSystem state = do putStr (enableScrollRegion 1 (height state)) putStr (goto 1 (height state)) - System.Cmd.system ("stty icanon echo") + system ("stty icanon echo") return () @@ -357,32 +357,32 @@ (map (\(i,e)->(i,cut lab e)) ctx') in do repaint state ((lineno,newctx):tail stack) loop (label e) newctx - Expand -> let newctx = Sctx (join state lab e) - (map (\(i,e)->(i,join state lab e)) ctx') + Expand -> let newctx = Sctx (joinE state lab e) + (map (\(i,e)->(i,joinE state lab e)) ctx') in do repaint state ((lineno,newctx):tail stack) loop (label e) newctx Revert -> let newctx = Sctx (revert state lab e) (map (\(i,e)->(i,revert state lab e)) ctx') in do repaint state ((lineno,newctx):tail stack) loop (label e) newctx - Detect -> do System.Cmd.system (hatDetect (file state) node) + Detect -> do system (hatDetect (file state) node) interpret lab ctx extent - Trail -> do System.Cmd.system (hatTrail (file state) node) + Trail -> do system (hatTrail (file state) node) interpret lab ctx extent - Anim -> do System.Cmd.system (hatAnim (file state) node) + Anim -> do system (hatAnim (file state) node) interpret lab ctx extent - Explore -> do System.Cmd.system (hatExplore (file state) node) + Explore -> do system (hatExplore (file state) node) interpret lab ctx extent - ObserveAll -> do System.Cmd.system (hatObserve (file state) + ObserveAll -> do system (hatObserve (file state) (showQN True (funId e))) interpret lab ctx extent ObservePat p -> - do System.Cmd.system (hatObserve (file state) p) + do system (hatObserve (file state) p) interpret lab ctx extent ObserveSrc -> do let srcref = expSrcRef e when (srcref /= nil) (let sr = readSrcRef srcref in - do System.Cmd.system + do system (hatObserve (file state) (SrcRef.filename sr ++" "++show (SrcRef.line sr) @@ -394,7 +394,7 @@ Resize -> resize state stack Source -> do let srcref = expSrcRef e when (srcref /= nil) - (do System.Cmd.system (hatView (readSrcRef srcref)) + (do system (hatView (readSrcRef srcref)) showSrcRef e state) interpret lab ctx extent Definition -> let defn = getDefnRef (funLabel e) @@ -411,7 +411,7 @@ (funId e) ++": defn not found") state else do - System.Cmd.system (hatView defnSR) + system (hatView defnSR) statusLine (showQN (showQual (options state)) (funId e) ++": definition") state @@ -461,10 +461,10 @@ cut v exp = let l = label exp in if l==v then SCut v else rebuild exp (map (cut v) (children exp)) -join :: State -> Label -> SExp Label -> SExp Label -join state v exp = let l = label exp in +joinE :: State -> Label -> SExp Label -> SExp Label +joinE state v exp = let l = label exp in if l==v then toSExp state False (fst v) (snd v) - else rebuild exp (map (join state v) (children exp)) + else rebuild exp (map (joinE state v) (children exp)) -- To revert a subexpression means to display it in its less-than-finally- -- evaluated form. In particular, rather than seeing a lambda expression @@ -693,7 +693,7 @@ newSetting mode state = do let state' = setState mode state statusLine (showState mode state') state' - System.Cmd.system ("sleep 1") + system ("sleep 1") return state' diff --git a/tools/HighlightStyle.hs b/tools/HighlightStyle.hs --- a/tools/HighlightStyle.hs +++ b/tools/HighlightStyle.hs @@ -85,6 +85,7 @@ fromEnum Concealed = 8 fromEnum (Foreground c) = 30 + fromEnum c fromEnum (Background c) = 40 + fromEnum c + toEnum _ = error "HighlightStyle.Highlight.toEnum undefined" highlight :: [Highlight] -> String -> String highlight attrs s = highlightOn attrs ++ s ++ highlightOff diff --git a/tools/Ident.hs b/tools/Ident.hs --- a/tools/Ident.hs +++ b/tools/Ident.hs @@ -69,6 +69,10 @@ , i_defnlineend = dle , i_defncolend = dce , 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/LowLevel.hs b/tools/LowLevel.hs --- a/tools/LowLevel.hs +++ b/tools/LowLevel.hs @@ -71,6 +71,11 @@ instance Num FileNode where (+) (FileNode x) (FileNode y) = FileNode (x+y) + (*) _ _ = error "LowLevel Num FileNode (*) undefined" + abs _ = error "LowLevel Num FileNode abs undefined" + signum _ = error "LowLevel Num FileNode signum undefined" + fromInteger _ = error "LowLevel Num FileNode fromInteger undefined" + negate _ = error "LowLevel Num FileNode negate undefined" -- There are 25 basic types of node, encoded in the lower 5 bits of the tag -- They fall into four broad classes: module info, srcpos, expressions, atoms. @@ -131,6 +136,7 @@ toEnum 28 = AtomAbstract toEnum 29 = ListCons toEnum n = error ("NodeType.toEnum "++show n) + fromEnum _ = error "LowLevel.NodeType.fromEnum" -- For most purposes, we don't care about the exact node type, and a -- simplified division of nodes into kinds is useful. diff --git a/tools/NonTermLib.hs b/tools/NonTermLib.hs --- a/tools/NonTermLib.hs +++ b/tools/NonTermLib.hs @@ -171,7 +171,8 @@ 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 setOptions :: [String] -> State diff --git a/tools/ParseLib.hs b/tools/ParseLib.hs deleted file mode 100644 --- a/tools/ParseLib.hs +++ /dev/null @@ -1,203 +0,0 @@ -{----------------------------------------------------------------------------- -* extension: parameterised on token type -* by Malcolm Wallace - - A LIBRARY OF MONADIC PARSER COMBINATORS - - 29th July 1996 - - Graham Hutton Erik Meijer - University of Nottingham University of Utrecht - -This Haskell 1.3 script defines a library of parser combinators, and is taken -from sections 1-6 of our article "Monadic Parser Combinators". Some changes -to the library have been made in the move from Gofer to Haskell: - - * Do notation is used in place of monad comprehension notation; - - * The parser datatype is defined using "newtype", to avoid the overhead - of tagging and untagging parsers with the P constructor. - ------------------------------------------------------------------------------} - -module ParseLib - (Parser(..), item, first, papply, (+++), sat, tok, many, many1, - sepby, sepby1, chainl, chainl1, chainr, chainr1, ops, bracket, - -- char, digit, lower, upper, - -- letter, alphanum, string, ident, nat, int, spaces, comment, junk, - -- skip, token, natural, integer, symbol, identifier - ) where - -import Data.Char -import Control.Monad - -infixr 5 +++ - ---- The parser monad --------------------------------------------------------- - -newtype Parser t a = P ([t] -> [(a,[t])]) - -instance Functor (Parser t) where - -- map :: (a -> b) -> (Parser t a -> Parser t b) - fmap f (P p) = P (\inp -> [(f v, out) | (v,out) <- p inp]) - -instance Monad (Parser t) where - -- return :: a -> Parser t a - return v = P (\inp -> [(v,inp)]) - -- >>= :: Parser t a -> (a -> Parser t b) -> Parser t b - (P p) >>= f = P (\inp -> concat [papply (f v) out | (v,out) <- p inp]) - -- fail :: String -> Parser t a - fail _ = P (\inp -> []) - -instance MonadPlus (Parser t) where - -- mzero :: Parser t a - mzero = P (\inp -> []) - -- mplus :: Parser t a -> Parser t a -> Parser t a - (P p) `mplus` (P q) = P (\inp -> (p inp ++ q inp)) - ---- Other primitive parser combinators --------------------------------------- - -item :: Parser t t -item = P (\inp -> case inp of - [] -> [] - (x:xs) -> [(x,xs)]) - -force :: Parser t a -> Parser t a -force (P p) = P (\inp -> let x = p inp in - (fst (head x), snd (head x)) : tail x) - -first :: Parser t a -> Parser t a -first (P p) = P (\inp -> case p inp of - [] -> [] - (x:xs) -> [x]) - -papply :: Parser t a -> [t] -> [(a,[t])] -papply (P p) inp = p inp - ---- Derived combinators ------------------------------------------------------ - -(+++) :: Parser t a -> Parser t a -> Parser t a -p +++ q = first (p `mplus` q) - -sat :: (t -> Bool) -> Parser t t -sat p = do {x <- item; if p x then return x else mzero} - -tok :: Eq t => t -> Parser t t -tok t = do {x <- item; if t==x then return t else mzero} - -many :: Parser t a -> Parser t [a] -many p = many1 p +++ return [] ---many p = force (many1 p +++ return []) - -many1 :: Parser t a -> Parser t [a] -many1 p = do {x <- p; xs <- many p; return (x:xs)} - -sepby :: Parser t a -> Parser t b -> Parser t [a] -p `sepby` sep = (p `sepby1` sep) +++ return [] - -sepby1 :: Parser t a -> Parser t b -> Parser t [a] -p `sepby1` sep = do {x <- p; xs <- many (do {sep; p}); return (x:xs)} - -chainl :: Parser t a -> Parser t (a -> a -> a) -> a -> Parser t a -chainl p op v = (p `chainl1` op) +++ return v - -chainl1 :: Parser t a -> Parser t (a -> a -> a) -> Parser t a -p `chainl1` op = do {x <- p; rest x} - where - rest x = do {f <- op; y <- p; rest (f x y)} - +++ return x - -chainr :: Parser t a -> Parser t (a -> a -> a) -> a -> Parser t a -chainr p op v = (p `chainr1` op) +++ return v - -chainr1 :: Parser t a -> Parser t (a -> a -> a) -> Parser t a -p `chainr1` op = do {x <- p; rest x} - where - rest x = do { f <- op - ; y <- p `chainr1` op - ; return (f x y)} - +++ return x - -ops :: [(Parser t a, b)] -> Parser t b -ops xs = foldr1 (+++) [do {p; return op} | (p,op) <- xs] - -bracket :: Parser t a -> Parser t b -> Parser t c -> Parser t b -bracket open p close = do {open; x <- p; close; return x} - -{- ---- Useful parsers ----------------------------------------------------------- -char :: Char -> Parser Char -char x = sat (\y -> x == y) - -digit :: Parser Char -digit = sat isDigit - -lower :: Parser Char -lower = sat isLower - -upper :: Parser Char -upper = sat isUpper - -letter :: Parser Char -letter = sat isAlpha - -alphanum :: Parser Char -alphanum = sat isAlphanum +++ char '_' - -string :: String -> Parser String -string "" = return "" -string (x:xs) = do {char x; string xs; return (x:xs)} - -ident :: Parser String -ident = do {x <- lower; xs <- many alphanum; return (x:xs)} - -nat :: Parser Int -nat = do {x <- digit; return (fromEnum x - fromEnum '0')} `chainl1` return op - where - m `op` n = 10*m + n - -int :: Parser Int -int = do {char '-'; n <- nat; return (-n)} +++ nat - ---- Lexical combinators ------------------------------------------------------ - -spaces :: Parser () -spaces = do {many1 (sat isSpace); return ()} - -comment :: Parser () ---comment = do {string "--"; many (sat (\x -> x /= '\n')); return ()} ---comment = do --- _ <- string "--" --- _ <- many (sat (\x -> x /= '\n')) --- return () -comment = do - bracket (string "/*") (many item) (string "*/") - return () - -junk :: Parser () -junk = do {many (spaces +++ comment); return ()} - -skip :: Parser a -> Parser a -skip p = do {junk; p} - -token :: Parser a -> Parser a -token p = do {v <- p; junk; return v} - ---- Token parsers ------------------------------------------------------------ - -natural :: Parser Int -natural = token nat - -integer :: Parser Int -integer = token int - -symbol :: String -> Parser String -symbol xs = token (string xs) - -identifier :: [String] -> Parser String -identifier ks = token (do {x <- ident; - if not (elem x ks) then return x - else return MZERO}) - ------------------------------------------------------------------------------- --} diff --git a/tools/Pattern.hs b/tools/Pattern.hs --- a/tools/Pattern.hs +++ b/tools/Pattern.hs @@ -12,7 +12,7 @@ import Data.List (isPrefixOf) import Data.Char (isDigit,isAlphaNum,isSpace,isUpper,isLower) import SExp (SExp(..),SFixity(..),QName(..),showQN) -import ParseLib +import Text.ParserCombinators.Poly @@ -86,7 +86,7 @@ | CloseBrace | End | Error String - deriving (Eq) + deriving (Eq, Show) gather :: (Char->Bool) -> (String->Token) -> (String->[Token]) -> String -> (String->[Token]) @@ -147,19 +147,38 @@ n = tail n' c = head n + +-- The Parser part: + +-- Derived combinator used frequently +tok :: Token -> Parser Token Token +tok t = do + x <- next + if t==x then return t + else fail ("Parsing failed. Expected " ++ show t ++ " but found " ++ show x) + + -- Parser from [Token] to SExp. parsePat :: [Token] -> (Either String (SExp ()), Maybe QName) +parsePat tokens = case runParser context tokens of + (Left err, restTokens) -> (Left err, Nothing) + (_, [Error s]) -> (Left ("Lexing error: " ++ s), Nothing) + (Right (exp,ctx), [End]) -> (Right exp, ctx) + _ -> (Left "tokens left for parsing", Nothing) + +{- parsePat tokens = case papply context tokens of [((exp,ctx),[End])] -> (Right exp, ctx) [(_, [Error s])] -> (Left s, Nothing) _ -> (Left "ambiguous", Nothing) +-} context :: Parser Token (SExp (), Maybe QName) context = do eqn <- equation ctx <- ( do tok In - Variable ctx <- item - return (Just ctx) ) +++ + Variable ctx <- next + return (Just ctx) ) <|> ( do return Nothing ) return (eqn,ctx) @@ -168,22 +187,22 @@ do lhs <- pattern ( ( do tok Equal rhs <- pattern - return (SEquation () lhs rhs) ) +++ + return (SEquation () lhs rhs) ) <|> ( do return lhs ) ) pattern :: Parser Token (SExp ()) pattern = ( do tok OpenParen tok CloseParen - return (SId () (Plain "()") SInfixDefault) ) +++ + return (SId () (Plain "()") SInfixDefault) ) <|> ( do tok OpenParen (SId () v (SInfix 0)) <- atom tok CloseParen - return (SId () v SInfixDefault) ) +++ + return (SId () v SInfixDefault) ) <|> ( do tok OpenParen p <- pattern tok CloseParen - return p ) +++ + return p ) <|> ( do ps <- many1 atom ( let reorder xs = case xs of @@ -195,45 +214,45 @@ atom :: Parser Token (SExp ()) atom = - ( do String s <- item - return (mkList (SLiteral () . show) s) ) +++ + ( do String s <- next + return (mkList (SLiteral () . show) s) ) <|> ( do tok Underscore - return (SUnevaluated ()) ) +++ - ( do Char c <- item - return (SLiteral () ('\'':c++"'")) ) +++ - ( do Numeric n <- item - return (SLiteral () n) ) +++ - ( do Constructor c <- item + return (SUnevaluated ()) ) <|> + ( do Char c <- next + return (SLiteral () ('\'':c++"'")) ) <|> + ( do Numeric n <- next + return (SLiteral () n) ) <|> + ( do Constructor c <- next tok OpenBrace - fields <- (do Variable name <- item + fields <- (do Variable name <- next tok Equal pat <- pattern - return (showQN False name,pat)) `sepby1` (tok Comma) + return (showQN False name,pat)) `sepBy1` (tok Comma) tok CloseBrace let (names,exps) = unzip fields - return (SFieldExpr () (SId () c SInfixDefault) names exps) ) +++ - ( do Constructor c <- item + return (SFieldExpr () (SId () c SInfixDefault) names exps) ) <|> + ( do Constructor c <- next many ( do { tok OpenBrace; tok CloseBrace } ) - return (SId () c SInfixDefault) ) +++ - ( do Variable v <- item - return (SId () v SInfixDefault) ) +++ - ( do InfixConstructor v <- item - return (SId () v (SInfix 0)) ) +++ - ( do InfixVariable v <- item - return (SId () v (SInfix 0)) ) +++ + return (SId () c SInfixDefault) ) <|> + ( do Variable v <- next + return (SId () v SInfixDefault) ) <|> + ( do InfixConstructor v <- next + return (SId () v (SInfix 0)) ) <|> + ( do InfixVariable v <- next + return (SId () v (SInfix 0)) ) <|> ( do tok OpenParen - ps <- pattern `sepby1` (tok Comma) + ps <- pattern `sepBy1` (tok Comma) tok CloseParen case length ps of 1 -> return (head ps) _ -> let tuple = Plain (replicate (length ps - 1) ',') - in return (SApp () (SId () tuple SInfixDefault: ps)) ) +++ + in return (SApp () (SId () tuple SInfixDefault: ps)) ) <|> ( do tok OpenParen ps <- many1 atom tok CloseParen - return (SApp () ps) ) +++ + return (SApp () ps) ) <|> ( do tok OpenBracket - elems <- pattern `sepby` (tok Comma) + elems <- pattern `sepBy` (tok Comma) tok CloseBracket return (mkList id elems) ) diff --git a/tools/PrettyHat.hs b/tools/PrettyHat.hs --- a/tools/PrettyHat.hs +++ b/tools/PrettyHat.hs @@ -3,7 +3,7 @@ -- System Imports import System.IO (stdin,stdout,stderr,hPutStrLn) import Data.List (isSuffixOf) -import System.Cmd (system) +import System.Process (system) import System.Environment (getArgs,getProgName) import System.Exit (exitWith,ExitCode(..)) import Foreign.C.String (withCString) diff --git a/tools/Run.hs b/tools/Run.hs --- a/tools/Run.hs +++ b/tools/Run.hs @@ -4,7 +4,7 @@ ) where import System.Directory (removeFile) -import System.Cmd (system) +import System.Process (system) import System.Exit (ExitCode(..)) import System.IO.Unsafe (unsafePerformIO) diff --git a/tools/SExp.hs b/tools/SExp.hs --- a/tools/SExp.hs +++ b/tools/SExp.hs @@ -455,9 +455,11 @@ (<|>) :: Doc -> Doc -> Doc d1 <|> d2 = d1 <> fdelimiter "" <> d2 +{- not used -- breakable before a comma -(<*>) :: Doc -> Doc -> Doc -d1 <*> d2 = d1 <|> text "," <> d2 +(<->) :: Doc -> Doc -> Doc +d1 <-> d2 = d1 <|> text "," <> d2 +-} -- breakable before or after a cons (<:>) :: Doc -> Doc -> Doc diff --git a/tools/Slice.hs b/tools/Slice.hs --- a/tools/Slice.hs +++ b/tools/Slice.hs @@ -67,12 +67,12 @@ compress [] = [] compress [x] = [x] compress (x:x1:xs) - | x <+ x1 = compress (join x x1 : xs) + | x <+ x1 = compress (joinSlices x x1 : xs) | x <+> x1 = compress (x : xs) | otherwise = x : compress (x1:xs) -join :: PartSlice -> PartSlice -> PartSlice -join (Part {file=f, start=s, finish=e}) (Part {file=f', start=s', finish=e'}) +joinSlices :: PartSlice -> PartSlice -> PartSlice +joinSlices (Part {file=f, start=s, finish=e}) (Part {file=f', start=s', finish=e'}) = Part {file=f, start=s, finish=e'} makeSlice :: Int -> NodeExp -> Maybe Slice diff --git a/tools/SrcRefViewer.hs b/tools/SrcRefViewer.hs --- a/tools/SrcRefViewer.hs +++ b/tools/SrcRefViewer.hs @@ -6,7 +6,7 @@ module Main where import System.Environment (getProgName, getArgs) -import System.Cmd (system) +import System.Process (system) import System.Exit (exitWith, ExitCode(..)) import System.IO (hSetBuffering,BufferMode(..),stdin,stdout) import Data.Char (isSpace,isDigit) @@ -57,9 +57,9 @@ else putStr (goto 1 2 ++ a ++ highlight [Bold, Foreground Magenta] b ++ c ++ goto column (line'+1)) - System.Cmd.system ("stty -icanon min 1 -echo") + system ("stty -icanon min 1 -echo") awaitQuit - System.Cmd.system ("stty icanon echo") + system ("stty icanon echo") putStr (goto 1 height) return () diff --git a/tools/artutils.c b/tools/artutils.c --- a/tools/artutils.c +++ b/tools/artutils.c @@ -65,7 +65,7 @@ FILE* file; strcpy(filename,base); strcat(filename,ext); - if (file = fopen(filename,"rb")) { + if ((file = fopen(filename,"rb"))) { return file; } else { fprintf(stderr,"%s: cannot open %s\n",progname,filename); @@ -1029,6 +1029,9 @@ if (hasSrcPos(c)) { readFO(); } return parentNode(readFO()); break; + default: + printf("artutils.parentNode of unkown node.\n"); + exit(-1); } } @@ -1242,6 +1245,9 @@ case AtomAbstract: return 0; break; + default: + printf("artutils.getExpArity of unkown node.\n"); + exit(-1); } } diff --git a/tools/detectutils.c b/tools/detectutils.c --- a/tools/detectutils.c +++ b/tools/detectutils.c @@ -3,6 +3,7 @@ */ #include #include +#include #ifdef DEBUG #define HIDE(x) x diff --git a/tools/hat-check.c b/tools/hat-check.c --- a/tools/hat-check.c +++ b/tools/hat-check.c @@ -239,6 +239,7 @@ if (amode && smode) putchar('\n'); if (smode) reportstats(); } + return 0; } int @@ -565,13 +566,15 @@ break; } } - if (gmode && requireoffset!=0 && *edgelabel != '\0') - if (strcmp(edgelabel,"p")==0) + if (gmode && requireoffset!=0 && *edgelabel != '\0') { + if (strcmp(edgelabel,"p")==0) { printf("%d -> %d [style=dashed]\n", contextoffset, requireoffset); - else + } else { printf("%d -> %d [label=\"%s\"]\n", contextoffset, requireoffset, edgelabel); + } + } } #define ismarked(b) ((b)&0x80) @@ -857,7 +860,7 @@ for (i=0; i Module l -> IO Environment +readAuxFiles :: Flags -> Module SrcSpanInfo -> IO Environment readAuxFiles flags mod@(Module l maybeModuleHead _ importDecls decls) = do importEnvs <- mapM (importEnv flags) (filter notNotHat importDecls) return (unionRelations importEnvs) @@ -23,7 +23,7 @@ notNotHat :: ImportDecl l -> Bool notNotHat importDecl = not ("NotHat" `isPrefixOf` getId (importModule importDecl)) -importEnv :: Flags -> ImportDecl l -> IO Environment +importEnv :: Flags -> ImportDecl SrcSpanInfo -> IO Environment importEnv flags importDecl = do entities <- readAuxFile flags (importModule importDecl) return (imports (listToHxEnvironment entities) importDecl) diff --git a/trans/Derive.hs b/trans/Derive.hs --- a/trans/Derive.hs +++ b/trans/Derive.hs @@ -7,7 +7,7 @@ import Wired (mkExpDeriveEqualEqual,mkExpDeriveAndAnd,mkExpDeriveTrue,mkExpDeriveFalse,qNameBuiltinIdent) import SynHelp (Id(getId),appN,tyAppN,litInt,litString,litChar,conDeclName,conDeclArity ,mkQName, fieldDeclNames - ,instHeadQName,declHeadName,declHeadTyVarBinds,tyVarBind2Type + ,instRuleQName,declHeadName,declHeadTyVarBinds,tyVarBind2Type ,combineMaybeContexts) import Environment (Environment, hasPriority) import Debug.Trace @@ -19,9 +19,9 @@ derive env (DataDecl l dataOrNew maybeContext declHead qualConDecls maybeDeriving) = case maybeDeriving of Nothing -> [] - Just (Deriving _ instHeads) -> - map (deriveClass env maybeContext instTy tyVars conDecls . instHeadQName) - instHeads + Just (Deriving _ instRules) -> + map (deriveClass env maybeContext instTy tyVars conDecls . instRuleQName) + instRules where tyVars = map tyVarBind2Type (declHeadTyVarBinds declHead) nameTy = declHeadName declHead @@ -67,12 +67,12 @@ deriveEq :: l -> Maybe (Context l) -> (Type l) -> [ConDecl l] -> Decl l deriveEq l maybeContext instTy conDecls = - InstDecl l maybeContext (IHead l (deriveIdent "Eq" l) [instTy]) - (Just [InsDecl l (FunBind l ( + mkInstance l maybeContext "Eq" instTy + [InsDecl l (FunBind l ( map matchEqConstr conDecls ++ [Match l (Symbol l "==") [PWildCard l, PWildCard l] (UnGuardedRhs l (mkExpDeriveFalse l)) - Nothing]))]) + Nothing]))] where names = newNames l -- mkExpEqual :: Exp l -> Exp l -> Exp l @@ -99,8 +99,8 @@ deriveOrd :: l -> Maybe (Context l) -> (Type l) -> [ConDecl l] -> Decl l deriveOrd l maybeContext instTy conDecls = - InstDecl l maybeContext (IHead l (deriveIdent "Ord" l) [instTy]) - (Just [InsDecl l (FunBind l ( + mkInstance l maybeContext "Ord" instTy + [InsDecl l (FunBind l ( concatMap matchCompareEqConstr conDecls ++ [Match l nameCompare [PVar l nameL, PVar l nameR] (UnGuardedRhs l @@ -110,8 +110,8 @@ (Var l (UnQual l nameL)))) (App l (Var l (UnQual l nameLocalFromEnum)) (Var l (UnQual l nameR))))) - (Just (BDecls l [FunBind l (zipWith matchLocalFromEnum conDecls [0..])])) - ]))]) + (Just (BDecls l [FunBind l (zipWith matchLocalFromEnum conDecls [(0::Int)..])])) + ]))] where nameL : nameR : names = newNames l nameCompare = Ident l "compare" @@ -135,8 +135,8 @@ -- mkExpCase :: Exp l -> Exp l -> Exp l mkExpCase e1 e2 = Case l e1 - [Alt l (PApp l (deriveIdent "EQ" l) []) (UnGuardedAlt l e2) Nothing - ,Alt l (PVar l nameL) (UnGuardedAlt l (Var l (UnQual l nameL))) Nothing] + [Alt l (PApp l (deriveIdent "EQ" l) []) (UnGuardedRhs l e2) Nothing + ,Alt l (PVar l nameL) (UnGuardedRhs l (Var l (UnQual l nameL))) Nothing] -- mkExpCompare :: Exp l -> Exp l -> Exp l mkExpCompare e1 e2 = App l (App l (Var l (deriveIdent "compare" l)) e1) e2 @@ -152,23 +152,21 @@ deriveBounded :: l -> Maybe (Context l) -> (Type l) -> [ConDecl l] -> Decl l deriveBounded l maybeContext instTy conDecls = - InstDecl l maybeContext (IHead l (deriveIdent "Bounded" l) [instTy]) + mkInstance l maybeContext "Bounded" instTy (if all (== 0) (map conDeclArity conDecls) then -- all constructors have no arguments (enumeration) - (Just [InsDecl l (PatBind l - (PVar l (Ident l "minBound")) Nothing + (PVar l (Ident l "minBound")) (UnGuardedRhs l (Con l (UnQual l (conDeclName (head conDecls))))) Nothing) ,InsDecl l (PatBind l - (PVar l (Ident l "maxBound")) Nothing + (PVar l (Ident l "maxBound")) (UnGuardedRhs l (Con l (UnQual l (conDeclName (last conDecls))))) - Nothing)]) + Nothing)] else -- exactly one constructor let [conDecl] = conDecls in - (Just [InsDecl l (PatBind l - (PVar l (Ident l "minBound")) Nothing + (PVar l (Ident l "minBound")) (UnGuardedRhs l (appN (Con l (UnQual l (conDeclName conDecl)) @@ -176,23 +174,22 @@ (Var l (deriveIdent "minBound" l))))) Nothing) ,InsDecl l (PatBind l - (PVar l (Ident l "maxBound")) Nothing + (PVar l (Ident l "maxBound")) (UnGuardedRhs l (appN (Con l (UnQual l (conDeclName conDecl)) :replicate (conDeclArity conDecl) (Var l (deriveIdent "maxBound" l))))) - Nothing)])) + Nothing)]) -- ---------------------------------------------------------------------------- deriveEnum :: l -> Maybe (Context l) -> (Type l) -> [ConDecl l] -> Decl l deriveEnum l maybeContext instTy conDecls = -- assert: all (== 0) (map constrArity constrs) - InstDecl l maybeContext (IHead l (deriveIdent "Enum" l) [instTy]) - (Just - [InsDecl l (FunBind l (zipWith matchFromEnum conDecls [0..])) - ,InsDecl l (FunBind l (zipWith matchToEnum conDecls [0..] ++ [failure])) + mkInstance l maybeContext "Enum" instTy + [InsDecl l (FunBind l (zipWith matchFromEnum conDecls [(0::Int)..])) + ,InsDecl l (FunBind l (zipWith matchToEnum conDecls [(0::Integer)..] ++ [failure])) ,InsDecl l (FunBind l [Match l (Ident l "enumFrom") [PVar l name1] (UnGuardedRhs l @@ -214,7 +211,7 @@ (Var l (UnQual l name1))]) (Con l (UnQual l (conDeclName (last conDecls)))) (Con l (UnQual l (conDeclName (head conDecls))))])) - Nothing])]) + Nothing])] where name1:name2:_ = newNames l var1 = Var l (UnQual l name1) @@ -223,7 +220,7 @@ Match l (Ident l "fromEnum") [PApp l (UnQual l (conDeclName conDecl)) []] (UnGuardedRhs l (litInt l num)) Nothing matchToEnum conDecl num = - Match l (Ident l "toEnum") [PLit l (Int l num (show num))] + Match l (Ident l "toEnum") [PLit l (Signless l) (Int l num (show num))] (UnGuardedRhs l (Con l (UnQual l (conDeclName conDecl)))) Nothing failure = Match l (Ident l "toEnum") [PWildCard l] @@ -236,10 +233,10 @@ deriveRead :: Environment -> l -> Maybe (Context l) -> (Type l) -> [ConDecl l] -> Decl l deriveRead env l maybeContext instTy conDecls = - InstDecl l maybeContext (IHead l (deriveIdent "Read" l) [instTy]) - (Just [InsDecl l (FunBind l ( + mkInstance l maybeContext "Read" instTy + [InsDecl l (FunBind l ( [Match l (Ident l "readsPrec") [PVar l name1] - (UnGuardedRhs l (foldr1 alt . map expReadsPrec $ conDecls)) Nothing]))]) + (UnGuardedRhs l (foldr1 alt . map expReadsPrec $ conDecls)) Nothing]))] where name1:_ = newNames l e1 `alt` e2 = appN [Var l (mkQName l "PreludeBasic.alt"), e1, e2] @@ -272,7 +269,7 @@ e1 `thenAp` e2 = appN [Var l (mkQName l "PreludeBasic.thenAp"), e1, e2] precGreaterPriority = InfixApp l (Var l (UnQual l name1)) (QVarOp l (deriveSymbol ">" l)) (litInt l priority) readsArg = appN [Var l (deriveIdent "readsPrec" l), litInt l priorityPlus1] - readsArg0 = appN [Var l (deriveIdent "readsPrec" l), litInt l 0] + readsArg0 = appN [Var l (deriveIdent "readsPrec" l), litInt l (0::Integer)] p `thenField` fieldName = p `thenLex` getId fieldName `thenLex` "=" `thenAp` readsArg0 p `thenCommaField` fieldName = p `thenLex` "," `thenField` fieldName @@ -280,8 +277,8 @@ deriveShow :: Environment -> l -> Maybe (Context l) -> (Type l) -> [ConDecl l] -> Decl l deriveShow env l maybeContext instTy conDecls = - InstDecl l maybeContext (IHead l (deriveIdent "Show" l) [instTy]) - (Just [InsDecl l (FunBind l (map matchShowsPrec conDecls))]) + mkInstance l maybeContext "Show" instTy + [InsDecl l (FunBind l (map matchShowsPrec conDecls))] where name1:names = newNames l matchShowsPrec conDecl = @@ -319,7 +316,7 @@ e1 `composeSpace` e2 = e1 `compose` showCharExp ' ' `compose` e2 e1 `composeComma` e2 = e1 `compose` showCharExp ',' `compose` e2 showField fieldName e = - showStringExp (getId fieldName) `compose` showCharExp '=' `compose` showPrec 0 e + showStringExp (getId fieldName) `compose` showCharExp '=' `compose` showPrec (0::Int) e showPrec d e = appN [Var l (deriveIdent "showsPrec" l), litInt l d, e] @@ -327,43 +324,47 @@ deriveIx :: l -> Maybe (Context l) -> (Type l) -> [ConDecl l] -> Decl l deriveIx l maybeContext instTy conDecls = - InstDecl l maybeContext (IHead l (deriveIdent "Ix" l) [instTy]) - (Just (map (InsDecl l) (if all (==0) (map conDeclArity conDecls) then ixEnumeration else ixSingleConstructor))) + mkInstance l maybeContext "Ix" instTy + (map (InsDecl l) (if all (==0) (map conDeclArity conDecls) then ixEnumeration else ixSingleConstructor)) where ixEnumeration = - [FunBind l [Match l (Ident l "range") [PTuple l [PVar l lName, PVar l uName]] (UnGuardedRhs l + [FunBind l [Match l (Ident l "range") [ppair (PVar l lName) (PVar l uName)] (UnGuardedRhs l (appN [Var l (deriveIdent "map" l) ,toEnumVar 'r' ,appN [Var l (deriveIdent "enumFromTo" l) ,appN [fromEnumVar 'r', Var l (UnQual l lName)] ,appN [fromEnumVar 'r', Var l (UnQual l uName)]]])) (Just (BDecls l (declsToEnum 'r' ++ declsFromEnum 'r')))] - ,FunBind l [Match l (Ident l "index") [PTuple l [PVar l lName, PVar l uName], PVar l iName] (UnGuardedRhs l + ,FunBind l [Match l (Ident l "index") [ppair (PVar l lName) (PVar l uName), PVar l iName] (UnGuardedRhs l (InfixApp l (appN [fromEnumVar 'i', Var l (UnQual l iName)]) (QVarOp l (deriveSymbol "-" l)) (appN [fromEnumVar 'i', Var l (UnQual l uName)]))) (Just (BDecls l (declsFromEnum 'i')))] - ,FunBind l [Match l (Ident l "inRange") [PTuple l [PVar l lName, PVar l uName], PVar l iName] (UnGuardedRhs l + ,FunBind l [Match l (Ident l "inRange") [ppair (PVar l lName) (PVar l uName), PVar l iName] (UnGuardedRhs l (appN [Var l (deriveIdent "inRange" l) - ,Tuple l [appN [fromEnumVar 'n', Var l (UnQual l lName)] - ,appN [fromEnumVar 'n', Var l (UnQual l uName)]] + ,pair (appN [fromEnumVar 'n', Var l (UnQual l lName)]) + (appN [fromEnumVar 'n', Var l (UnQual l uName)]) ,appN [fromEnumVar 'n', Var l (UnQual l iName)]])) (Just (BDecls l (declsFromEnum 'n')))]] where + -- pair :: Exp l -> Exp l -> Exp l + pair e1 e2 = Tuple l Boxed [e1,e2] + -- ppair :: Pat l - Pat l -> Pat l + ppair p1 p2 = PTuple l Boxed [p1,p2] lName:uName:iName:_ = newNames l fromEnumVar prefix = Var l (deriveIdent (prefix : "fromEnum") l) toEnumVar prefix = Var l (deriveIdent (prefix : "toEnum") l) -- declsFromEnum :: [Decl l] declsFromEnum prefix = [TypeSig l [(Ident l (prefix : "fromEnum"))] (TyFun l instTy (TyCon l (deriveIdent "Int" l))) - ,FunBind l (zipWith (matchFromEnum prefix) conDecls [0..])] + ,FunBind l (zipWith (matchFromEnum prefix) conDecls [(0::Integer)..])] declsToEnum prefix = [TypeSig l [(Ident l (prefix : "toEnum"))] (TyFun l (TyCon l (deriveIdent "Int" l)) instTy) - ,FunBind l (zipWith (matchToEnum prefix) conDecls [0..])] + ,FunBind l (zipWith (matchToEnum prefix) conDecls [(0::Integer)..])] matchFromEnum prefix conDecl num = Match l (Ident l (prefix : "fromEnum")) [PApp l (UnQual l (conDeclName conDecl)) []] (UnGuardedRhs l (litInt l num)) Nothing matchToEnum prefix conDecl num = - Match l (Ident l (prefix : "toEnum")) [PLit l (Int l num (show num))] + Match l (Ident l (prefix : "toEnum")) [PLit l (Signless l) (Int l num (show num))] (UnGuardedRhs l (Con l (UnQual l (conDeclName conDecl)))) Nothing ixSingleConstructor = [FunBind l [Match l (Ident l "range") [pTupleConLU] (UnGuardedRhs l @@ -387,29 +388,39 @@ uvars = map (Var l . UnQual l) uNames ivars = map (Var l . UnQual l) iNames conIVars = appN (Con l (UnQual l conName) : ivars) - pTupleConLU = PTuple l [PApp l (UnQual l conName) (map (PVar l) lNames) - ,PApp l (UnQual l conName) (map (PVar l) uNames)] + pTupleConLU = PTuple l Boxed [PApp l (UnQual l conName) (map (PVar l) lNames) + ,PApp l (UnQual l conName) (map (PVar l) uNames)] pConI = PApp l (UnQual l conName) (map (PVar l) iNames) -- rangeComb :: Exp l -> Exp l -> Name l -> Exp l -> Exp l rangeComb le ue ie cont = - InfixApp l (appN [Var l (deriveIdent "range" l), Tuple l [le, ue]]) (QVarOp l (deriveSymbol ">>=" l)) + InfixApp l (appN [Var l (deriveIdent "range" l), pair le ue]) (QVarOp l (deriveSymbol ">>=" l)) (Lambda l [PVar l ie] cont) - indexExp le ue ie = appN [Var l (deriveIdent "index" l), Tuple l [le, ue], ie] + indexExp le ue ie = appN [Var l (deriveIdent "index" l), pair le ue, ie] -- indexComb :: Exp l -> Exp l -> Exp l -> Exp l -> Exp l indexComb le ue ie ee = InfixApp l (indexExp le ue ie) (QVarOp l (deriveSymbol "+" l)) - (InfixApp l (appN [Var l (deriveIdent "rangeSize" l), Tuple l [le, ue]]) + (InfixApp l (appN [Var l (deriveIdent "rangeSize" l), pair le ue]) (QVarOp l (deriveSymbol "*" l)) ee) - inRangeExp le ue ie = appN [Var l (deriveIdent "inRange" l), Tuple l [le, ue], ie] + inRangeExp le ue ie = appN [Var l (deriveIdent "inRange" l), pair le ue, ie] -- andExp :: Exp l -> Exp l -> Exp l andExp e1 e2 = InfixApp l e1 (QVarOp l (deriveSymbol "&&" l)) e2 + -- pair :: Exp l -> Exp l -> Exp l + pair e1 e2 = Tuple l Boxed [e1,e2] -- ---------------------------------------------------------------------------- +-- Create simple instance as needed for derived instances, filling in all arguments that are trivial. +mkInstanceO :: l -> Maybe (Context l) -> String -> Type l -> Maybe [InstDecl l] -> Decl l +mkInstanceO l maybeContext id instTy maybeDecls = + InstDecl l Nothing (IRule l Nothing maybeContext (IHApp l (IHCon l (deriveIdent id l)) instTy)) maybeDecls + +mkInstance :: l -> Maybe (Context l) -> String -> Type l -> [InstDecl l] -> Decl l +mkInstance l maybeContext id instTy decls = mkInstanceO l maybeContext id instTy (Just decls) + -- Infinite list of parameter names in derived code. -- Only need to avoid conflict with names of the methods of derived classes. newNames :: l -> [Name l] -newNames l = map (Ident l . ('y':) . show) [1..] +newNames l = map (Ident l . ('y':) . show) [(1::Int)..] -- syntax helpers: diff --git a/trans/Environment.hs b/trans/Environment.hs --- a/trans/Environment.hs +++ b/trans/Environment.hs @@ -18,10 +18,11 @@ ) 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)) +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 SynHelp (Id(getId),getQualified,mkQual,qual,isQual,isUnQual,notSupported - ,tyVarBind2Name,declHeadTyVarBinds,declHeadName,instHeadQName,getArityFromConDecl + ,tyVarBind2Name,declHeadTyVarBinds,declHeadName,instRuleQName,getArityFromConDecl ,getConDeclFromQualConDecl,getConstructorFromConDecl,eqName,mkName,mkQName ,getFieldNamesFromConDecl,decomposeFunType,isFunTyCon,tyAppN,getModuleNameFromModule ,UpdId(updateId),dropAnn,noSpan) @@ -424,7 +425,7 @@ fromList [eSig (getId name) | name <- names] -- needed for methods in classes declEnv tracing _ (FunBind l matches) = matchEnv l tracing (head matches) -declEnv tracing _ (PatBind l pat _ _ _) = patEnv l tracing pat +declEnv tracing _ (PatBind l pat _ _) = patEnv l tracing pat declEnv tracing _ (ForImp l _ _ _ name ty) = -- only for NoHat. import singleton (eVar (getId name) l (length tyArgs) tracing) @@ -436,18 +437,19 @@ declEnv _ _ (WarnPragmaDecl _ _) = emptyRelation declEnv _ _ (InlineSig _ _ _ _) = emptyRelation declEnv _ _ (InlineConlikeSig _ _ _) = emptyRelation -declEnv _ _ (SpecSig _ _ _) = emptyRelation +declEnv _ _ (SpecSig _ _ _ _) = emptyRelation declEnv _ _ (SpecInlineSig _ _ _ _ _) = emptyRelation -declEnv _ _ (InstSig _ _ _) = emptyRelation +declEnv _ _ (InstSig _ _) = emptyRelation declEnv _ _ (AnnPragma _ _) = emptyRelation +declEnv _ _ (MinimalPragma _ _) = emptyRelation -- Produce local environment for a non-empty class instance definition. instanceEnv :: Bool -> Environment -> Decl SrcSpanInfo -> Environment -instanceEnv tracing finalEnv (InstDecl l maybeContext instHead (Just instDecls)) = +instanceEnv tracing finalEnv (InstDecl l maybeContext instRule (Just instDecls)) = var2Method `mapRng` (declsEnv tracing finalEnv (map getDecl instDecls)) where - classId = getId (instHeadQName instHead) + classId = getId (instRuleQName instRule) var2Method :: Entity -> Entity var2Method e | isVar e = eMethod (eId e) [eSrc e] classId tracing | otherwise = error "Environment.declEnv: unexpected declaration in instance." @@ -473,12 +475,11 @@ patEnv :: SrcSpanInfo -> Bool -> Pat SrcSpanInfo -> Environment patEnv l tracing (PVar _ name) = singleton (eVar (getId name) l 0 tracing) -patEnv _ _ (PLit _ _) = emptyRelation -patEnv l tracing (PNeg _ pat) = patEnv l tracing pat +patEnv _ _ (PLit _ _ _) = emptyRelation patEnv l tracing (PNPlusK l2 name _) = patEnv l tracing (PVar l2 name) patEnv l tracing (PInfixApp _ patl _ patr) = unionRelations [patEnv l tracing patl, patEnv l tracing patr] patEnv l tracing (PApp _ _ pats) = unionRelations . map (patEnv l tracing) $ pats -patEnv l tracing (PTuple _ pats) = unionRelations . map (patEnv l tracing) $ pats +patEnv l tracing (PTuple _ _ pats) = unionRelations . map (patEnv l tracing) $ pats patEnv l tracing (PList _ pats) = unionRelations . map (patEnv l tracing) $ pats patEnv l tracing (PParen _ pat) = patEnv l tracing pat patEnv l tracing (PRec _ _ patFields) = unionRelations . map (patField l tracing) $ patFields @@ -494,7 +495,6 @@ patEnv _ _ (PXPcdata l _) = notSupported l "XML PCDATA pattern" patEnv _ _ (PXPatTag l _) = notSupported l "XML embedded pattern" patEnv _ _ (PXRPats l _) = notSupported l "XML regular list pattern" -patEnv _ _ (PExplTypeArg l _ _) = notSupported l "explicit generics style type argument" patEnv _ _ (PQuasiQuote l _ _) = notSupported l "quasi quote pattern" patEnv l tracing (PBangPat _ pat) = patEnv l tracing pat @@ -513,7 +513,7 @@ exports :: Bool -> Module SrcSpanInfo -> Environment -> HxEnvironment exports tracing mod@(Module l maybeModuleHead _ _ _) env = case maybeModuleHead of - Nothing -> exportList [Syntax.EVar l (UnQual l (Ident l "main"))] + Nothing -> exportList [Syntax.EVar l (Syntax.NoNamespace l) (UnQual l (Ident l "main"))] Just (ModuleHead _ _ _ Nothing) -> getQualified `mapDom` moduleDefines tracing env mod Just (ModuleHead _ _ _ (Just (ExportSpecList _ list))) -> exportList list where @@ -522,7 +522,7 @@ exports = filterExportSpec env `map` list -- Determine exports for one export specification of the export list -filterExportSpec :: Environment -> ExportSpec l -> Environment +filterExportSpec :: Environment -> ExportSpec SrcSpanInfo -> Environment filterExportSpec env (EModuleContents _ moduleName) = (qual moduleNameT `mapDom` unqs) `intersectRelation` qs where @@ -536,7 +536,8 @@ subs = restrictRng (`isOwned` allOwners) env qNameT = dropAnn qName (qName,mSub) = case eSpec of - Syntax.EVar _ qName -> (qName, emptyRelation) + 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 -> @@ -557,7 +558,7 @@ hxEnvironmentToList = map entity2HxEntity . Set.toAscList . Relation.rng -- Filter with one import declaration from the export environment of the imported module -imports :: HxEnvironment -> ImportDecl l -> Environment +imports :: HxEnvironment -> ImportDecl SrcSpanInfo -> Environment imports exports importDecl = if importQualified importDecl then qs else unionRelations [unqs, qs] where @@ -575,7 +576,7 @@ importQual imDecl = dropAnn (fromMaybe (importModule imDecl) (importAs imDecl)) -- Filter given environment with one import specification from an import list -filterImportSpec :: Bool -> HxEnvironment -> ImportSpec l -> HxEnvironment +filterImportSpec :: Bool -> HxEnvironment -> ImportSpec SrcSpanInfo -> HxEnvironment filterImportSpec isHiding exports iSpec = unionRelations [fSpec,fSub] where @@ -584,7 +585,8 @@ subs = restrictRng (`isOwned` allOwners) exports nameT = dropAnn name (name,fSub,noSubSpec) = case iSpec of - IVar _ name -> (name, emptyRelation, True) + IVar _ (NoNamespace _) name -> (name, emptyRelation, True) + IVar _ (TypeNamespace l) _ -> notSupported l "type name space in import" IAbs _ name -> (name, emptyRelation, True) IThingAll _ name -> (name, subs, False) IThingWith _ name cNames -> diff --git a/trans/HatTrans.hs b/trans/HatTrans.hs --- a/trans/HatTrans.hs +++ b/trans/HatTrans.hs @@ -17,8 +17,10 @@ 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(..),ParseResult,fromParseResult,parseFileWithMode - ,Module(..),ImportDecl(..),ModuleName(..),Extension(..),applyFixities) +import Language.Haskell.Exts.Annotated(ParseMode(..),Language(..),Extension(..),KnownExtension(..) + ,ParseResult + ,fromParseResult,parseFileWithMode + ,Module(..),ImportDecl(..),ModuleName(..),applyFixities) import Language.Haskell.Exts.Fixity(Fixity) import Language.Haskell.Exts.Pretty(prettyPrintStyleMode,Style(..),style,PPHsMode,defaultMode) import Wrap(wrap) @@ -40,7 +42,9 @@ {- parse source code -} let filePath = sSourceFile flags let parseMode = ParseMode {parseFilename = filePath - ,extensions = [ForeignFunctionInterface,NPlusKPatterns] + ,baseLanguage = Haskell2010 + ,extensions = [EnableExtension ForeignFunctionInterface + ,EnableExtension NPlusKPatterns] ,ignoreLanguagePragmas = False ,ignoreLinePragmas = True ,fixities = Nothing} @@ -113,7 +117,7 @@ importDecls' = if sPrelude flags || "Prelude" `elem` map (getId . importModule) importDecls then importDecls else ImportDecl{importAnn = l, importModule = ModuleName l "Prelude" - ,importQualified = False, importSrc = False + ,importQualified = False, importSrc = False, importSafe = False ,importPkg = Nothing, importAs = Nothing, importSpecs = Nothing} : importDecls -- Add import PreludeBasic if current module is not part of the Prelude. @@ -127,10 +131,10 @@ importDecls' = if sPrelude flags then importDecls else ImportDecl{importAnn = l, importModule = ModuleName l "PreludeBasic" - ,importQualified = True, importSrc = False + ,importQualified = True, importSrc = False, importSafe = False ,importPkg = Nothing, importAs = Nothing, importSpecs = Nothing} : ImportDecl{importAnn = l, importModule = ModuleName l "PreludeBuiltinTypes" - ,importQualified = True, importSrc = False + ,importQualified = True, importSrc = False, importSafe = False ,importPkg = Nothing, importAs = Nothing, importSpecs = Nothing} : importDecls {- If first argument is True, then print second and third with formatting -} diff --git a/trans/SynHelp.hs b/trans/SynHelp.hs --- a/trans/SynHelp.hs +++ b/trans/SynHelp.hs @@ -149,8 +149,9 @@ alt2Match :: Alt l -> Match l alt2Match (Alt l pat guardedAlts maybeBinds) = - Match l undefined [pat] (guardedAlts2Rhs guardedAlts) maybeBinds + Match l undefined [pat] guardedAlts maybeBinds +{- no longer needed for syntax after June 2014 guardedAlts2Rhs :: GuardedAlts l -> Rhs l guardedAlts2Rhs (UnGuardedAlt l exp) = UnGuardedRhs l exp guardedAlts2Rhs (GuardedAlts l gdAlts) = @@ -158,6 +159,7 @@ guardedAlt2GuardedRhs :: GuardedAlt l -> GuardedRhs l guardedAlt2GuardedRhs (GuardedAlt l stmts exp) = GuardedRhs l stmts exp +-} qOp2Exp :: QOp l -> Exp l qOp2Exp (QVarOp l qName) = Var l qName @@ -244,23 +246,29 @@ contextAssertions :: Context l -> [Asst l] contextAssertions (CxSingle _ asst) = [asst] contextAssertions (CxTuple _ assts) = assts -contextAssertions (CxParen _ ctx) = contextAssertions ctx contextAssertions (CxEmpty _) = [] +instRuleQName :: InstRule l -> QName l +instRuleQName (IRule _ _ _ instHead) = instHeadQName instHead +instRuleQName (IParen _ instRule) = instRuleQName instRule + instHeadQName :: InstHead l -> QName l -instHeadQName (IHead _ qname _) = qname -instHeadQName (IHInfix _ _ qname _) = qname +instHeadQName (IHCon _ qname) = qname +instHeadQName (IHInfix _ _ qname) = qname instHeadQName (IHParen _ ih) = instHeadQName ih +instHeadQName (IHApp _ ih _) = instHeadQName ih declHeadName :: DeclHead l -> Name l -declHeadName (DHead _ name _) = name -declHeadName (DHInfix _ _ name _ ) = name +declHeadName (DHead _ name) = name +declHeadName (DHInfix _ _ name) = name declHeadName (DHParen _ dh) = declHeadName dh +declHeadName (DHApp _ dh _) = declHeadName dh declHeadTyVarBinds :: DeclHead l -> [TyVarBind l] -declHeadTyVarBinds (DHead _ _ tvbs) = tvbs -declHeadTyVarBinds (DHInfix _ tvbL _ tvbR) = [tvbL,tvbR] +declHeadTyVarBinds (DHead _ _) = [] +declHeadTyVarBinds (DHInfix _ tvbL _) = [tvbL] declHeadTyVarBinds (DHParen _ dh) = declHeadTyVarBinds dh +declHeadTyVarBinds (DHApp _ dh tvb) = declHeadTyVarBinds dh ++ [tvb] tyVarBind2Type :: TyVarBind l -> Type l tyVarBind2Type (KindedVar l name kind) = TyKind l (TyVar l name) kind diff --git a/trans/TraceTrans.hs b/trans/TraceTrans.hs --- a/trans/TraceTrans.hs +++ b/trans/TraceTrans.hs @@ -68,7 +68,7 @@ (map tModulePragma modulePragmas) (tImpDecls env impDecls) (declsExported ++ - [PatBind span patParent Nothing + [PatBind span patParent (UnGuardedRhs span expRoot) Nothing] ++ [defNameMod modName moduleFilename tracing] ++ (if isTraced tracing then map (defNameSpan modTrace) ls else [])) @@ -134,7 +134,7 @@ -- T.closeTrace defMain :: Tracing -> String -> Decl SrcSpanInfo defMain tracing artFileName = - PatBind noSpan (PVar noSpan (nameMain noSpan)) Nothing + PatBind noSpan (PVar noSpan (nameMain noSpan)) (UnGuardedRhs noSpan (appN [expTraceIO ,litString noSpan artFileName @@ -164,8 +164,8 @@ String -> -- name of *this* module, being transformed ExportSpec SrcSpanInfo -> [ExportSpec SrcSpanInfo] -tExportSpec env _ _ (EVar span qname) = - map (EVar span) (tEntityVar env qname) +tExportSpec env _ _ (EVar span nameSpace qname) = + map (EVar span nameSpace) (tEntityVar env qname) tExportSpec env _ _ (EAbs span qname) = map (EAbs span) qnames' where @@ -180,7 +180,7 @@ 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) qnames' + EThingWith span qname' cnames' : map (EVar span (NoNamespace span)) qnames' where (qname', cnames', qnames') = tEntityThingWith env qname cnames tExportSpec env decls thisModuleId @@ -203,11 +203,11 @@ makeExport (ClassDecl l _ declHead _ _) = [EThingAll l (UnQual l (getDeclHeadName declHead))] makeExport (FunBind l matches) = - if exportedTransName name then [EVar l (UnQual l name)] else [] + if exportedTransName name then [EVar l (NoNamespace l) (UnQual l name)] else [] where name = getMatchName (head matches) -makeExport (PatBind l (PVar l' name) _ _ _) = - if exportedTransName name then [EVar l (UnQual l name)] else [] +makeExport (PatBind l (PVar l' name) _ _) = + if exportedTransName name then [EVar l (NoNamespace l) (UnQual l name)] else [] makeExport _ = [] -- Checks whether this is the name of a function that should be exported @@ -225,9 +225,10 @@ getMatchArity (InfixMatch _ _ _ pats _ _) = 1 + length pats getDeclHeadName :: DeclHead l -> Name l -getDeclHeadName (DHead _ name _) = name -getDeclHeadName (DHInfix _ _ name _) = name +getDeclHeadName (DHead _ name) = name +getDeclHeadName (DHInfix _ _ name) = name getDeclHeadName (DHParen _ declHead) = getDeclHeadName declHead +getDeclHeadName (DHApp _ declHead _) = getDeclHeadName declHead -- ---------------------------------------------------------------------------- -- Produce imports @@ -238,6 +239,7 @@ importModule = ModuleName noSpan "Prelude", importQualified = True, importSrc = False, + importSafe = False, importPkg = Nothing, importAs = Nothing, importSpecs = Nothing} @@ -257,6 +259,7 @@ importModule = ModuleName noSpan "Hat.Hat", importQualified = True, importSrc = False, + importSafe = False, importPkg = Nothing, importAs = Just (ModuleName noSpan "T"), importSpecs = Nothing} @@ -282,8 +285,8 @@ -- Nearly identical with tExportSpec except for the types. tImportSpec :: Environment -> ImportSpec SrcSpanInfo -> [ImportSpec SrcSpanInfo] -tImportSpec env (IVar span name) = - map (IVar span . qName2Name) qnames' +tImportSpec env (IVar span nameSpace name) = + map (IVar span nameSpace . qName2Name) qnames' where qnames' = tEntityVar env (UnQual (ann name) name) tImportSpec env (IAbs span name) = @@ -301,7 +304,7 @@ fieldName str = VarName span (mkName span str) tImportSpec env (IThingWith span name cnames) = IThingWith span (qName2Name qname') cnames' : - map (IVar span . qName2Name) qnames' + map (IVar span (NoNamespace span) . qName2Name) qnames' where (qname', cnames', qnames') = tEntityThingWith env (UnQual (ann name) name) cnames @@ -360,7 +363,7 @@ defNameMod :: ModuleName SrcSpanInfo -> String -> Tracing -> Decl SrcSpanInfo defNameMod modName@(ModuleName l modId) filename tracing = - PatBind l (PVar l (nameTraceInfoModule modName)) Nothing + PatBind l (PVar l (nameTraceInfoModule modName)) (UnGuardedRhs l (appN [Var l (qNameMkModule l) @@ -374,7 +377,7 @@ -- The span in the name is used in the declared name and its definition. defNameCon :: Name SrcSpanInfo -> [Name SrcSpanInfo] -> Int -> Int -> Exp SrcSpanInfo -> Decl SrcSpanInfo defNameCon conName fieldNames fixPri arity moduleTrace = - PatBind l (PVar l (nameTraceInfoCon conName)) Nothing + PatBind l (PVar l (nameTraceInfoCon conName)) (UnGuardedRhs l (appN (Var l (qNameMkAtomConstructor l withFields) : @@ -426,7 +429,7 @@ -- The span in the name is used in the declared name and its definition. defNameVar :: Name SrcSpanInfo -> Int -> Int -> Scope -> Scope -> Exp SrcSpanInfo -> Decl SrcSpanInfo defNameVar varName fixPri arity defScope visScope moduleTrace = - PatBind l (PVar l (nameTraceInfoVar l visScope varName)) Nothing + PatBind l (PVar l (nameTraceInfoVar l visScope varName)) (UnGuardedRhs l (appN (Var l (qNameMkAtomVariable l) : @@ -467,7 +470,7 @@ defNameSpan :: Exp SrcSpanInfo -> SrcSpan -> Decl SrcSpanInfo defNameSpan moduleTrace span = - PatBind l (PVar l (nameTraceInfoSpan l)) Nothing + PatBind l (PVar l (nameTraceInfoSpan l)) (UnGuardedRhs l (appN (Var l (qNameMkSpan l) : @@ -610,12 +613,12 @@ where (classDecls', declsConsts) = tClassDecls env tracing classDecls tDecl env _ tracing -- class instance without methods - (InstDecl l maybeContext instHead Nothing) = - onlyDecl (InstDecl l (fmap tContext maybeContext) (tInstHead instHead) + (InstDecl l maybeOverlap instRule Nothing) = + onlyDecl (InstDecl l maybeOverlap (tInstRule instRule) Nothing) tDecl env _ tracing -- class instance with methods - inst@(InstDecl l maybeContext instHead (Just instDecls)) = - ([InstDecl l (fmap tContext maybeContext) (tInstHead instHead) + inst@(InstDecl l maybeOverlap instRule (Just instDecls)) = + ([InstDecl l maybeOverlap (tInstRule instRule) (Just instDecls')] ,declsConsts `moduleConstsUnion` moduleConstsEnv Local localEnv) where @@ -666,8 +669,8 @@ tDecl env scope tracing (FunBind l matches) = tFunBind env scope tracing l matches -- a function does not use the static parent -tDecl env scope tracing (PatBind l pat maybeTy rhs maybeBinds) = - tPatBind env scope tracing l pat maybeTy rhs maybeBinds +tDecl env scope tracing (PatBind l pat rhs maybeBinds) = + tPatBind env scope tracing l pat rhs maybeBinds tDecl env _ _ (ForImp l callConv maybeSafety maybeString name ty) = case maybeString >>= stripPrefix "NotHat." of Just origName -> tForeignImp l (mkQName l origName) name ty @@ -688,11 +691,11 @@ onlyDecl (WarnPragmaDecl l [([], "ignore INLINE pragma")]) tDecl _ _ _ (InlineConlikeSig l _ _) = onlyDecl (WarnPragmaDecl l [([], "ignore INLINE CONLIKE pragma")]) -tDecl _ _ _ (SpecSig l _ _) = +tDecl _ _ _ (SpecSig l _ _ _) = onlyDecl (WarnPragmaDecl l [([], "ignore SPECIALISE pragma")]) tDecl _ _ _ (SpecInlineSig l _ _ _ _) = onlyDecl (WarnPragmaDecl l [([], "ignore SPECIALISE INLINE pragma")]) -tDecl _ _ _ (InstSig l _ _) = +tDecl _ _ _ (InstSig l _) = onlyDecl (WarnPragmaDecl l [([], "ignore SPECIALISE instance pragma")]) tDecl _ _ _ (AnnPragma l _) = onlyDecl (WarnPragmaDecl l [([], "ignore ANN pragma")]) @@ -704,21 +707,21 @@ -- Process pattern binding: tPatBind :: Environment -> Scope -> Tracing -> SrcSpanInfo -> - Pat SrcSpanInfo -> Maybe (Type SrcSpanInfo) -> Rhs SrcSpanInfo -> + Pat SrcSpanInfo -> Rhs SrcSpanInfo -> Maybe (Binds SrcSpanInfo) -> ([Decl SrcSpanInfo], ModuleConsts) -tPatBind env scope tracing l (PVar _ name) maybeType rhs maybeBinds = +tPatBind env scope tracing l (PVar _ name) rhs maybeBinds = -- simple case - tCaf env scope tracing l name maybeType rhs maybeBinds -tPatBind env scope tracing l (PAsPat _ name pat) maybeType rhs maybeBinds = + tCaf env scope tracing l name rhs maybeBinds +tPatBind env scope tracing l (PAsPat _ name pat) rhs maybeBinds = -- can break off simple case (cafDecls ++ patDecls, cafConsts `moduleConstsUnion` patConsts) where (cafDecls, cafConsts) = - tCaf env scope tracing l name maybeType rhs maybeBinds + tCaf env scope tracing l name rhs maybeBinds (patDecls, patConsts) = tDecl env scope tracing - (PatBind l pat maybeType (UnGuardedRhs l (Var l (UnQual l name))) Nothing) -tPatBind env scope tracing l pat maybeType rhs maybeBinds = + (PatBind l pat (UnGuardedRhs l (Var l (UnQual l name))) Nothing) +tPatBind env scope tracing l pat rhs maybeBinds = -- unfortunately we cannot transform a pattern binding into another pattern -- binding; we have to introduce an explicit `case' to be able to terminate -- with an appropriate error message when the pattern does not match. @@ -732,10 +735,10 @@ (map (useDef tracing) patNames ++ map (projDef scope tracing l patTuple (Var l (UnQual l resultTraceName)) patName resultTraceName) patNames ++ - [PatBind l (PVar l patName) Nothing (UnGuardedRhs l ( + [PatBind l (PVar l patName) (UnGuardedRhs l ( (Case l exp' - [Alt l pat'' (UnGuardedAlt l expTuple) Nothing - ,Alt l (PWildCard l) (UnGuardedAlt l (mkFailExp expParent)) Nothing]))) + [Alt l pat'' (UnGuardedRhs l expTuple) Nothing + ,Alt l (PWildCard l) (UnGuardedRhs l (mkFailExp expParent)) Nothing]))) Nothing] ,foldr moduleConstsUnion altConsts (map (moduleConstsSpan . ann) patNames)) where @@ -743,8 +746,8 @@ patNames = map (\(PVar _ name) -> name) patVars patName = nameTraceShared l firstName resultTraceName = nameTrace2 firstName - expTuple = Tuple l (map (Var l . UnQual l) (resultTraceName : patNames')) - patTuple = PTuple l (map (PVar l) (resultTraceName : patNames')) + expTuple = Tuple l Boxed (map (Var l . UnQual l) (resultTraceName : patNames')) + patTuple = PTuple l Boxed (map (PVar l) (resultTraceName : patNames')) patNames' = map (\(PVar _ name) -> name) patVars' (patVars', Nothing) = tPats patVars -- Nothing means that we do not support numeric patterns (k and n+k) @@ -776,14 +779,14 @@ projDef :: Scope -> Tracing -> SrcSpanInfo -> Pat SrcSpanInfo -> Exp SrcSpanInfo -> Name SrcSpanInfo -> Name SrcSpanInfo -> Name SrcSpanInfo -> Decl SrcSpanInfo projDef scope tracing l patTuple expVarResultTrace patName resultTraceName name = - PatBind l (PVar l (nameShare name)) Nothing + PatBind l (PVar l (nameShare name)) (UnGuardedRhs l (appN [mkExpConstDef tracing ,expParent ,Var l (UnQual l (nameTraceInfoVar l scope name)) ,Lambda l [PWildCard l] (Case l (Var l (UnQual l patName)) - [Alt l patTuple (UnGuardedAlt l + [Alt l patTuple (UnGuardedRhs l (if isLocal scope && tracing == Trusted then varLambdaName else appN @@ -799,12 +802,11 @@ -- Extract all variables from a pattern, left-to-right getPatVars :: Pat SrcSpanInfo -> [Pat SrcSpanInfo] getPatVars p@(PVar _ _) = [p] -getPatVars (PLit _ _) = [] -getPatVars (PNeg _ p) = getPatVars p +getPatVars (PLit _ _ _) = [] getPatVars (PNPlusK l _ _) = notSupported l "n+k pattern in pattern binding" getPatVars (PInfixApp _ pl _ pr) = getPatVars pl ++ getPatVars pr getPatVars (PApp _ _ ps) = concatMap getPatVars ps -getPatVars (PTuple _ ps) = concatMap getPatVars ps +getPatVars (PTuple _ _ ps) = concatMap getPatVars ps getPatVars (PList _ ps) = concatMap getPatVars ps getPatVars (PParen _ p) = getPatVars p getPatVars (PRec _ _ patFields) = concatMap getPatFieldVars patFields @@ -826,16 +828,15 @@ -- The second binding is similar to what projDef produces tCaf :: Environment -> Scope -> Tracing -> SrcSpanInfo -> Name SrcSpanInfo -> -- name of original caf - Maybe (Type SrcSpanInfo) -> Rhs SrcSpanInfo -> Maybe (Binds SrcSpanInfo) -> ([Decl SrcSpanInfo], ModuleConsts) -tCaf env scope tracing l name maybeType rhs maybeBinds = +tCaf env scope tracing l name rhs maybeBinds = -- Produce a wrapper and a worker, the latter must be a caf -- to avoid reevaluation. -- name sr p = constUse sr p name' -- name' = constDef parent "name" (\p -> [[rhs]]_p) ([useDef tracing name - ,PatBind l (PVar l (nameShare name)) (fmap tType maybeType) + ,PatBind l (PVar l (nameShare name)) (UnGuardedRhs l (appN [mkExpConstDef tracing ,expParent @@ -888,7 +889,7 @@ (Var l (UnQual l wrappedId')) funArity)) Nothing] :(if isLocal scope - then (PatBind l (PVar l (nameTraceInfoVar l Global orgName)) Nothing + then (PatBind l (PVar l (nameTraceInfoVar l Global orgName)) (UnGuardedRhs l (Var l (UnQual l (nameTraceInfoVar l Local orgName)))) Nothing :) @@ -1054,12 +1055,11 @@ GuardedRhss _ gdRhss -> gdRhssCanFail gdRhss numericLitIn :: Pat l -> Bool -numericLitIn (PLit _ (Int _ _ _)) = True -numericLitIn (PLit _ (Frac _ _ _)) = True -numericLitIn (PNeg _ pat) = numericLitIn pat +numericLitIn (PLit _ _ (Int _ _ _)) = True +numericLitIn (PLit _ _ (Frac _ _ _)) = True numericLitIn (PInfixApp _ pL _ pR) = numericLitIn pL || numericLitIn pR numericLitIn (PApp _ _ pats) = any numericLitIn pats -numericLitIn (PTuple _ pats) = any numericLitIn pats +numericLitIn (PTuple _ _ pats) = any numericLitIn pats numericLitIn (PList _ pats) = any numericLitIn pats numericLitIn (PParen _ p) = numericLitIn p numericLitIn (PRec _ _ patFields) = any numericLitInField patFields @@ -1150,7 +1150,7 @@ ,expParent ,Var l (UnQual l shareName)])) Nothing] - ,PatBind l (PVar l shareName) Nothing + ,PatBind l (PVar l shareName) (UnGuardedRhs l (appN [mkExpConstDef Trusted ,expParent @@ -1191,11 +1191,15 @@ -- Process class instances: +tInstRule :: InstRule SrcSpanInfo -> InstRule SrcSpanInfo +tInstRule (IRule l mTyVars mCtx iHead) = IRule l (fmap (map tTyVarBind) mTyVars) (fmap tContext mCtx) (tInstHead iHead) +tInstRule (IParen l iRule) = IParen l (tInstRule iRule) + tInstHead :: InstHead SrcSpanInfo -> InstHead SrcSpanInfo -tInstHead (IHead l qname tys) = IHead l (nameTransCls qname) (map tType tys) -tInstHead (IHInfix l tyL qname tyR) = - IHInfix l (tType tyL) (nameTransCls qname) (tType tyR) -tInstHead (IHParen l instHead) = IHParen l (tInstHead instHead) +tInstHead (IHCon l qname) = IHCon l (nameTransCls qname) -- or type name? +tInstHead (IHInfix l ty qname) = IHInfix l (tType ty) (nameTransCls qname) -- or type name? +tInstHead (IHParen l iHead) = IHParen l (tInstHead iHead) +tInstHead (IHApp l iHead ty) = IHApp l (tInstHead iHead) (tType ty) tInstDecls :: Environment -> Tracing -> [InstDecl SrcSpanInfo] -> @@ -1261,7 +1265,7 @@ where (FunBind l [match] : _ : workerDecls, moduleConsts) = tDecl env Local tracing decl -tClassInstDecl env tracing decl@(PatBind _ _ _ _ _) = +tClassInstDecl env tracing decl@(PatBind _ _ _ _) = -- Currently don't do any patching! -- Use of sharing variable needs to be qualified if class name needs to be -- qualified (still covers not all necessary cases) @@ -1273,7 +1277,7 @@ -- of the sharing variable. (tySig' : TypeSig l (map nameShare names) (tMapType tConstType ty) : - map (\name -> PatBind l (PVar l (nameShare name)) Nothing + map (\name -> PatBind l (PVar l (nameShare name)) (UnGuardedRhs l (appN [expUndefined,expSR,expParent])) Nothing) (filter (isUndefinedMethod env) names) ,moduleConsts) @@ -1358,11 +1362,12 @@ else [] go (TyKind l ty kind) tys = notSupported l "kind annotation in type synonym" +-- Map given function over the head name (not argument type names) mapDeclHead :: (Name l -> Name l) -> DeclHead l -> DeclHead l -mapDeclHead f (DHead l name tyVarBinds) = DHead l (f name) tyVarBinds -mapDeclHead f (DHInfix l tyVarBindL name tyVarBindR) = - DHInfix l tyVarBindL (f name) tyVarBindR +mapDeclHead f (DHead l name) = DHead l (f name) +mapDeclHead f (DHInfix l tyVarBind name) = DHInfix l tyVarBind (f name) mapDeclHead f (DHParen l declHead) = DHParen l (mapDeclHead f declHead) +mapDeclHead f (DHApp l declHead tyVarBind) = DHApp l (mapDeclHead f declHead) tyVarBind -- Process data type declarations: @@ -1391,21 +1396,22 @@ tTyVarBind (UnkindedVar l name) = UnkindedVar l name tConDecl :: ConDecl SrcSpanInfo -> ConDecl SrcSpanInfo -tConDecl (ConDecl l name bangTys) = - ConDecl l (nameTransCon name) (map tBangType bangTys) -tConDecl (InfixConDecl l btL name btR) = - InfixConDecl l (tBangType btL) (nameTransCon name) (tBangType btR) +tConDecl (ConDecl l name tys) = + ConDecl l (nameTransCon name) (map tConstType tys) +tConDecl (InfixConDecl l tyL name tyR) = + InfixConDecl l (tConstType tyL) (nameTransCon name) (tConstType tyR) tConDecl (RecDecl l name fieldDecls) = RecDecl l (nameTransCon name) (map tFieldDecl fieldDecls) tFieldDecl :: FieldDecl SrcSpanInfo -> FieldDecl SrcSpanInfo -tFieldDecl (FieldDecl l fieldNames bangTy) = - FieldDecl l (map nameTransField fieldNames) (tBangType bangTy) +tFieldDecl (FieldDecl l fieldNames ty) = + FieldDecl l (map nameTransField fieldNames) (tConstType ty) +{- not used tBangType :: BangType SrcSpanInfo -> BangType SrcSpanInfo -tBangType (BangedTy l ty) = BangedTy l (wrapType (tType ty)) -tBangType (UnBangedTy l ty) = UnBangedTy l (wrapType (tType ty)) -tBangType (UnpackedTy l ty) = UnpackedTy l (wrapType (tType ty)) +tBangType (BangedTy l) = BangedTy l +tBangType (UnpackedTy l) = UnpackedTy l +-} @@ -1462,22 +1468,26 @@ [QualConDecl SrcSpanInfo] -> Decl SrcSpanInfo wrapValInstDecl env tracing maybeContext declHead qualConDecls = - InstDecl l maybeContext - (IHead l (qNameWrapValClass l) [dataDeclHeadToType declHead]) + InstDecl l Nothing + (IRule l Nothing maybeContext + (IHApp l (IHCon l (qNameWrapValClass l)) (dataDeclHeadToType declHead))) (Just [InsDecl l (FunBind l (map wrapValMatch conDecls))]) where l = ann declHead conDecls = map (\(QualConDecl _ _ _ conDecl) -> conDecl) qualConDecls -dataDeclHeadToType :: DeclHead l -> Type l -dataDeclHeadToType (DHead l name tyVarBinds) = - tyAppN (TyCon l (UnQual l name) : map tyVarBindToType tyVarBinds) - - -tyVarBindToType :: TyVarBind l -> Type l -tyVarBindToType (KindedVar l name kind) = - TyParen l (TyKind l (TyVar l name) kind) -tyVarBindToType (UnkindedVar l name) = TyVar l name +-- assuming this is the head of a type declaration, turn it into a type +-- data T a b = .... => (T a b) +dataDeclHeadToType :: DeclHead SrcSpanInfo -> Type SrcSpanInfo +dataDeclHeadToType declHead = go declHead [] + where + go (DHead l name) tys = -- type name + tyAppN (TyCon l (UnQual l name) : tys) + go (DHInfix l tyVarBind name) (ty2:tys) = + tyAppN (TyInfix l (tyVarBind2Type tyVarBind) (UnQual l name) ty2 : tys) + go (DHInfix l _ _) [] = notSupported l "Infix data type with single argument." + go (DHParen l declHead) tys = go declHead tys + go (DHApp l declHead tyVarBind) tys = go declHead (tyVarBind2Type tyVarBind : tys) wrapValMatch :: ConDecl SrcSpanInfo -> Match SrcSpanInfo wrapValMatch conDecl = @@ -1504,7 +1514,8 @@ varName = nameTrace2 (nameWrapValFun l) srName = nameSR (nameWrapValFun l) --- ---------------------------------------------------------------------------- -- Transform expressions +-- ---------------------------------------------------------------------------- +-- Transform expressions -- Boolean argument True iff the parent is equal to this expression, i.e., @@ -1570,8 +1581,8 @@ then Lambda l (pats' ++ [patParent]) body' else Lambda l (map (PVar l) nameVars ++ [patParent]) (Case l (mkExpTuple (map (Var l . UnQual l) nameVars)) - [Alt l (mkPatTuple pats') (UnGuardedAlt l body') Nothing - ,Alt l (PWildCard l) (UnGuardedAlt l expFail) Nothing] + [Alt l (mkPatTuple pats') (UnGuardedRhs l body') Nothing + ,Alt l (PWildCard l) (UnGuardedRhs l expFail) Nothing] ) (Match _ _ pats' (UnGuardedRhs _ body') _, bodyConsts) = tMatch env tracing True undefined failContinuation @@ -1628,12 +1639,12 @@ tExpF env tracing ls es (tExpA env tracing cr (removeDo stmts) [] []) tExpA env tracing cr (MDo l _) ls es = notSupported l "mdo-expression" -tExpA env tracing cr (Tuple l exps) [] [] = +tExpA env tracing cr (Tuple l Boxed exps) [] [] = tConApp env tracing (Special l (TupleCon l Boxed a)) (replicate a l) exps where a = length exps -tExpA env tracing cr (TupleSection l maybeExps) ls es = +tExpA env tracing cr (TupleSection l Boxed maybeExps) ls es = -- desugar tuple section into lambda tExpA env tracing cr (desugarTupleSection l maybeExps) ls es tExpA env tracing cr (List l []) [] [] = -- just the empty list, transform efficiently @@ -1692,7 +1703,7 @@ where mkFieldVarDecl :: Name SrcSpanInfo -> Exp SrcSpanInfo -> Decl SrcSpanInfo mkFieldVarDecl name exp = - PatBind noSpan (PVar noSpan name) Nothing (UnGuardedRhs noSpan exp) Nothing + PatBind noSpan (PVar noSpan name) (UnGuardedRhs noSpan exp) Nothing (exp', expConsts) = tExp env Traced False exp (fieldUpdates', fieldsConsts) = mapMerge2 (tField env Traced) fieldUpdates labels = map (Var l . UnQual l . nameTraceInfoVar l Global) labelNames @@ -1787,6 +1798,8 @@ notSupported l "higher-order arrow application from left" tExpA env tracing cr (RightArrHighApp l _ _) ls es = notSupported l "higher-order arrow application from right" +tExpA _ _ _ exp _ _ = + notSupported (ann exp) "unkown form of expression" -- At end of transforming expressions possibly add deferred applications. -- Lists are ordered from innermost to outermost. @@ -1877,8 +1890,7 @@ -- (safe approximation) neverFailingPat :: Pat l -> Bool neverFailingPat (PVar _ _) = True -neverFailingPat (PNeg _ p) = neverFailingPat p -neverFailingPat (PTuple _ ps) = neverFailingPats ps +neverFailingPat (PTuple _ _ ps) = neverFailingPats ps neverFailingPat (PParen _ p) = neverFailingPat p neverFailingPat (PAsPat _ _ p) = neverFailingPat p neverFailingPat (PWildCard _) = True @@ -1919,9 +1931,9 @@ then Lambda l [pat] (removeDo stmts) else Lambda l [PVar l newName] (Case l (Var l (UnQual l newName)) - [Alt l pat (UnGuardedAlt l (removeDo stmts)) Nothing + [Alt l pat (UnGuardedRhs l (removeDo stmts)) Nothing ,Alt l (PWildCard l) - (UnGuardedAlt l + (UnGuardedRhs l (App l (Var l (qNameDeriveFail l)) (Lit l (String l msg msg)))) Nothing])] @@ -1934,7 +1946,7 @@ desugarTupleSection :: SrcSpanInfo -> [Maybe (Exp SrcSpanInfo)] -> Exp SrcSpanInfo desugarTupleSection l maybeExps = - Lambda l (map (PVar l) varNames) (Tuple l (mkTuple maybeExps varNames)) + Lambda l (map (PVar l) varNames) (mkExpTuple (mkTuple maybeExps varNames)) where arity = length (filter isNothing maybeExps) varNames = take arity (namesFromSpan l) @@ -2008,14 +2020,14 @@ ,Maybe (QName SrcSpanInfo, Exp SrcSpanInfo, [Decl SrcSpanInfo] ,[Exp SrcSpanInfo], [Pat SrcSpanInfo])) tPat (PVar l name) = (PVar l (nameTransLambdaVar name), Nothing) -tPat (PLit _ lit@(Char l c str)) = - (wrapPat (PLit l lit) (PWildCard l), Nothing) -tPat (PLit _ (String l s str)) = +tPat (PLit _ (Signless _) lit@(Char l c str)) = + (wrapPat (PLit l (Signless l) lit) (PWildCard l), Nothing) +tPat (PLit _ (Signless _) (String l s str)) = tPat . mkPatList l . map mkPatChar $ s where mkPatChar :: Char -> Pat SrcSpanInfo - mkPatChar c = PLit l (Char l c (show c)) -tPat (PLit _ lit@(Int l int str)) = + mkPatChar c = PLit l (Signless l) (Char l c (show c)) +tPat (PLit _ (Signless _) lit@(Int l int str)) = (PVar l (nameTransLambdaVar nameNew) ,Just (UnQual l nameNew ,App l (App l (mkExpDeriveEqualEqual l) @@ -2024,7 +2036,7 @@ ,[],[],[])) where nameNew = nameFromSpan l -tPat (PLit _ lit@(Frac l rat str)) = +tPat (PLit _ (Signless _) lit@(Frac l rat str)) = (PVar l (nameTransLambdaVar nameNew) ,Just (UnQual l nameNew ,App l (App l (mkExpDeriveEqualEqual l) @@ -2033,23 +2045,24 @@ ,[],[],[])) where nameNew = nameFromSpan l -tPat (PLit l lit) = - notSupported l "unboxed literal" -tPat (PNeg l (PLit _ (Int _ int str))) = - -- a negative integer literal is represented as negate int - tPat (PLit l (Int l (-int) ('-':str))) -tPat (PNeg l (PLit _ (Frac _ rat str))) = +tPat (PLit l (Negative _) (Int _ int str)) = + -- a negative integer literal is represented as negate int, so literal can be negative + -- differs from ghc where + -- f (-k) = v is sugar for f z | z == negate (fromInteger k) = v + tPat (PLit l (Signless l) (Int l (-int) ('-':str))) +tPat (PLit l (Negative _) (Frac _ rat str)) = -- a negative floating point literal is represented as negate frac - tPat (PLit l (Frac l (-rat) ('-':str))) -tPat (PNeg l _) = - notSupported l "negated pattern" + -- same issues as above + tPat (PLit l (Signless l) (Frac l (-rat) ('-':str))) +tPat (PLit l _ lit) = + notSupported l "unsupported literal in pattern" tPat (PNPlusK l n k) = (PVar l (nameTransLambdaVar nameNew) ,Just (UnQual l nameNew ,App l (App l (mkExpDeriveGreaterEqual l) varNew) litK - ,[PatBind l (PVar l n) Nothing + ,[PatBind l (PVar l n) (UnGuardedRhs l (App l (App l (mkExpDeriveMinus l) varNew) litK)) Nothing] @@ -2065,7 +2078,7 @@ ,patsNumInfo) where (pats', patsNumInfo) = tPats pats -tPat (PTuple l pats) = +tPat (PTuple l Boxed pats) = tPat (PApp l (Special l (TupleCon l Boxed arity)) pats) where arity = length pats @@ -2116,8 +2129,6 @@ notSupported l "XML embedded pattern" tPat (PXRPats l _) = notSupported l "XML regular list pattern" -tPat (PExplTypeArg l _ _) = - notSupported l "explicit generics style type argument" tPat (PQuasiQuote l _ _) = notSupported l "quasi quote pattern" tPat (PBangPat l pat) = @@ -2262,7 +2273,6 @@ tContext :: Context SrcSpanInfo -> Context SrcSpanInfo tContext (CxSingle l asst) = CxSingle l (tAsst asst) tContext (CxTuple l assts) = CxTuple l (map tAsst assts) -tContext (CxParen l ctx) = CxParen l (tContext ctx) tContext (CxEmpty l) = CxEmpty l tAsst :: Asst SrcSpanInfo -> Asst SrcSpanInfo @@ -2440,7 +2450,7 @@ update (Symbol l name) = Symbol l (d : showsSymEncodeSpan span name) prefixNames :: UpdId i => Char -> Char -> i -> [i] -prefixNames c d name = map (($ name) . updateId . update) [1..] +prefixNames c d name = map (($ name) . updateId . update) [(1::Int)..] where update no (Ident l name) = Ident l (c : show no ++ name) update no (Symbol l name) = Symbol l (d : numToSym (show no) ++ name) @@ -2625,10 +2635,10 @@ -- Frequently used in transformed code: mkExpTuple :: [Exp SrcSpanInfo] -> Exp SrcSpanInfo -mkExpTuple es = Tuple noSpan es +mkExpTuple es = Tuple noSpan Boxed es mkPatTuple :: [Pat SrcSpanInfo] -> Pat SrcSpanInfo -mkPatTuple ps = PTuple noSpan ps +mkPatTuple ps = PTuple noSpan Boxed ps mkExpList :: [Exp SrcSpanInfo] -> Exp SrcSpanInfo mkExpList = diff --git a/trans/Wrap.hs b/trans/Wrap.hs --- a/trans/Wrap.hs +++ b/trans/Wrap.hs @@ -41,7 +41,7 @@ import Language.Haskell.Exts.Annotated import System.FilePath(FilePath) import SynHelp (nameFromOp,mkQual,declHeadName,declHeadTyVarBinds,getId - ,isUnQual,getModuleNameFromModule,tyVarBind2Type) + ,isUnQual,getModuleNameFromModule,tyVarBind2Type,notSupported) wrap :: FilePath -> Module SrcSpanInfo -> Module SrcSpanInfo wrap filename mod@(Module l maybeModuleHead modulePragmas importDecls decls) = @@ -56,18 +56,19 @@ mkImportOriginal :: ModuleName l -> ImportDecl l mkImportOriginal modName = ImportDecl {importAnn = ann modName, importModule = modName, importQualified = True, importSrc = False, - importPkg = Nothing, importAs = Nothing, importSpecs = Nothing} + importSafe = False, importPkg = Nothing, importAs = Nothing, importSpecs = Nothing} type Exported l = Name l -> Bool -getExported :: Maybe (ModuleHead l) -> Exported l +getExported :: SrcInfo l => Maybe (ModuleHead l) -> Exported l getExported Nothing = const True -- everything exported getExported (Just (ModuleHead l modName maybeWarningText Nothing)) = const True -- everything exported getExported (Just (ModuleHead l modName maybeWarningText (Just (ExportSpecList _ exportSpecs)))) = \name -> (name `within`) `any` exportSpecs where - within :: Name l1 -> ExportSpec l2 -> Bool - name `within` (EVar l qname) = same modName name qname + 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 @@ -85,7 +86,7 @@ -- Doesn't handle deriving. -- ToDo: general case. [DataDecl l (NewType l) Nothing declHead - [QualConDecl l Nothing Nothing (ConDecl l name [UnBangedTy l newType])] Nothing] + [QualConDecl l Nothing Nothing (ConDecl l name [newType])] Nothing] where -- need to get type variable parameters name = declHeadName declHead @@ -100,7 +101,7 @@ where expOps = filter (exported . nameFromOp) ops trans exported modName (FunBind l matches) = [] -- remove function declaration -trans exported modName (PatBind l pat maybeTy rhs maybeBinds) = [] -- remove pattern declaration +trans exported modName (PatBind l pat rhs maybeBinds) = [] -- remove pattern declaration trans exported modName (ForImp l callConv maybeSafety maybeString name ty) | exported name = [mkForeignHaskell modName ty name] trans _ _ _ = [] -- ToDo: check which other declarations do need special treatment