liquidhaskell 0.4.1.1 → 0.5.0.0
raw patch · 69 files changed
+15155/−505 lines, 69 filesdep +Cabaldep +stmdep +transformersdep ~ghcdep ~process
Dependencies added: Cabal, stm, transformers
Dependency ranges changed: ghc, process
Files
- Liquid.hs +20/−10
- include/708/Control/Monad.spec +3/−0
- include/710/Data/Traversable.spec +3/−0
- include/GHC/Base.spec +2/−2
- include/GHC/CString.spec +3/−1
- include/Prelude.spec +1/−1
- liquidhaskell.cabal +48/−27
- src/Language/Haskell/Liquid/ANFTransform.hs +8/−7
- src/Language/Haskell/Liquid/Annotate.hs +80/−83
- src/Language/Haskell/Liquid/Bare/Check.hs +4/−8
- src/Language/Haskell/Liquid/Bare/GhcSpec.hs +6/−3
- src/Language/Haskell/Liquid/Bare/Lookup.hs +2/−3
- src/Language/Haskell/Liquid/Bare/Measure.hs +1/−1
- src/Language/Haskell/Liquid/Bare/SymSort.hs +1/−1
- src/Language/Haskell/Liquid/Cabal.hs +254/−0
- src/Language/Haskell/Liquid/CmdLine.hs +82/−39
- src/Language/Haskell/Liquid/Constraint/Generate.hs +156/−81
- src/Language/Haskell/Liquid/Constraint/ToFixpoint.hs +11/−24
- src/Language/Haskell/Liquid/Constraint/Types.hs +41/−43
- src/Language/Haskell/Liquid/CoreToLogic.hs +1/−0
- src/Language/Haskell/Liquid/Desugar710/Check.hs +773/−0
- src/Language/Haskell/Liquid/Desugar710/Coverage.hs +1274/−0
- src/Language/Haskell/Liquid/Desugar710/Desugar.hs +484/−0
- src/Language/Haskell/Liquid/Desugar710/DsArrows.hs +1178/−0
- src/Language/Haskell/Liquid/Desugar710/DsBinds.hs +1196/−0
- src/Language/Haskell/Liquid/Desugar710/DsCCall.hs +382/−0
- src/Language/Haskell/Liquid/Desugar710/DsExpr.hs +982/−0
- src/Language/Haskell/Liquid/Desugar710/DsExpr.hs-boot +9/−0
- src/Language/Haskell/Liquid/Desugar710/DsForeign.hs +809/−0
- src/Language/Haskell/Liquid/Desugar710/DsGRHSs.hs +158/−0
- src/Language/Haskell/Liquid/Desugar710/DsListComp.hs +871/−0
- src/Language/Haskell/Liquid/Desugar710/DsMeta.hs +2917/−0
- src/Language/Haskell/Liquid/Desugar710/DsUtils.hs +838/−0
- src/Language/Haskell/Liquid/Desugar710/HscMain.hs +95/−0
- src/Language/Haskell/Liquid/Desugar710/Match.hs +1091/−0
- src/Language/Haskell/Liquid/Desugar710/Match.hs-boot +33/−0
- src/Language/Haskell/Liquid/Desugar710/MatchCon.hs +290/−0
- src/Language/Haskell/Liquid/Desugar710/MatchLit.hs +395/−0
- src/Language/Haskell/Liquid/Errors.hs +26/−22
- src/Language/Haskell/Liquid/GhcInterface.hs +6/−11
- src/Language/Haskell/Liquid/GhcMisc.hs +18/−3
- src/Language/Haskell/Liquid/Literals.hs +16/−4
- src/Language/Haskell/Liquid/Measure.hs +20/−0
- src/Language/Haskell/Liquid/Names.hs +6/−0
- src/Language/Haskell/Liquid/Parse.hs +71/−14
- src/Language/Haskell/Liquid/PredType.hs +1/−2
- src/Language/Haskell/Liquid/RefType.hs +68/−47
- src/Language/Haskell/Liquid/Types.hs +27/−10
- tests/ffi-include/foo.c +4/−0
- tests/ffi-include/foo.h +1/−0
- tests/neg/AutoSize.hs +20/−0
- tests/neg/ListDataCons.hs +0/−16
- tests/neg/Solver.hs +101/−0
- tests/neg/datacon-eq.hs +4/−2
- tests/neg/lit.hs +4/−0
- tests/pos/AutoSize.hs +17/−0
- tests/pos/Bar.hs +0/−5
- tests/pos/GhcListSort.hs +5/−3
- tests/pos/HasElem.hs +0/−4
- tests/pos/ListDataCons.hs +0/−16
- tests/pos/Solver.hs +101/−0
- tests/pos/State.hquals +10/−0
- tests/pos/StringLit.hs +4/−0
- tests/pos/div000.hs +11/−0
- tests/pos/listSet.hquals +4/−0
- tests/pos/lit.hs +4/−0
- tests/pos/selfList.hquals +1/−0
- tests/pos/test000.hs +3/−5
- tests/test.hs +100/−7
Liquid.hs view
@@ -1,9 +1,16 @@ {-# LANGUAGE TupleSections #-}+{-# LANGUAGE CPP #-} -import Data.Maybe+{-@ LIQUID "--cabaldir" @-}+{-@ LIQUID "--diff" @-}++#if __GLASGOW_HASKELL__ < 710 import Data.Monoid (mconcat, mempty)-import System.Exit import Control.Applicative ((<$>))+#endif++import Data.Maybe+import System.Exit import Control.DeepSeq import Text.PrettyPrint.HughesPJ import CoreSyn@@ -15,7 +22,7 @@ import qualified Language.Haskell.Liquid.DiffCheck as DC import Language.Fixpoint.Misc import Language.Fixpoint.Interface-import Language.Fixpoint.Types (sinfo)+import Language.Fixpoint.Types (sinfo, Result (..)) import Language.Haskell.Liquid.Types import Language.Haskell.Liquid.Errors import Language.Haskell.Liquid.CmdLine@@ -26,6 +33,8 @@ import Language.Haskell.Liquid.TransformRec import Language.Haskell.Liquid.Annotate (mkOutput) ++ main :: IO b main = do cfg0 <- getOpts res <- mconcat <$> mapM (checkOne cfg0) (files cfg0)@@ -63,26 +72,26 @@ DC.saveResult target out' exitWithResult cfg target out' --- checkedNames :: Maybe DC.DiffCheck -> Maybe [Name.Name]+checkedNames :: Maybe DC.DiffCheck -> Maybe [String] checkedNames dc = concatMap names . DC.newBinds <$> dc where names (NonRec v _ ) = [showpp $ shvar v] names (Rec xs) = map (shvar . fst) xs shvar = showpp . varName ---- prune :: Config -> [CoreBind] -> FilePath -> GhcInfo -> IO (Maybe Diff)-prune cfg cbs target info- | not (null vs) = return . Just $ DC.DC (DC.thin cbs vs) mempty sp- | diffcheck cfg = DC.slice target cbs sp+prune :: Config -> [CoreBind] -> FilePath -> GhcInfo -> IO (Maybe DC.DiffCheck)+prune cfg cbinds target info+ | not (null vs) = return . Just $ DC.DC (DC.thin cbinds vs) mempty sp+ | diffcheck cfg = DC.slice target cbinds sp | otherwise = return Nothing where vs = tgtVars sp sp = spec info +solveCs :: Config -> FilePath -> CGInfo -> GhcInfo -> Maybe DC.DiffCheck -> IO (Output Doc) solveCs cfg target cgi info dc = do finfo <- cgInfoFInfo info cgi- (r, sol) <- solve fx finfo+ Result r sol <- solve fx finfo let names = checkedNames dc let warns = logErrors cgi let annm = annotMap cgi@@ -94,6 +103,7 @@ , FC.real = real cfg , FC.native = native cfg , FC.srcFile = target+ -- , FC.stats = True } ferr s r = fmap (tidyError s) $ result $ sinfo <$> r
+ include/708/Control/Monad.spec view
@@ -0,0 +1,3 @@+module spec Control.Monad where++Control.Monad.sequence :: GHC.Base.Monad m => xs:[m a] -> m {v:[a] | (len v) = (len xs)}
+ include/710/Data/Traversable.spec view
@@ -0,0 +1,3 @@+module spec Data.Traversable where++Data.Traversable.sequence :: Data.Traversable.Traversable t => GHC.Base.Monad m => xs:t (m a) -> m (t {v:[a] | (len v) = (len xs)})
include/GHC/Base.spec view
@@ -1,5 +1,6 @@ module spec GHC.Base where +import GHC.CString import GHC.Prim import GHC.Classes import GHC.Types@@ -9,6 +10,7 @@ measure Prop :: GHC.Types.Bool -> Prop +measure autolen :: forall a. a -> GHC.Types.Int class measure len :: forall f a. f a -> GHC.Types.Int instance measure len :: forall a. [a] -> GHC.Types.Int len [] = 0@@ -34,5 +36,3 @@ ($) :: (a -> b) -> a -> b id :: x:a -> {v:a | v = x}--
include/GHC/CString.spec view
@@ -2,4 +2,6 @@ import GHC.Prim -GHC.CString.unpackCString# :: x:GHC.Prim.Addr# -> {v:String | v ~~ x}+GHC.CString.unpackCString#+ :: x:GHC.Prim.Addr#+ -> {v:[Char] | v ~~ x && len v == strLen x}
include/Prelude.spec view
@@ -25,7 +25,7 @@ assume GHC.Num.+ :: (GHC.Num.Num a) => x:a -> y:a -> {v:a | v = x + y } assume GHC.Num.- :: (GHC.Num.Num a) => x:a -> y:a -> {v:a | v = x - y } -embed GHC.Types.Double as real+embed GHC.Types.Double as real embed GHC.Integer.Type.Integer as int type GeInt N = {v: GHC.Types.Int | v >= N }
liquidhaskell.cabal view
@@ -1,5 +1,5 @@ Name: liquidhaskell-Version: 0.4.1.1+Version: 0.5.0.0 Copyright: 2010-15 Ranjit Jhala, University of California, San Diego. build-type: Simple Synopsis: Liquid Types for Haskell @@ -32,21 +32,21 @@ , include/Language/Haskell/Liquid/*.hs , include/Language/Haskell/Liquid/*.pred , include/System/*.spec+ , include/708/Control/*.spec+ , include/710/Data/*.spec , syntax/liquid.css extra-source-files: tests/pos/*.hs , tests/neg/*.hs , tests/crash/*.hs+ , tests/pos/*.hquals+ , tests/ffi-include/foo.c+ , tests/ffi-include/foo.h Source-Repository head Type: git Location: https://github.com/ucsd-progsys/liquidhaskell/ ---Flag devel--- Description: turn on stricter error reporting for development--- Default: False--- Manual: True- Flag include Description: use in-tree include directory Default: False@@ -54,7 +54,7 @@ Executable liquid default-language: Haskell98 Build-Depends: base >= 4 && < 5- , ghc>=7.8.3+ , ghc , ansi-terminal , template-haskell , time@@ -88,9 +88,7 @@ , liquidhaskell Main-is: Liquid.hs- ghc-options: -W -fno-warn-unused-imports -fno-warn-dodgy-imports -fno-warn-deprecated-flags -fno-warn-deprecations--- if flag(devel)--- ghc-options: -Werror+ ghc-options: -W -fno-warn-unused-imports -fno-warn-dodgy-imports -fno-warn-deprecated-flags -fno-warn-deprecations Default-Extensions: PatternGuards -- Executable liquid-count-binders@@ -131,7 +129,7 @@ Library Default-Language: Haskell98 Build-Depends: base- , ghc>=7.8.3+ , ghc == 7.8.3 || == 7.8.4 || == 7.10.2 , ansi-terminal , template-haskell , time@@ -152,7 +150,7 @@ , mtl , parsec , pretty- , process+ , process >= 1.2 , syb , text , intern@@ -163,6 +161,7 @@ , aeson , bytestring , fingertree+ , Cabal >= 1.18 hs-source-dirs: src, include @@ -189,6 +188,7 @@ Language.Haskell.Liquid.Annotate, Language.Haskell.Liquid.CTags, Language.Haskell.Liquid.CmdLine, + Language.Haskell.Liquid.Cabal, Language.Haskell.Liquid.GhcMisc, Language.Haskell.Liquid.GhcPlay, Language.Haskell.Liquid.Misc, @@ -206,6 +206,7 @@ Language.Haskell.Liquid.Fresh, Language.Haskell.Liquid.Visitors, Language.Haskell.Liquid.WiredIn,+ Language.Haskell.Liquid.Names, Paths_liquidhaskell, -- FIXME: These shouldn't really be exposed, but the linker complains otherwise...@@ -229,27 +230,43 @@ if impl(ghc < 7.10) exposed-modules: --NOTE: these need to be exposed so GHC generates .dyn_o files for them..+ Language.Haskell.Liquid.Desugar.Check,+ Language.Haskell.Liquid.Desugar.Coverage, Language.Haskell.Liquid.Desugar.Desugar,+ Language.Haskell.Liquid.Desugar.DsArrows,+ Language.Haskell.Liquid.Desugar.DsBinds, Language.Haskell.Liquid.Desugar.DsExpr,- Language.Haskell.Liquid.Desugar.Coverage,- Language.Haskell.Liquid.Desugar.Check, Language.Haskell.Liquid.Desugar.DsForeign,- Language.Haskell.Liquid.Desugar.DsMeta,+ Language.Haskell.Liquid.Desugar.DsGRHSs, Language.Haskell.Liquid.Desugar.DsListComp,- Language.Haskell.Liquid.Desugar.MatchCon,- Language.Haskell.Liquid.Desugar.MatchLit,- Language.Haskell.Liquid.Desugar.DsArrows,+ Language.Haskell.Liquid.Desugar.DsMeta, Language.Haskell.Liquid.Desugar.DsUtils,+ Language.Haskell.Liquid.Desugar.HscMain, Language.Haskell.Liquid.Desugar.Match,- Language.Haskell.Liquid.Desugar.DsBinds,- Language.Haskell.Liquid.Desugar.DsGRHSs,- Language.Haskell.Liquid.Desugar.HscMain+ Language.Haskell.Liquid.Desugar.MatchCon,+ Language.Haskell.Liquid.Desugar.MatchLit+ else+ exposed-modules:+ --NOTE: these need to be exposed so GHC generates .dyn_o files for them..+ Language.Haskell.Liquid.Desugar710.Check,+ Language.Haskell.Liquid.Desugar710.Coverage,+ Language.Haskell.Liquid.Desugar710.Desugar,+ Language.Haskell.Liquid.Desugar710.DsArrows,+ Language.Haskell.Liquid.Desugar710.DsBinds,+ Language.Haskell.Liquid.Desugar710.DsCCall,+ Language.Haskell.Liquid.Desugar710.DsExpr,+ Language.Haskell.Liquid.Desugar710.DsForeign,+ Language.Haskell.Liquid.Desugar710.DsGRHSs,+ Language.Haskell.Liquid.Desugar710.DsListComp,+ Language.Haskell.Liquid.Desugar710.DsMeta,+ Language.Haskell.Liquid.Desugar710.DsUtils,+ Language.Haskell.Liquid.Desugar710.HscMain,+ Language.Haskell.Liquid.Desugar710.Match,+ Language.Haskell.Liquid.Desugar710.MatchCon,+ Language.Haskell.Liquid.Desugar710.MatchLit ghc-options: -W -fno-warn-unused-imports -fno-warn-dodgy-imports -fno-warn-deprecated-flags -fno-warn-deprecations--- if flag(devel)--- ghc-options: -Werror if flag(include) hs-source-dirs: devel- ghc-prof-options: -fprof-auto Default-Extensions: PatternGuards test-suite test@@ -259,12 +276,16 @@ ghc-options: -O2 -threaded main-is: test.hs build-depends: base,+ liquidhaskell,+ containers, directory, filepath,+ mtl, process,- tagged,- liquidhaskell, optparse-applicative == 0.11.*,+ stm,+ tagged, tasty >= 0.10, tasty-hunit >= 0.9,- tasty-rerun >= 1.1+ tasty-rerun >= 1.1,+ transformers
src/Language/Haskell/Liquid/ANFTransform.hs view
@@ -125,11 +125,11 @@ -- normalizeNameDebug γ e -- = liftM (tracePpr ("normalizeName" ++ showPpr e)) $ normalizeName γ e -normalizeName _ e@(Lit (LitInteger _ _))- = normalizeLiteral e--normalizeName _ e@(Tick _ (Lit (LitInteger _ _)))+normalizeName _ e@(Lit l)+ | shouldNormalize l = normalizeLiteral e+ | otherwise+ = return e normalizeName γ (Var x) = return $ Var (lookupWithDefaultVarEnv γ x x)@@ -137,9 +137,6 @@ normalizeName _ e@(Type _) = return e -normalizeName _ e@(Lit _)- = return e- normalizeName _ e@(Coercion _) = do x <- lift $ freshNormalVar $ exprType e add [NonRec x e]@@ -155,6 +152,10 @@ add [NonRec x e'] return $ Var x +shouldNormalize l = case l of+ LitInteger _ _ -> True+ MachStr _ -> True+ _ -> False add :: [CoreBind] -> DsMW () add w = modify $ \s -> s{st_binds = st_binds s++w}
src/Language/Haskell/Liquid/Annotate.hs view
@@ -6,7 +6,7 @@ {-# LANGUAGE FlexibleInstances #-} ------------------------------------------------------------------------------ | This module contains the code that uses the inferred types to generate +-- | This module contains the code that uses the inferred types to generate -- 1. HTMLized source with Inferred Types in mouseover annotations. -- 2. Annotations files (e.g. for vim/emacs) -- 3. JSON files for the web-demo etc.@@ -27,12 +27,12 @@ import Data.List (sortBy) import Data.Maybe (mapMaybe) -import Data.Aeson +import Data.Aeson import Control.Arrow hiding ((<+>)) import Control.Applicative ((<$>)) import Control.Monad (when, forM_) -import System.FilePath (takeFileName, dropFileName, (</>)) +import System.FilePath (takeFileName, dropFileName, (</>)) import System.Directory (findExecutable, copyFile) import Text.Printf (printf) import qualified Data.List as L@@ -58,28 +58,28 @@ -------------------------------------------------------------------------------------------- mkOutput :: Config -> FixResult Error -> FixSolution -> AnnInfo (Annot SpecType) -> Output Doc ---------------------------------------------------------------------------------------------mkOutput cfg res sol anna +mkOutput cfg res sol anna = O { o_vars = Nothing , o_errors = []- , o_types = toDoc <$> annTy + , o_types = toDoc <$> annTy , o_templs = toDoc <$> annTmpl- , o_bots = mkBots annTy - , o_result = res + , o_bots = mkBots annTy+ , o_result = res } where annTmpl = closeAnnots anna- annTy = tidySpecType Lossy <$> applySolution sol annTmpl + annTy = tidySpecType Lossy <$> applySolution sol annTmpl toDoc = rtypeDoc tidy tidy = if shortNames cfg then Lossy else Full --- | @annotate@ actually renders the output to files +-- | @annotate@ actually renders the output to files --------------------------------------------------------------------annotate :: Config -> FilePath -> Output Doc -> IO () +annotate :: Config -> FilePath -> Output Doc -> IO () ------------------------------------------------------------------- annotate cfg srcF out = do generateHtml srcF tpHtmlF tplAnnMap- generateHtml srcF tyHtmlF typAnnMap - writeFile vimF $ vimAnnot cfg annTyp + generateHtml srcF tyHtmlF typAnnMap+ writeFile vimF $ vimAnnot cfg annTyp B.writeFile jsonF $ encode typAnnMap when showWarns $ forM_ bots (printf "WARNING: Found false in %s\n" . showPpr) where@@ -89,10 +89,10 @@ annTyp = o_types out result = o_result out bots = o_bots out- tyHtmlF = extFileName Html srcF - tpHtmlF = extFileName Html $ extFileName Cst srcF + tyHtmlF = extFileName Html srcF+ tpHtmlF = extFileName Html $ extFileName Cst srcF _annF = extFileName Annot srcF- jsonF = extFileName Json srcF + jsonF = extFileName Json srcF vimF = extFileName Vim srcF showWarns = not $ nowarnings cfg @@ -100,70 +100,70 @@ , isFalse (rTypeReft t) ] writeFilesOrStrings :: FilePath -> [Either FilePath String] -> IO ()-writeFilesOrStrings tgtFile = mapM_ $ either (`copyFile` tgtFile) (tgtFile `appendFile`) +writeFilesOrStrings tgtFile = mapM_ $ either (`copyFile` tgtFile) (tgtFile `appendFile`) generateHtml srcF htmlF annm = do src <- readFile srcF let lhs = isExtFile LHs srcF let body = {-# SCC "hsannot" #-} ACSS.hsannot False (Just tokAnnot) lhs (src, annm) cssFile <- getCssPath- copyFile cssFile (dropFileName htmlF </> takeFileName cssFile) + copyFile cssFile (dropFileName htmlF </> takeFileName cssFile) renderHtml lhs htmlF srcF (takeFileName cssFile) body -renderHtml True = renderPandoc +renderHtml True = renderPandoc renderHtml False = renderDirect ---------------------------------------------------------------------------- | Pandoc HTML Rendering (for lhs + markdown source) ------------------ +-- | Pandoc HTML Rendering (for lhs + markdown source) ------------------ -------------------------------------------------------------------------- + renderPandoc htmlFile srcFile css body- = do renderFn <- maybe renderDirect renderPandoc' <$> findExecutable "pandoc" + = do renderFn <- maybe renderDirect renderPandoc' <$> findExecutable "pandoc" renderFn htmlFile srcFile css body renderPandoc' pandocPath htmlFile srcFile css body = do _ <- writeFile mdFile $ pandocPreProc body- ec <- executeShellCommand "pandoc" cmd + ec <- executeShellCommand "pandoc" cmd writeFilesOrStrings htmlFile [Right (cssHTML css)] checkExitCode cmd ec- where mdFile = extFileName Mkdn srcFile + where mdFile = extFileName Mkdn srcFile cmd = pandocCmd pandocPath mdFile htmlFile pandocCmd pandocPath mdFile htmlFile- = printf "%s -f markdown -t html %s > %s" pandocPath mdFile htmlFile + = printf "%s -f markdown -t html %s > %s" pandocPath mdFile htmlFile -pandocPreProc = T.unpack - . strip beg code +pandocPreProc = T.unpack+ . strip beg code . strip end code- . strip beg spec - . strip end spec + . strip beg spec+ . strip end spec . T.pack- where + where beg, end, code, spec :: String beg = "begin" end = "end" code = "code"- spec = "spec" + spec = "spec" strip x y = T.replace (T.pack $ printf "\\%s{%s}" x y) T.empty- -- stripBcode = T.replace (T.pack "\\begin{code}") T.empty - -- stripEcode = T.replace (T.pack "\\end{code}") T.empty - -- stripBspec = T.replace (T.pack "\\begin{code}") T.empty - -- stripEspec = T.replace (T.pack "\\end{code}") T.empty + -- stripBcode = T.replace (T.pack "\\begin{code}") T.empty+ -- stripEcode = T.replace (T.pack "\\end{code}") T.empty+ -- stripBspec = T.replace (T.pack "\\begin{code}") T.empty+ -- stripEspec = T.replace (T.pack "\\end{code}") T.empty ---------------------------------------------------------------------------- | Direct HTML Rendering (for non-lhs/markdown source) ---------------- +-- | Direct HTML Rendering (for non-lhs/markdown source) ---------------- ------------------------------------------------------------------------- -- More or less taken from hscolour -renderDirect htmlFile srcFile css body +renderDirect htmlFile srcFile css body = writeFile htmlFile $! (top'n'tail full srcFile css $! body)- where full = True -- False -- TODO: command-line-option + where full = True -- False -- TODO: command-line-option --- | @top'n'tail True@ is used for standalone HTML, +-- | @top'n'tail True@ is used for standalone HTML, -- @top'n'tail False@ for embedded HTML top'n'tail True title css = (htmlHeader title css ++) . (++ htmlClose)@@ -195,7 +195,7 @@ -- | Building Annotation Maps ------------------------------------------------ ------------------------------------------------------------------------------ --- | This function converts our annotation information into that which +-- | This function converts our annotation information into that which -- is required by `Language.Haskell.Liquid.ACSS` to generate mouseover -- annotations. @@ -208,14 +208,14 @@ mkStatus _ = ACSS.Crash mkAnnMapErr (Unsafe ls) = mapMaybe cinfoErr ls-mkAnnMapErr (Crash ls _) = mapMaybe cinfoErr ls +mkAnnMapErr (Crash ls _) = mapMaybe cinfoErr ls mkAnnMapErr _ = []- + cinfoErr e = case pos e of RealSrcSpan l -> Just (srcSpanStartLoc l, srcSpanEndLoc l, showpp e) _ -> Nothing --- cinfoErr (Ci (RealSrcSpan l) e) = +-- cinfoErr (Ci (RealSrcSpan l) e) = -- cinfoErr _ = Nothing @@ -230,11 +230,11 @@ bindStr (x, v) = (maybe "_" (symbolString . shorten . symbol) x, render v) shorten = if shortNames cfg then dropModuleNames else id -closeAnnots :: AnnInfo (Annot SpecType) -> AnnInfo SpecType +closeAnnots :: AnnInfo (Annot SpecType) -> AnnInfo SpecType closeAnnots = closeA . filterA . collapseA -closeA a@(AI m) = cf <$> a - where +closeA a@(AI m) = cf <$> a+ where cf (AnnLoc l) = case m `mlookup` l of [(_, AnnUse t)] -> t [(_, AnnDef t)] -> t@@ -245,7 +245,7 @@ cf (AnnRDf t) = t filterA (AI m) = AI (M.filter ff m)- where + where ff [(_, AnnLoc l)] = l `M.member` m ff _ = True @@ -257,7 +257,7 @@ (_, _, x:_, _) -> [x] (_, _, _, x:_) -> [x] (_, _, _, _ ) -> [ ]- where + where rs = [x | x@(_, AnnRDf _) <- xas] ds = [x | x@(_, AnnDef _) <- xas] ls = [x | x@(_, AnnLoc _) <- xas]@@ -272,23 +272,23 @@ -- | The top-level function for tokenizing @-block annotations. Used to -- tokenize comments by ACSS.-tokAnnot s - = case trimLiquidAnnot s of +tokAnnot s+ = case trimLiquidAnnot s of Just (l, body, r) -> [(refToken, l)] ++ tokBody body ++ [(refToken, r)] Nothing -> [(Comment, s)] -trimLiquidAnnot ('{':'-':'@':ss) +trimLiquidAnnot ('{':'-':'@':ss) | drop (length ss - 3) ss == "@-}"- = Just ("{-@", take (length ss - 3) ss, "@-}") -trimLiquidAnnot _ + = Just (liquidBegin, take (length ss - 3) ss, liquidEnd)+trimLiquidAnnot _ = Nothing -tokBody s +tokBody s | isData s = tokenise s | isType s = tokenise s | isIncl s = tokenise s | isMeas s = tokenise s- | otherwise = tokeniseSpec s + | otherwise = tokeniseSpec s isMeas = spacePrefix "measure" isData = spacePrefix "data"@@ -298,20 +298,20 @@ spacePrefix str s@(c:cs) | isSpace c = spacePrefix str cs | otherwise = take (length str) s == str-spacePrefix _ _ = False +spacePrefix _ _ = False tokeniseSpec :: String -> [(TokenType, String)] tokeniseSpec str = {- traceShow ("tokeniseSpec: " ++ str) $ -} tokeniseSpec' str -tokeniseSpec' = tokAlt . chopAltDBG -- [('{', ':'), ('|', '}')] - where +tokeniseSpec' = tokAlt . chopAltDBG -- [('{', ':'), ('|', '}')]+ where tokAlt (s:ss) = tokenise s ++ tokAlt' ss tokAlt _ = [] tokAlt' (s:ss) = (refToken, s) : tokAlt ss tokAlt' _ = [] -chopAltDBG y = {- traceShow ("chopAlts: " ++ y) $ -} +chopAltDBG y = {- traceShow ("chopAlts: " ++ y) $ -} filter (/= "") $ concatMap (chopAlts [("{", ":"), ("|", "}")]) $ chopAlts [("<{", "}>"), ("{", "}")] y @@ -328,7 +328,7 @@ data Annot1 = A1 { ident :: String , ann :: String , row :: Int- , col :: Int + , col :: Int } ------------------------------------------------------------------------@@ -336,14 +336,14 @@ ------------------------------------------------------------------------ vimAnnot :: Config -> AnnInfo Doc -> String-vimAnnot cfg = L.intercalate "\n" . map vimBind . mkAnnMapBinders cfg +vimAnnot cfg = L.intercalate "\n" . map vimBind . mkAnnMapBinders cfg -vimBind (sp, (v, ann)) = printf "%d:%d-%d:%d::%s" l1 c1 l2 c2 (v ++ " :: " ++ show ann) +vimBind (sp, (v, ann)) = printf "%d:%d-%d:%d::%s" l1 c1 l2 c2 (v ++ " :: " ++ show ann) where l1 = srcSpanStartLine sp- c1 = srcSpanStartCol sp - l2 = srcSpanEndLine sp - c2 = srcSpanEndCol sp + c1 = srcSpanStartCol sp+ l2 = srcSpanEndLine sp+ c2 = srcSpanEndCol sp ------------------------------------------------------------------------ -- | JSON Instances ----------------------------------------------------@@ -355,7 +355,7 @@ toJSON ACSS.Error = "error" toJSON ACSS.Crash = "crash" -instance ToJSON Annot1 where +instance ToJSON Annot1 where toJSON (A1 i a r c) = object [ "ident" .= i , "ann" .= a , "row" .= r@@ -366,33 +366,33 @@ toJSON (L (l, c)) = object [ "line" .= toJSON l , "column" .= toJSON c ] -instance ToJSON AnnErrors where +instance ToJSON AnnErrors where toJSON errs = Array $ V.fromList $ fmap toJ errs- where - toJ (l,l',s) = object [ "start" .= toJSON l - , "stop" .= toJSON l' + where+ toJ (l,l',s) = object [ "start" .= toJSON l+ , "stop" .= toJSON l' , "message" .= toJSON s ] instance (Show k, ToJSON a) => ToJSON (Assoc k a) where toJSON (Asc kas) = object [ tshow k .= toJSON a | (k, a) <- M.toList kas ] where- tshow = T.pack . show + tshow = T.pack . show -instance ToJSON ACSS.AnnMap where +instance ToJSON ACSS.AnnMap where toJSON a = object [ "types" .= toJSON (annTypes a) , "errors" .= toJSON (ACSS.errors a) , "status" .= toJSON (ACSS.status a) ] -annTypes :: ACSS.AnnMap -> AnnTypes +annTypes :: ACSS.AnnMap -> AnnTypes annTypes a = grp [(l, c, ann1 l c x s) | (l, c, x, s) <- binders]- where - ann1 l c x s = A1 x s l c + where+ ann1 l c x s = A1 x s l c grp = L.foldl' (\m (r,c,x) -> ins r c x m) (Asc M.empty) binders = [(l, c, x, s) | (L (l, c), (x, s)) <- M.toList $ ACSS.types a] ins r c x (Asc m) = Asc (M.insert r (Asc (M.insert c x rm)) m)- where + where Asc rm = M.lookupDefault (Asc M.empty) r m @@ -401,7 +401,7 @@ -- | A Little Unit Test -------------------------------------------------------- -------------------------------------------------------------------------------- -_anns :: AnnTypes +_anns :: AnnTypes _anns = i [(5, i [( 14, A1 { ident = "foo" , ann = "int -> int" , row = 5@@ -409,20 +409,17 @@ }) ] )- ,(9, i [( 22, A1 { ident = "map" + ,(9, i [( 22, A1 { ident = "map" , ann = "(a -> b) -> [a] -> [b]" , row = 9 , col = 22 }) ,( 28, A1 { ident = "xs"- , ann = "[b]" - , row = 9 + , ann = "[b]"+ , row = 9 , col = 28 }) ]) ]- -i = Asc . M.fromList --+i = Asc . M.fromList
src/Language/Haskell/Liquid/Bare/Check.hs view
@@ -375,13 +375,9 @@ checkMBody' emb sort γ body = case body of E e -> checkSortFull γ (rTypeSort emb sort') e- P p -> checkSortFull γ psort p- R s p -> checkSortFull (insertSEnv s sty γ) psort p+ P p -> checkSortFull γ propSort p+ R s p -> checkSortFull (insertSEnv s sty γ) propSort p where- psort = FApp propFTyCon []+ -- psort = FApp propFTyCon [] sty = rTypeSortedReft emb sort'- sort' = fromRTypeRep $ trep' { ty_vars = [], ty_preds = [], ty_labels = []- , ty_binds = tail $ ty_binds trep'- , ty_args = tail $ ty_args trep'- , ty_refts = tail $ ty_refts trep' }- trep' = toRTypeRep sort+ sort' = ty_res $ toRTypeRep sort
src/Language/Haskell/Liquid/Bare/GhcSpec.hs view
@@ -54,6 +54,7 @@ import Language.Haskell.Liquid.Bare.Spec import Language.Haskell.Liquid.Bare.SymSort import Language.Haskell.Liquid.Bare.RefToLogic+import Language.Haskell.Liquid.Bare.Lookup (lookupGhcTyCon) ------------------------------------------------------------------ ---------- Top Level Output --------------------------------------@@ -130,7 +131,7 @@ >>= makeSpecDictionaries embs vars specs emptySpec :: Config -> GhcSpec-emptySpec cfg = SP [] [] [] [] [] [] [] [] [] mempty [] [] [] [] mempty mempty cfg mempty [] mempty mempty+emptySpec cfg = SP [] [] [] [] [] [] [] [] [] mempty [] [] [] [] mempty mempty mempty cfg mempty [] mempty mempty makeGhcSpec0 cfg defVars exports name sp@@ -178,6 +179,7 @@ texprs' <- mconcat <$> mapM (makeTExpr defVars . snd) specs lazies <- mkThing makeLazy lvars' <- mkThing makeLVar+ asize' <- S.fromList <$> makeASize hmeas <- mkThing makeHIMeas quals <- mconcat <$> mapM makeQualifiers specs let sigs = strengthenHaskellMeasures hmeas ++ tySigs sp@@ -189,6 +191,7 @@ , decr = decr' , texprs = texprs' , lvars = lvars'+ , autosize = asize' , lazy = lazies , tySigs = tx <$> sigs , asmSigs = tx <$> (asmSigs sp)@@ -196,7 +199,7 @@ } where mkThing mk = S.fromList . mconcat <$> sequence [ mk defVars s | (m, s) <- specs, m == name ]-+ makeASize = mapM lookupGhcTyCon [v | (m, s) <- specs, m == name, v <- S.toList (Ms.autosize s)] makeGhcSpecCHOP1 specs = do (tcs, dcs) <- mconcat <$> mapM makeConTypes specs@@ -224,7 +227,7 @@ name <- gets modName mapM_ (makeHaskellInlines cbs name) specs hmeans <- mapM (makeHaskellMeasures cbs name) specs- let measures = mconcat (measures':Ms.mkMSpec' dcSelectors:hmeans)+ let measures = mconcat (Ms.wiredInMeasures:measures':Ms.mkMSpec' dcSelectors:hmeans) let (cs, ms) = makeMeasureSpec' measures let cms = makeClassMeasureSpec measures let cms' = [ (x, Loc l l' $ cSort t) | (Loc l l' x, t) <- cms ]
src/Language/Haskell/Liquid/Bare/Lookup.hs view
@@ -22,7 +22,6 @@ import PrelNames (fromIntegerName, smallIntegerName, integerTyConName) import RdrName (setRdrNameSpace) import SrcLoc (SrcSpan, GenLocated(L))-import TcRnDriver (tcRnLookupRdrName) import TcEnv import TyCon import TysWiredIn@@ -39,7 +38,7 @@ import Language.Fixpoint.Names (hpropConName, isPrefixOfSym, lengthSym, propConName, symbolString) import Language.Fixpoint.Types (Symbol, Symbolic(..)) -import Language.Haskell.Liquid.GhcMisc (lookupRdrName, sourcePosSrcSpan)+import Language.Haskell.Liquid.GhcMisc (lookupRdrName, sourcePosSrcSpan, tcRnLookupRdrName) import Language.Haskell.Liquid.Types import Language.Haskell.Liquid.WiredIn @@ -105,7 +104,7 @@ res' <- lookupRdrName env modName (setRdrNameSpace rn tcName) return $ catMaybes [res, res'] | otherwise- = do L _ rn <- hscParseIdentifier env $ symbolString s+ = do rn <- hscParseIdentifier env $ symbolString s (_, lookupres) <- tcRnLookupRdrName env rn case lookupres of Just ns -> return ns
src/Language/Haskell/Liquid/Bare/Measure.hs view
@@ -124,7 +124,7 @@ binders (Rec xes) = fst <$> xes coreToDef' x v def = case (runToLogic lmap mkError $ coreToDef x v def) of- Left l -> return l+ Left l -> return l Right e -> throwError e mkError :: String -> Error
src/Language/Haskell/Liquid/Bare/SymSort.hs view
@@ -29,8 +29,8 @@ (rargs, rrest) = splitAt (length pvs) rs r' = L.foldl' go r rrest go r (RPropP _ r') = r' `meet` r+ go r (RProp _ _ ) = r -- is this correct? go _ (RHProp _ _ ) = errorstar "TODO:EFFECTS:addSymSort"- go _ _ = errorstar "YUCKER" -- r addSymSort _ _ t = t
+ src/Language/Haskell/Liquid/Cabal.hs view
@@ -0,0 +1,254 @@+-- | This module contains a single function that extracts the cabal information about a target file, if any.+-- This information can be used to extend the source-directories that are searched to find modules that are+-- imported by the target file.++{-@ LIQUID "--no-termination" @-}+{-@ LIQUID "--diff" @-}+{-@ LIQUID "--short-names" @-}+{-@ LIQUID "--cabaldir" @-}++{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE CPP #-}++module Language.Haskell.Liquid.Cabal (cabalInfo, Info(..)) where++import Control.Applicative ((<$>))+import Data.Bits ( shiftL, shiftR, xor )+import Data.Char ( ord )+import Data.List+import Data.Maybe+import qualified Data.Text as T+import qualified Data.Text.IO as TIO+import Data.Word ( Word32 )+import Distribution.Compiler+import Distribution.Package+import Distribution.PackageDescription+import Distribution.PackageDescription.Configuration+import Distribution.PackageDescription.Parse+import Distribution.Simple.BuildPaths+import Distribution.System+import Distribution.Verbosity+import Language.Haskell.Extension+import Numeric ( showHex )+import System.Console.CmdArgs+import System.Environment+import System.Exit+import System.FilePath+import System.Directory+import System.Info+import Language.Haskell.Liquid.Errors++-- To use in ghci:+-- exitWithPanic = undefined++-----------------------------------------------------------------------------------------------+cabalInfo :: FilePath -> IO (Maybe Info)+-----------------------------------------------------------------------------------------------+cabalInfo f = do+ f <- canonicalizePath f+ cf <- findCabalFile f+ case cf of+ Just f -> Just <$> processCabalFile f+ Nothing -> return Nothing++processCabalFile :: FilePath -> IO Info+processCabalFile f = do+ let sandboxDir = sandboxBuildDir (takeDirectory f </> ".cabal-sandbox")+ b <- doesDirectoryExist sandboxDir+ let distDir = if b then sandboxDir else "dist"+ i <- cabalConfiguration f distDir <$> readPackageDescription silent f+ i <- addPackageDbs =<< canonicalizePaths i+ whenLoud $ putStrLn $ "Cabal Info: " ++ show i+ return i++-----------------------------------------------------------------------------------------------+findCabalFile :: FilePath -> IO (Maybe FilePath)+-----------------------------------------------------------------------------------------------+findCabalFile = fmap listToMaybe . findInPath isCabal+ where+ isCabal = (".cabal" ==) . takeExtension++findInPath :: (FilePath -> Bool) -> FilePath -> IO [FilePath]+findInPath p f = concat <$> mapM (findInDir p) (ancestorDirs f)++ancestorDirs :: FilePath -> [FilePath]+ancestorDirs = go . takeDirectory+ where+ go f+ | f == f' = [f]+ | otherwise = f : go f'+ where+ f' = takeDirectory f++findInDir :: (FilePath -> Bool) -> FilePath -> IO [FilePath]+findInDir p dir = do+ files <- getDirectoryContents dir+ return [ dir </> f | f <- files, p f ]++-----------------------------------------------------------------------------------------------+++-- INVARIANT: all FilePaths must be absolute+data Info = Info { cabalFile :: FilePath+ , buildDirs :: [FilePath]+ , sourceDirs :: [FilePath]+ , exts :: [Extension]+ , otherOptions :: [String]+ , packageDbs :: [String]+ , packageDeps :: [String]+ , macroPath :: FilePath+ } deriving (Show)+++addPackageDbs :: Info -> IO Info+addPackageDbs i = maybe i addDB <$> getSandboxDB i+ where+ addDB db = i { packageDbs = T.unpack db : packageDbs i}++getSandboxDB :: Info -> IO (Maybe T.Text)+getSandboxDB i = do+ tM <- maybeReadFile $ sandBoxFile i+ case tM of+ Just t -> return $ Just $ parsePackageDb t+ Nothing -> return Nothing+ -- fmap <$> maybeReadFile (sandBoxFile i)++parsePackageDb :: T.Text -> T.Text+parsePackageDb t = case dbs of+ [db] -> T.strip db+ _ -> exitWithPanic $ "Malformed package-db in sandbox: " ++ show dbs+ where+ dbs = mapMaybe (T.stripPrefix pfx) $ T.lines t+ pfx = "package-db:"+ -- /Users/rjhala/research/liquid/liquidhaskell/.cabal-sandbox/x86_64-osx-ghc-7.8.3-packages.conf.d++maybeReadFile :: FilePath -> IO (Maybe T.Text)+maybeReadFile f = do+ b <- doesFileExist f+ if b then Just <$> TIO.readFile f+ else return Nothing++++sandBoxFile :: Info -> FilePath+sandBoxFile i = dir </> "cabal.sandbox.config"+ where+ dir = takeDirectory $ cabalFile i+++dumpPackageDescription :: PackageDescription -> FilePath -> FilePath -> Info+dumpPackageDescription pkgDesc file distDir = Info {+ cabalFile = file+ , buildDirs = nub (map normalise buildDirs)+ , sourceDirs = nub (normalise <$> getSourceDirectories buildInfo dir)+ , exts = nub (concatMap usedExtensions buildInfo)+ , otherOptions = nub (filter isAllowedOption (concatMap (hcOptions GHC) buildInfo))+ , packageDbs = []+ , packageDeps = nub [ unPackName n | Dependency n _ <- buildDepends pkgDesc, n /= thisPackage ]+ , macroPath = macroPath+ }+ where+ (buildDirs, macroPath) = getBuildDirectories pkgDesc distDir+ buildInfo = allBuildInfo pkgDesc+ dir = dropFileName file+ thisPackage = (pkgName . package) pkgDesc++unPackName :: PackageName -> String+unPackName (PackageName s) = s+++getSourceDirectories :: [BuildInfo] -> FilePath -> [String]+getSourceDirectories buildInfo cabalDir = map (cabalDir </>) (concatMap hsSourceDirs buildInfo)++allowedOptions :: [String]+allowedOptions =+ ["-W"+ ,"-w"+ ,"-Wall"+ ,"-fglasgow-exts"+ ,"-fpackage-trust"+ ,"-fhelpful-errors"+ ,"-F"+ ,"-cpp"]++allowedOptionPrefixes :: [String]+allowedOptionPrefixes =+ ["-fwarn-"+ ,"-fno-warn-"+ ,"-fcontext-stack="+ ,"-firrefutable-tuples"+ ,"-D"+ ,"-U"+ ,"-I"+ ,"-fplugin="+ ,"-fplugin-opt="+ ,"-pgm"+ ,"-opt"]+++getBuildDirectories :: PackageDescription -> FilePath -> ([String], FilePath)+getBuildDirectories pkgDesc distDir =+ (case library pkgDesc of+ Just _ -> buildDir : buildDirs+ Nothing -> buildDirs+ ,autogenDir </> cppHeaderName)+ where+ buildDir = distDir </> "build"+ autogenDir = buildDir </> "autogen"+ execBuildDir e = buildDir </> exeName e </> (exeName e ++ "-tmp")+ buildDirs = autogenDir : map execBuildDir (executables pkgDesc)+++-- See https://github.com/haskell/cabal/blob/master/cabal-install/Distribution/Client/Sandbox.hs#L137-L158+sandboxBuildDir :: FilePath -> FilePath+sandboxBuildDir sandboxDir = "dist/dist-sandbox-" ++ showHex sandboxDirHash ""+ where+ sandboxDirHash = jenkins sandboxDir++ -- See http://en.wikipedia.org/wiki/Jenkins_hash_function+ jenkins :: String -> Word32+ jenkins str = loop_finish $ foldl' loop 0 str+ where+ loop :: Word32 -> Char -> Word32+ loop hash key_i' = hash'''+ where+ key_i = toEnum . ord $ key_i'+ hash' = hash + key_i+ hash'' = hash' + (shiftL hash' 10)+ hash''' = hash'' `xor` (shiftR hash'' 6)++ loop_finish :: Word32 -> Word32+ loop_finish hash = hash'''+ where+ hash' = hash + (shiftL hash 3)+ hash'' = hash' `xor` (shiftR hash' 11)+ hash''' = hash'' + (shiftL hash'' 15)++isAllowedOption :: String -> Bool+isAllowedOption opt = elem opt allowedOptions || any (`isPrefixOf` opt) allowedOptionPrefixes++buildCompiler :: CompilerId+buildCompiler = CompilerId buildCompilerFlavor compilerVersion++cabalConfiguration :: FilePath -> FilePath -> GenericPackageDescription -> Info+cabalConfiguration cabalFile distDir desc =+ case finalizePackageDescription []+ (const True)+ buildPlatform+#if MIN_VERSION_Cabal(1,22,0)+ (unknownCompilerInfo buildCompiler NoAbiTag)+#else+ buildCompiler+#endif+ []+ desc of+ Right (pkgDesc,_) -> dumpPackageDescription pkgDesc cabalFile distDir+ Left e -> exitWithPanic $ "Issue with package configuration\n" ++ show e++canonicalizePaths :: Info -> IO Info+canonicalizePaths i = do+ buildDirs <- mapM canonicalizePath (buildDirs i)+ macroPath <- canonicalizePath (macroPath i)+ return (i { buildDirs = buildDirs, macroPath = macroPath })
src/Language/Haskell/Liquid/CmdLine.hs view
@@ -5,6 +5,9 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# OPTIONS_GHC -fno-cse #-} +{-@ LIQUID "--cabaldir" @-}+{-@ LIQUID "--diff" @-}+ -- | This module contains all the code needed to output the result which -- is either: `SAFE` or `WARNING` with some reasonable error message when -- something goes wrong. All forms of errors/exceptions should go through@@ -18,6 +21,7 @@ -- * Update Configuration With Pragma , withPragmas+ , withCabal -- * Exit Function , exitWithResult@@ -37,7 +41,7 @@ import System.Console.CmdArgs.Implicit hiding (Loud) import System.Console.CmdArgs.Text -import Data.List (nub)+import Data.List (intercalate, nub) import Data.Monoid import System.FilePath (dropFileName, isAbsolute,@@ -47,12 +51,14 @@ import Language.Fixpoint.Files import Language.Fixpoint.Misc import Language.Fixpoint.Names (dropModuleNames)-import Language.Fixpoint.Types+import Language.Fixpoint.Types hiding (Result) import Language.Haskell.Liquid.Annotate import Language.Haskell.Liquid.GhcMisc import Language.Haskell.Liquid.Misc import Language.Haskell.Liquid.PrettyPrint import Language.Haskell.Liquid.Types hiding (config, name, typ)+import Language.Haskell.Liquid.Errors+import Language.Haskell.Liquid.Cabal import Text.Parsec.Pos (newPos) import Text.PrettyPrint.HughesPJ hiding (Mode)@@ -137,6 +143,10 @@ = def &= name "short-errors" &= help "Don't show long error messages, just line numbers." + , cabalDir+ = def &= name "cabal-dir"+ &= help "Find and use .cabal to add paths to sources for imported files"+ , ghcOptions = def &= name "ghc-option" &= typ "OPTION"@@ -147,7 +157,6 @@ &= typ "OPTION" &= help "Tell GHC to compile and link against these files" - } &= verbosity &= program "liquid" &= help "Refinement Types for Haskell"@@ -159,18 +168,19 @@ ] getOpts :: IO Config-getOpts = do cfg0 <- envCfg- cfg1 <- mkOpts =<< cmdArgsRun' config- pwd <- getCurrentDirectory- cfg <- canonicalizePaths (fixCfg $ mconcat [cfg0, cfg1]) pwd- whenNormal $ putStrLn copyright- case smtsolver cfg of- Just _ -> return cfg- Nothing -> do smts <- mapM find [Z3, Cvc4, Mathsat]- case catMaybes smts of- (s:_) -> return (cfg {smtsolver = Just s})- _ -> do putStrLn "ERROR: LiquidHaskell requires z3, cvc4, or mathsat to be installed."- exitWith $ ExitFailure 2+getOpts = do+ cfg0 <- envCfg+ cfg1 <- mkOpts =<< cmdArgsRun' config+ cfg <- fixConfig $ mconcat [cfg0, cfg1]+ whenNormal $ putStrLn copyright+ case smtsolver cfg of+ Just _ -> return cfg+ Nothing -> do smts <- mapM findSmtSolver [Z3, Cvc4, Mathsat]+ case catMaybes smts of+ (s:_) -> return (cfg {smtsolver = Just s})+ _ -> exitWithPanic noSmtError+ where+ noSmtError = "LiquidHaskell requires an SMT Solver, i.e. z3, cvc4, or mathsat to be installed." cmdArgsRun' :: Mode (CmdArgs a) -> IO a cmdArgsRun' mode@@ -180,31 +190,37 @@ putStrLn (help err) >> exitFailure Right args -> cmdArgsApply args- where- help err- = showText defaultWrap $ helpText [err] HelpFormatDefault mode+ where+ help err = showText defaultWrap $ helpText [err] HelpFormatDefault mode -find :: SMTSolver -> IO (Maybe SMTSolver)-find smt = maybe Nothing (const $ Just smt) <$> findExecutable (show smt)+findSmtSolver :: SMTSolver -> IO (Maybe SMTSolver)+findSmtSolver smt = maybe Nothing (const $ Just smt) <$> findExecutable (show smt) +fixConfig :: Config -> IO Config+fixConfig cfg = do+ pwd <- getCurrentDirectory+ cfg <- canonicalizePaths pwd cfg+ -- cfg <- withCabal cfg+ return $ fixDiffCheck cfg+ -- | Attempt to canonicalize all `FilePath's in the `Config' so we don't have -- to worry about relative paths.-canonicalizePaths :: Config -> FilePath -> IO Config-canonicalizePaths cfg tgt- = do -- st <- getFileStatus tgt- tgt <- canonicalizePath tgt- isdir <- doesDirectoryExist tgt- let canonicalize f- | isAbsolute f = return f- | isdir = canonicalizePath (tgt </> f)- -- | isDirectory st = canonicalizePath (tgt </> f)- | otherwise = canonicalizePath (takeDirectory tgt </> f)- is <- mapM canonicalize $ idirs cfg- cs <- mapM canonicalize $ cFiles cfg- return $ cfg { idirs = is, cFiles = cs }+canonicalizePaths :: FilePath -> Config -> IO Config+canonicalizePaths pwd cfg = do+ tgt <- canonicalizePath pwd+ isdir <- doesDirectoryExist tgt+ is <- mapM (canonicalize tgt isdir) $ idirs cfg+ cs <- mapM (canonicalize tgt isdir) $ cFiles cfg+ return $ cfg { idirs = is, cFiles = cs } +canonicalize :: FilePath -> Bool -> FilePath -> IO FilePath+canonicalize tgt isdir f+ | isAbsolute f = return f+ | isdir = canonicalizePath (tgt </> f)+ | otherwise = canonicalizePath (takeDirectory tgt </> f) -fixCfg cfg = cfg { diffcheck = diffcheck cfg && not (fullcheck cfg) }+fixDiffCheck :: Config -> Config+fixDiffCheck cfg = cfg { diffcheck = diffcheck cfg && not (fullcheck cfg) } envCfg = do so <- lookupEnv "LIQUIDHASKELL_OPTS" case so of@@ -219,7 +235,6 @@ mkOpts :: Config -> IO Config mkOpts cfg = do let files' = sortNub $ files cfg- -- idirs' <- if null (idirs cfg) then single <$> getIncludeDir else return (idirs cfg) id0 <- getIncludeDir return $ cfg { files = files' } { idirs = (dropFileName <$> files') ++ [id0 </> gHC_VERSION, id0] ++ idirs cfg }@@ -232,8 +247,7 @@ --------------------------------------------------------------------------------------- withPragmas :: Config -> FilePath -> [Located String] -> IO Config ----------------------------------------------------------------------------------------withPragmas cfg fp ps- = foldM withPragma cfg ps >>= flip canonicalizePaths fp+withPragmas cfg fp ps = foldM withPragma cfg ps >>= canonicalizePaths fp withPragma :: Config -> Located String -> IO Config withPragma c s = (c `mappend`) <$> parsePragma s@@ -242,12 +256,41 @@ parsePragma s = withArgs [val s] $ cmdArgsRun config ---------------------------------------------------------------------------------------+withCabal :: Config -> IO Config+---------------------------------------------------------------------------------------+withCabal cfg+ | cabalDir cfg = withCabal' cfg+ | otherwise = return cfg++withCabal' cfg = do+ whenLoud $ putStrLn $ "addCabalDirs: " ++ tgt+ io <- cabalInfo tgt+ case io of+ Just i -> return $ fixCabalDirs' cfg i+ Nothing -> exitWithPanic "Cannot find .cabal information!"+ where+ tgt = case files cfg of+ f:_ -> f+ _ -> exitWithPanic "Please provide a target file to verify."+++fixCabalDirs' :: Config -> Info -> Config+fixCabalDirs' cfg i = cfg { idirs = nub $ idirs cfg ++ sourceDirs i ++ buildDirs i }+ { ghcOptions = ghcOptions cfg ++ dbOpts ++ pkOpts+ ++ ["-optP-include", "-optP" ++ macroPath i]}+ where+ dbOpts = ["-package-db " ++ db | db <- packageDbs i]+ pkOpts = ["-package " ++ n | n <- packageDeps i] -- SPEED HIT for smaller benchmarks++++--------------------------------------------------------------------------------------- -- | Monoid instances for updating options --------------------------------------------------------------------------------------- instance Monoid Config where- mempty = Config def def def def def def def def def def def def def def def def 2 def def def def def+ mempty = Config def def def def def def def def def def def def def def def def 2 def def def def def def mappend c1 c2 = Config { files = sortNub $ files c1 ++ files c2 , idirs = sortNub $ idirs c1 ++ idirs c2 , fullcheck = fullcheck c1 || fullcheck c2@@ -268,6 +311,7 @@ , smtsolver = smtsolver c1 `mappend` smtsolver c2 , shortNames = shortNames c1 || shortNames c2 , shortErrors = shortErrors c1 || shortErrors c2+ , cabalDir = cabalDir c1 || cabalDir c2 , ghcOptions = ghcOptions c1 ++ ghcOptions c2 , cFiles = cFiles c1 ++ cFiles c2 }@@ -296,7 +340,6 @@ return $ out { o_result = r } where r = o_result out `addErrors` o_errors out- writeCheckVars Nothing = return ()
src/Language/Haskell/Liquid/Constraint/Generate.hs view
@@ -7,7 +7,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TupleSections #-}-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE DeriveFunctor #-}@@ -37,13 +36,14 @@ import Class (Class, className) import Var import Id+import IdInfo import Name import NameSet import Text.PrettyPrint.HughesPJ hiding (first) import Control.Monad.State -import Control.Applicative ((<$>))+import Control.Applicative ((<$>), (<*>)) import Data.Monoid (mconcat, mempty, mappend) import Data.Maybe (fromMaybe, catMaybes, fromJust, isJust)@@ -66,6 +66,7 @@ import qualified Language.Fixpoint.Types as F +import Language.Haskell.Liquid.Names import Language.Haskell.Liquid.Dictionaries import Language.Haskell.Liquid.Variance import Language.Haskell.Liquid.Types hiding (binds, Loc, loc, freeTyVars, Def)@@ -85,6 +86,8 @@ import Language.Haskell.Liquid.Constraint.Types import Language.Haskell.Liquid.Constraint.Constraint +-- import Debug.Trace (trace)+ ----------------------------------------------------------------------- ------------- Constraint Generation: Toplevel ------------------------- -----------------------------------------------------------------------@@ -100,9 +103,7 @@ = do γ <- initEnv info sflag <- scheck <$> get tflag <- trustghc <$> get- let trustBinding x = if tflag- then (x `elem` (derVars info) || isInternal x)- else False+ let trustBinding x = tflag && (x `elem` derVars info || isInternal x) foldM_ (consCBTop trustBinding) γ (cbs info) hcs <- hsCs <$> get hws <- hsWfs <$> get@@ -114,7 +115,7 @@ let hcs' = if sflag then subsS smap hcs else hcs fcs <- concat <$> mapM splitC (subsS smap hcs') fws <- concat <$> mapM splitW hws- let annot' = if sflag then (\t -> subsS smap t) <$> annot else annot+ let annot' = if sflag then subsS smap <$> annot else annot modify $ \st -> st { fixCs = fcs } { fixWfs = fws } {annotMap = annot'} ------------------------------------------------------------------------------------@@ -123,31 +124,76 @@ initEnv info = do let tce = tcEmbeds sp let fVars = impVars info- let dcs = filter isConLikeId (snd <$> freeSyms sp)+ let dcs = filter isConLikeId ((snd <$> freeSyms sp))+ let dcs' = filter isConLikeId fVars defaults <- forM fVars $ \x -> liftM (x,) (trueTy $ varType x) dcsty <- forM dcs $ \x -> liftM (x,) (trueTy $ varType x)+ dcsty' <- forM dcs' $ \x -> liftM (x,) (trueTy $ varType x) (hs,f0) <- refreshHoles $ grty info -- asserted refinements (for defined vars) f0'' <- refreshArgs' =<< grtyTop info -- default TOP reftype (for exported vars without spec) let f0' = if notruetypes $ config sp then [] else f0''- f1 <- refreshArgs' $ defaults -- default TOP reftype (for all vars)- f1' <- refreshArgs' $ makedcs dcsty -- default TOP reftype (for data cons)+ f1 <- refreshArgs' defaults -- default TOP reftype (for all vars)+ f1' <- refreshArgs' $ makedcs dcsty f2 <- refreshArgs' $ assm info -- assumed refinements (for imported vars) f3 <- refreshArgs' $ vals asmSigs sp -- assumed refinedments (with `assume`)- f4 <- refreshArgs' $ makedcs $ vals ctors sp -- constructor refinements (for measures)+ f40 <- refreshArgs' $ vals ctors sp -- constructor refinements (for measures)+ (invs1, f41) <- mapSndM refreshArgs' $ makeAutoDecrDataCons dcsty (autosize sp) dcs+ (invs2, f42) <- mapSndM refreshArgs' $ makeAutoDecrDataCons dcsty' (autosize sp) dcs'+ let f4 = mergeDataConTypes f40 (f41 ++ f42) sflag <- scheck <$> get let senv = if sflag then f2 else [] let tx = mapFst F.symbol . addRInv ialias . strataUnify senv . predsUnify sp let bs = (tx <$> ) <$> [f0 ++ f0', f1 ++ f1', f2, f3, f4] lts <- lits <$> get let tcb = mapSnd (rTypeSort tce) <$> concat bs- let γ0 = measEnv sp (head bs) (cbs info) (tcb ++ lts) (bs!!3) hs+ let γ0 = measEnv sp (head bs) (cbs info) (tcb ++ lts) (bs!!3) hs (invs1 ++ invs2) foldM (++=) γ0 [("initEnv", x, y) | (x, y) <- concat $ tail bs] where sp = spec info ialias = mkRTyConIAl $ ialiases sp vals f = map (mapSnd val) . f+ mapSndM f (x,y) = (x,) <$> f y makedcs = map strengthenDataConType +makeAutoDecrDataCons dcts specenv dcs+ = (simplify invs, tys)+ where+ (invs, tys) = unzip $ concatMap go tycons+ tycons = L.nub $ catMaybes $ map idTyCon dcs++ go tycon+ | S.member tycon specenv = zipWith (makeSizedDataCons dcts) (tyConDataCons tycon) [0..]+ go _+ = []+ idTyCon x = dataConTyCon <$> case idDetails x of {DataConWorkId d -> Just d; DataConWrapId d -> Just d; _ -> Nothing}++ simplify invs = dummyLoc . (`strengthen` invariant) . fmap (\_ -> mempty) <$> L.nub invs+ invariant = U (F.Reft (F.vv_, F.Refa $ F.PAtom F.Ge (lenOf F.vv_) (F.ECon $ F.I 0)) ) mempty mempty++lenOf x = F.EApp lenLocSymbol [F.EVar x]++makeSizedDataCons dcts x' n = (toRSort $ ty_res trep, (x, fromRTypeRep trep{ty_res = tres}))+ where+ x = dataConWorkId x'+ t = fromMaybe (errorstar "makeSizedDataCons: this should never happen") $ L.lookup x dcts+ trep = toRTypeRep t+ tres = ty_res trep `strengthen` U (F.Reft (F.vv_, F.Refa+ $ F.PAtom F.Eq (lenOf F.vv_) computelen)) mempty mempty++ recarguments = filter (\(t,_) -> (toRSort t == toRSort tres)) (zip (ty_args trep) (ty_binds trep))+ computelen = foldr (F.EBin F.Plus) (F.ECon $ F.I n) (lenOf . snd <$> recarguments)+++mergeDataConTypes xts yts = merge (L.sortBy f xts) (L.sortBy f yts)+ where+ f (x,_) (y,_) = compare x y+ merge [] ys = ys+ merge xs [] = xs+ merge (xt@(x, tx):xs) (yt@(y, ty):ys)+ | x == y = (x, tx `F.meet` ty):merge xs ys+ | x < y = xt:merge xs (yt:ys)+ | otherwise = yt:merge (xt:xs) ys+ refreshHoles vts = first catMaybes . unzip . map extract <$> mapM refreshHoles' vts refreshHoles' (x,t) | noHoles t = return (Nothing,x,t)@@ -162,7 +208,7 @@ strataUnify :: [(Var, SpecType)] -> (Var, SpecType) -> (Var, SpecType) strataUnify senv (x, t) = (x, maybe t (mappend t) pt) where- pt = (fmap (\(U _ _ l) -> U mempty mempty l)) <$> L.lookup x senv+ pt = fmap (\(U _ _ l) -> U mempty mempty l) <$> L.lookup x senv -- | TODO: All this *should* happen inside @Bare@ but appears@@ -182,14 +228,14 @@ --------------------------------------------------------------------------------------- --------------------------------------------------------------------------------------- -measEnv sp xts cbs lts asms hs+measEnv sp xts cbs lts asms hs autosizes = CGE { loc = noSrcSpan , renv = fromListREnv $ second val <$> meas sp , syenv = F.fromListSEnv $ freeSyms sp , fenv = initFEnv $ lts ++ (second (rTypeSort tce . val) <$> meas sp) , denv = dicts sp , recs = S.empty- , invs = mkRTyConInv $ invariants sp+ , invs = mkRTyConInv $ (invariants sp ++ autosizes) , ial = mkRTyConIAl $ ialiases sp , grtys = fromListREnv xts , assms = fromListREnv asms@@ -204,21 +250,20 @@ where tce = tcEmbeds sp -assm = assm_grty impVars-grty = assm_grty defVars+assm = assmGrty impVars+grty = assmGrty defVars -assm_grty f info = [ (x, val t) | (x, t) <- sigs, x `S.member` xs ]+assmGrty f info = [ (x, val t) | (x, t) <- sigs, x `S.member` xs ] where- xs = S.fromList $ f info- sigs = tySigs $ spec info+ xs = S.fromList $ f info+ sigs = tySigs $ spec info -grtyTop info = forM topVs $ \v -> (v,) <$> (trueTy $ varType v) -- val $ varSpecType v) | v <- defVars info, isTop v]+grtyTop info = forM topVs $ \v -> (v,) <$> trueTy (varType v) where topVs = filter isTop $ defVars info isTop v = isExportedId v && not (v `S.member` sigVs) isExportedId = flip elemNameSet (exports $ spec info) . getName- sigVs = S.fromList $ [v | (v,_) <- (tySigs $ spec info)- ++ (asmSigs $ spec info)]+ sigVs = S.fromList [v | (v,_) <- tySigs (spec info) ++ asmSigs (spec info)] ------------------------------------------------------------------------@@ -228,7 +273,7 @@ getTag :: CGEnv -> F.Tag-getTag γ = maybe Tg.defaultTag (`Tg.getTag` (tgEnv γ)) (tgKey γ)+getTag γ = maybe Tg.defaultTag (`Tg.getTag` tgEnv γ) (tgKey γ) setLoc :: CGEnv -> SrcSpan -> CGEnv γ `setLoc` src@@ -289,8 +334,8 @@ splitW (WfC γ t@(RApp _ ts rs _)) = do ws <- bsplitW γ t γ' <- γ `extendEnvWithVV` t- ws' <- concat <$> mapM splitW (map (WfC γ') ts)- ws'' <- concat <$> mapM (rsplitW γ) rs+ ws' <- concat <$> mapM (splitW . WfC γ') ts+ ws'' <- concat <$> mapM (rsplitW γ) rs return $ ws ++ ws' ++ ws'' splitW (WfC γ (RAllE x tx t))@@ -317,7 +362,7 @@ = errorstar "TODO: EFFECTS" bsplitW :: CGEnv -> SpecType -> CG [FixWfC]-bsplitW γ t = pruneRefs <$> get >>= return . bsplitW' γ t+bsplitW γ t = bsplitW' γ t . pruneRefs <$> get bsplitW' γ t pflag | F.isNonTrivial r' = [F.wfC (fe_binds $ fenv γ) r' Nothing ci]@@ -390,15 +435,16 @@ = return [] -splitS (SubC γ t1@(RApp _ _ _ _) t2@(RApp _ _ _ _))+splitS (SubC γ t1@(RApp {}) t2@(RApp {})) = do (t1',t2') <- unifyVV t1 t2 cs <- bsplitS t1' t2' γ' <- γ `extendEnvWithVV` t1' let RApp c t1s r1s _ = t1' let RApp _ t2s r2s _ = t2'+ let isapplied = tyConArity (rtc_tc c) == length t1s let tyInfo = rtc_info c- csvar <- splitsSWithVariance γ' t1s t2s $ varianceTyArgs tyInfo- csvar' <- rsplitsSWithVariance γ' r1s r2s $ variancePsArgs tyInfo+ csvar <- splitsSWithVariance γ' t1s t2s $ varianceTyArgs tyInfo+ csvar' <- rsplitsSWithVariance isapplied γ' r1s r2s $ variancePsArgs tyInfo return $ cs ++ csvar ++ csvar' splitS (SubC _ t1@(RVar a1 _) t2@(RVar a2 _))@@ -406,7 +452,7 @@ = bsplitS t1 t2 splitS (SubC _ t1 t2)- = errorstar $ "(Another Broken Test!!!) splitS unexpected: " ++ showpp t1 ++ "\n\n" ++ showpp t2+ = errorstar $ "(Another Broken Test1!!!) splitS unexpected: " ++ showpp t1 ++ "\n\n" ++ showpp t2 splitS (SubR _ _ _) = return []@@ -414,7 +460,10 @@ splitsSWithVariance γ t1s t2s variants = concatMapM (\(t1, t2, v) -> splitfWithVariance (\s1 s2 -> splitS (SubC γ s1 s2)) t1 t2 v) (zip3 t1s t2s variants) -rsplitsSWithVariance γ t1s t2s variants+rsplitsSWithVariance False _ _ _ _ + = return [] ++rsplitsSWithVariance _ γ t1s t2s variants = concatMapM (\(t1, t2, v) -> splitfWithVariance (rsplitS γ) t1 t2 v) (zip3 t1s t2s variants) bsplitS t1 t2@@ -445,26 +494,30 @@ splitC (SubC γ' t1 t2) splitC (SubC γ t1 (REx x tx t2))- = do γ' <- (γ, "addExBind 1") += (x, forallExprRefType γ tx)- splitC (SubC γ' t1 t2)+ = do y <- fresh + γ' <- (γ, "addExBind 1") += (y, forallExprRefType γ tx)+ splitC (SubC γ' t1 (F.subst1 t2 (x, F.EVar y))) -- existential at the left hand side is treated like forall splitC (SubC γ (REx x tx t1) t2) = do -- let tx' = traceShow ("splitC: " ++ showpp z) tx- γ' <- (γ, "addExBind 1") += (x, forallExprRefType γ tx)- splitC (SubC γ' t1 t2)+ y <- fresh + γ' <- (γ, "addExBind 2") += (y, forallExprRefType γ tx)+ splitC (SubC γ' (F.subst1 t1 (x, F.EVar y)) t2) splitC (SubC γ (RAllE x tx t1) (RAllE x2 _ t2)) | x == x2- = do γ' <- (γ, "addExBind 0") += (x, forallExprRefType γ tx)+ = do γ' <- (γ, "addAllBind 0") += (x, forallExprRefType γ tx) splitC (SubC γ' t1 t2) splitC (SubC γ (RAllE x tx t1) t2)- = do γ' <- (γ, "addExBind 2") += (x, forallExprRefType γ tx)- splitC (SubC γ' t1 t2)+ = do y <- fresh + γ' <- (γ, "addAABind 1") += (y, forallExprRefType γ tx)+ splitC (SubC γ' (t1 `F.subst1` (x, F.EVar y)) t2) splitC (SubC γ t1 (RAllE x tx t2))- = do γ' <- (γ, "addExBind 2") += (x, forallExprRefType γ tx)- splitC (SubC γ' t1 t2)+ = do y <- fresh + γ' <- (γ, "addAllBind 2") += (y, forallExprRefType γ tx)+ splitC (SubC γ' t1 (F.subst1 t2 (x, F.EVar y))) splitC (SubC γ (RRTy env _ OCons t1) t2) = do γ' <- foldM (\γ (x, t) -> γ `addSEnv` ("splitS", x,t)) γ xts@@ -521,9 +574,10 @@ γ' <- γ `extendEnvWithVV` t1' let RApp c t1s r1s _ = t1' let RApp _ t2s r2s _ = t2'+ let isapplied = tyConArity (rtc_tc c) == length t1s let tyInfo = rtc_info c- csvar <- splitsCWithVariance γ' t1s t2s $ varianceTyArgs tyInfo- csvar' <- rsplitsCWithVariance γ' r1s r2s $ variancePsArgs tyInfo+ csvar <- splitsCWithVariance γ' t1s t2s $ varianceTyArgs tyInfo+ csvar' <- rsplitsCWithVariance isapplied γ' r1s r2s $ variancePsArgs tyInfo return $ cs ++ csvar ++ csvar' splitC (SubC γ t1@(RVar a1 _) t2@(RVar a2 _))@@ -540,10 +594,10 @@ where γ'' = fe_env $ fenv γ γ' = fe_binds $ fenv γ- r1 = F.RR s $ F.toReft r- r2 = F.RR s $ F.Reft (vv, F.Refa $ F.PBexp $ F.EVar vv)+ r1 = F.RR F.boolSort $ F.toReft r+ r2 = F.RR F.boolSort $ F.Reft (vv, F.Refa $ F.PBexp $ F.EVar vv) vv = "vvRec"- s = F.FApp F.boolFTyCon []+ -- s = boolSort -- F.FApp F.boolFTyCon [] ci = Ci src err err = Just $ ErrAssType src o (text $ show o ++ "type error") r tag = getTag γ@@ -553,7 +607,10 @@ splitsCWithVariance γ t1s t2s variants = concatMapM (\(t1, t2, v) -> splitfWithVariance (\s1 s2 -> (splitC (SubC γ s1 s2))) t1 t2 v) (zip3 t1s t2s variants) -rsplitsCWithVariance γ t1s t2s variants+rsplitsCWithVariance False _ _ _ _ + = return [] ++rsplitsCWithVariance _ γ t1s t2s variants = concatMapM (\(t1, t2, v) -> splitfWithVariance (rsplitC γ) t1 t2 v) (zip3 t1s t2s variants) @@ -641,6 +698,8 @@ , logErrors = [] , kvProf = emptyKVProf , recCount = 0+ , bindSpans = M.empty+ , autoSize = autosize spc } where tce = tcEmbeds spc@@ -653,7 +712,7 @@ ++ [ (dconToSym dc, dconToSort dc) | dc <- dcons ] where lconsts = literalConst tce <$> literals (cbs info)- dcons = filter isDCon $ impVars info -- ++ (snd <$> freeSyms (spec info))+ dcons = filter isDCon $ impVars info ++ (snd <$> freeSyms (spec info)) dconToSort = typeSort tce . expandTypeSynonyms . varType dconToSym = dataConSymbol . idDataCon isDCon x = isDataConId x && not (hasBaseTypeVar x)@@ -676,18 +735,19 @@ = addCGEnv tx γ (msg, x, t) where xs = grapBindsWithType tyy γ- t = foldl (\t1 t2 -> t1 `F.meet` t2) ttrue [ tyx' `F.subst1` (yy, F.EVar x) | x <- xs]+ t = foldl F.meet ttrue [ tyx' `F.subst1` (yy, F.EVar x) | x <- xs] (tyx', ttrue) = splitXRelatedRefs yy tyx addCGEnv tx γ (_, x, t') = do idx <- fresh let t = tx $ normalize {-x-} idx t'+ let l = loc γ let γ' = γ { renv = insertREnv x t (renv γ) } pflag <- pruneRefs <$> get is <- if isBase t- then liftM2 (++) (liftM single $ addBind x $ rTypeSortedReft' pflag γ' t) (addClassBind t)- else return [] -- addClassBind t+ then (:) <$> addBind l x (rTypeSortedReft' pflag γ' t) <*> addClassBind l t+ else return [] return $ γ' { fenv = insertsFEnv (fenv γ) is } (++=) :: CGEnv -> (String, F.Symbol, SpecType) -> CG CGEnv@@ -748,15 +808,15 @@ = t -addBind :: F.Symbol -> F.SortedReft -> CG ((F.Symbol, F.Sort), F.BindId)-addBind x r+addBind :: SrcSpan -> F.Symbol -> F.SortedReft -> CG ((F.Symbol, F.Sort), F.BindId)+addBind l x r = do st <- get let (i, bs') = F.insertBindEnv x r (binds st)- put $ st { binds = bs' }+ put $ st { binds = bs' } { bindSpans = M.insert i l (bindSpans st) } return ((x, F.sr_sort r), i) -- traceShow ("addBind: " ++ showpp x) i -addClassBind :: SpecType -> CG [((F.Symbol, F.Sort), F.BindId)]-addClassBind = mapM (uncurry addBind) . classBinds+addClassBind :: SrcSpan -> SpecType -> CG [((F.Symbol, F.Sort), F.BindId)]+addClassBind l = mapM (uncurry (addBind l)) . classBinds -- RJ: What is this `isBind` business? pushConsBind act@@ -935,24 +995,25 @@ makeDecrIndexTy x t = do spDecr <- specDecr <$> get- hint <- checkHint' (L.lookup x $ spDecr)- case dindex of+ autosz <- autoSize <$> get+ hint <- checkHint' autosz (L.lookup x $ spDecr)+ case dindex autosz of Nothing -> return $ Left msg -- addWarning msg >> return [] Just i -> return $ Right $ fromMaybe [i] hint where ts = ty_args trep- checkHint' = checkHint x ts (isDecreasing cenv)- dindex = L.findIndex (isDecreasing cenv) ts+ checkHint' = \autosz -> checkHint x ts (isDecreasing autosz cenv)+ dindex = \autosz -> L.findIndex (isDecreasing autosz cenv) ts msg = ErrTermin [x] (getSrcSpan x) (text "No decreasing parameter")- cenv = makeNumEnv ts + cenv = makeNumEnv ts trep = toRTypeRep $ unOCons t -recType ((_, []), (_, [], t))+recType _ ((_, []), (_, [], t)) = t -recType ((vs, indexc), (_, index, t))- = makeRecType t v dxt index+recType autoenv ((vs, indexc), (_, index, t))+ = makeRecType autoenv t v dxt index where v = (vs !!) <$> indexc dxt = (xts !!) <$> index xts = zip (ty_binds trep) (ty_args trep)@@ -967,10 +1028,10 @@ msg' = ErrTermin [x] loc (text $ "No decreasing " ++ show index ++ "-th argument on " ++ (showPpr x) ++ " with " ++ (showPpr vs)) msg = ErrTermin [x] loc (text "No decreasing parameter") -makeRecType t vs dxs is+makeRecType autoenv t vs dxs is = mergecondition t $ fromRTypeRep $ trep {ty_binds = xs', ty_args = ts'} where- (xs', ts') = unzip $ replaceN (last is) (makeDecrType vdxs) xts+ (xs', ts') = unzip $ replaceN (last is) (makeDecrType autoenv vdxs) xts vdxs = zip vs dxs xts = zip (ty_binds trep) (ty_args trep) trep = toRTypeRep $ unOCons t@@ -1059,6 +1120,7 @@ consCBSizedTys γ xes = do xets'' <- forM xes $ \(x, e) -> liftM (x, e,) (varTemplate γ (x, Just e)) sflag <- scheck <$> get+ autoenv <- autoSize <$> get let cmakeFinType = if sflag then makeFinType else id let cmakeFinTy = if sflag then makeFinTy else snd let xets = mapThd3 (fmap cmakeFinType) <$> xets''@@ -1068,7 +1130,7 @@ let ts = cmakeFinTy <$> zip is ts' let xeets = (\vis -> [(vis, x) | x <- zip3 xs is $ map unTemplate ts]) <$> (zip vs is) (L.transpose <$> mapM checkIndex (zip4 xs vs ts is)) >>= checkEqTypes- let rts = (recType <$>) <$> xeets+ let rts = (recType autoenv <$>) <$> xeets let xts = zip xs ts γ' <- foldM extender γ xts let γs = [γ' `withTRec` (zip xs rts') | rts' <- rts]@@ -1395,8 +1457,8 @@ addLocA (Just x) (loc γ) (varAnn γ x t) return t -consE γ (Lit c)- = refreshVV $ uRType $ literalFRefType (emb γ) c+consE _ (Lit c)+ = refreshVV $ uRType $ literalFRefType c consE γ e'@(App e (Type τ)) = do RAllT α te <- checkAll ("Non-all TyApp with expr", e) <$> consE γ e@@ -1416,7 +1478,7 @@ updateLocA πs (exprLoc e) te'' let RFun x tx t _ = checkFun ("Non-fun App with caller ", e') te'' pushConsBind $ cconsE γ' a tx- addPost γ' $ maybe (checkUnbound γ' e' x t) (F.subst1 t . (x,)) (argExpr γ a)+ addPost γ' $ maybe (checkUnbound γ' e' x t a) (F.subst1 t . (x,)) (argExpr γ a) where grepfunname (App x (Type _)) = grepfunname x grepfunname (Var x) = x@@ -1439,7 +1501,7 @@ updateLocA πs (exprLoc e) te'' let RFun x tx t _ = checkFun ("Non-fun App with caller ", e') te'' pushConsBind $ cconsE γ' a tx- addPost γ' $ maybe (checkUnbound γ' e' x t) (F.subst1 t . (x,)) (argExpr γ a)+ addPost γ' $ maybe (checkUnbound γ' e' x t a) (F.subst1 t . (x,)) (argExpr γ a) consE γ (Lam α e) | isTyVar α = liftM (RAllT (rTyVar α)) (consE γ e)@@ -1539,12 +1601,12 @@ cconsE γ e t return t -checkUnbound γ e x t+checkUnbound γ e x t a | x `notElem` (F.syms t) = t | otherwise = errorstar $ "checkUnbound: " ++ show x ++ " is elem of syms of " ++ show t- ++ "\nIn\t" ++ showPpr e ++ " at " ++ showPpr (loc γ)+ ++ "\nIn\t" ++ showPpr e ++ " at " ++ showPpr (loc γ) ++ "\nArg = \n" ++ show a dropExists γ (REx x tx t) = liftM (, t) $ (γ, "dropExists") += (x, tx) dropExists γ t = return (γ, t)@@ -1628,7 +1690,7 @@ cγ <- addBinders γ x' [(x', xt')] return cγ -altReft γ _ (LitAlt l) = literalFReft (emb γ) l+altReft _ _ (LitAlt l) = literalFReft l altReft γ acs DEFAULT = mconcat [notLiteralReft l | LitAlt l <- acs] where notLiteralReft = maybe mempty F.notExprReft . snd . literalConst (emb γ) altReft _ _ _ = error "Constraint : altReft"@@ -1704,17 +1766,30 @@ argExpr γ (Tick _ e) = argExpr γ e argExpr _ e = errorstar $ "argExpr: " ++ showPpr e --varRefType γ x = liftM (varRefType' γ x) (γ ??= F.symbol x)+varRefType :: CGEnv -> Var -> CG SpecType+varRefType γ x = varRefType' γ x <$> (γ ??= F.symbol x) +varRefType' :: CGEnv -> Var -> SpecType -> SpecType varRefType' γ x t'- | Just tys <- trec γ, Just tr <- M.lookup x' tys- = tr `strengthen` xr+ | Just tys <- trec γ, Just tr <- M.lookup x' tys+ = tr `strengthenS` xr | otherwise- = t- where t = t' `strengthen` xr- xr = singletonReft x -- uTop $ F.symbolReft $ F.symbol x- x' = F.symbol x+ = t' `strengthenS` xr+ where+ xr = singletonReft x+ x' = F.symbol x+++-- | RJ: `nomeet` replaces `strengthenS` for `strengthen` in the definition+-- of `varRefType`. Why does `tests/neg/strata.hs` fail EVEN if I just replace+-- the `otherwise` case? The fq file holds no answers, both are sat.+strengthenS :: (F.Reftable r) => RType c tv r -> r -> RType c tv r+strengthenS (RApp c ts rs r) r' = RApp c ts rs $ topMeet r r'+strengthenS (RVar a r) r' = RVar a $ topMeet r r'+strengthenS (RFun b t1 t2 r) r' = RFun b t1 t2 $ topMeet r r'+strengthenS (RAppTy t1 t2 r) r' = RAppTy t1 t2 $ topMeet r r'+strengthenS t _ = t+topMeet r r' = F.top r `F.meet` r' -- TODO: should only expose/use subt. Not subsTyVar_meet subsTyVar_meet' (α, t) = subsTyVar_meet (α, toRSort t, t)
src/Language/Haskell/Liquid/Constraint/ToFixpoint.hs view
@@ -11,7 +11,7 @@ import Language.Fixpoint.Misc ( mapSnd ) import Language.Fixpoint.Interface ( parseFInfo ) --- import Control.Applicative ((<$>))+import Control.Applicative ((<$>)) import qualified Data.HashMap.Strict as M import Data.Monoid @@ -24,28 +24,18 @@ impFI <- parseFInfo $ hqFiles info return $ tgtFI <> impFI --- qs <- ghcQuals info--- return F.FI { F.cm = M.fromList $ F.addIds $ fixCs cgi--- , F.ws = fixWfs cgi--- , F.bs = binds cgi--- , F.gs = F.fromListSEnv . map mkSort $ meas spc--- , F.lits = lits cgi--- , F.kuts = kuts cgi--- , F.quals = qs }--- where--- spc = spec info--- tce = tcEmbeds spc--- mkSort = mapSnd (rTypeSortedReft tce . val)- targetFInfo :: GhcInfo -> CGInfo -> F.FInfo Cinfo targetFInfo info cgi- = F.FI { F.cm = M.fromList $ F.addIds $ fixCs cgi- , F.ws = fixWfs cgi- , F.bs = binds cgi- , F.gs = F.fromListSEnv . map mkSort $ meas spc- , F.lits = lits cgi- , F.kuts = kuts cgi- , F.quals = targetQuals info }+ = F.FI { F.cm = M.fromList $ F.addIds $ fixCs cgi+ , F.ws = fixWfs cgi+ , F.bs = binds cgi+ , F.gs = F.fromListSEnv . map mkSort $ meas spc+ , F.lits = lits cgi+ , F.kuts = kuts cgi+ , F.quals = targetQuals info+ , F.bindInfo = (`Ci` Nothing) <$> bindSpans cgi+ -- , F.fileName = error "FIX THIS" :: FilePath+ } where spc = spec info tce = tcEmbeds spc@@ -58,6 +48,3 @@ genQs = specificationQualifiers n info n = maxParams $ config spc spc = spec info---
src/Language/Haskell/Liquid/Constraint/Types.hs view
@@ -1,7 +1,7 @@ module Language.Haskell.Liquid.Constraint.Types where import CoreSyn-import SrcLoc +import SrcLoc import qualified TyCon as TC import qualified DataCon as DC@@ -26,20 +26,20 @@ import Language.Haskell.Liquid.PredType (wiredSortedSyms) import qualified Language.Fixpoint.Types as F -import Language.Fixpoint.Misc +import Language.Fixpoint.Misc import qualified Language.Haskell.Liquid.CTags as Tg -data CGEnv +data CGEnv = CGE { loc :: !SrcSpan -- ^ Location in original source file , renv :: !REnv -- ^ SpecTypes for Bindings in scope , syenv :: !(F.SEnv Var) -- ^ Map from free Symbols (e.g. datacons) to Var- -- , penv :: !(F.SEnv PrType) -- ^ PrTypes for top-level bindings (merge with renv) + -- , penv :: !(F.SEnv PrType) -- ^ PrTypes for top-level bindings (merge with renv) , denv :: !RDEnv -- ^ Dictionary Environment , fenv :: !FEnv -- ^ Fixpoint Environment , recs :: !(S.HashSet Var) -- ^ recursive defs being processed (for annotations)- , invs :: !RTyConInv -- ^ Datatype invariants - , ial :: !RTyConIAl -- ^ Datatype checkable invariants + , invs :: !RTyConInv -- ^ Datatype invariants+ , ial :: !RTyConIAl -- ^ Datatype checkable invariants , grtys :: !REnv -- ^ Top-level variables with (assert)-guarantees to verify , assms :: !REnv -- ^ Top-level variables with assumed types , emb :: F.TCEmb TC.TyCon -- ^ How to embed GHC Tycons into fixpoint sorts@@ -69,14 +69,14 @@ data SubC = SubC { senv :: !CGEnv , lhs :: !SpecType- , rhs :: !SpecType + , rhs :: !SpecType } | SubR { senv :: !CGEnv , oblig :: !Oblig , ref :: !RReft } -data WfC = WfC !CGEnv !SpecType +data WfC = WfC !CGEnv !SpecType -- deriving (Data, Typeable) type FixSubC = F.SubC Cinfo@@ -84,12 +84,12 @@ instance PPrint SubC where pprint c = pprint (senv c)- $+$ ((text " |- ") <+> ( (pprint (lhs c)) - $+$ text "<:" - $+$ (pprint (rhs c))))+ $+$ (text " |- " <+> (pprint (lhs c) $+$+ text "<:" $+$+ pprint (rhs c))) instance PPrint WfC where- pprint (WfC w r) = pprint w <> text " |- " <> pprint r + pprint (WfC w r) = pprint w <> text " |- " <> pprint r instance SubStratum SubC where subS su (SubC γ t1 t2) = SubC γ (subS su t1) (subS su t2)@@ -106,7 +106,7 @@ , hsWfs :: ![WfC] -- ^ wellformedness constraints over RType , sCs :: ![SubC] -- ^ additional stratum constrains for let bindings , fixCs :: ![FixSubC] -- ^ subtyping over Sort (post-splitting)- , isBind :: ![Bool] -- ^ tracks constraints that come from let-bindings + , isBind :: ![Bool] -- ^ tracks constraints that come from let-bindings , fixWfs :: ![FixWfC] -- ^ wellformedness constraints over Sort (post-splitting) , freshIndex :: !Integer -- ^ counter for generating fresh KVars , binds :: !F.BindEnv -- ^ set of environment binders@@ -116,23 +116,25 @@ , termExprs :: !(M.HashMap Var [F.Expr]) -- ^ Terminating Metrics for Recursive functions , specLVars :: !(S.HashSet Var) -- ^ Set of variables to ignore for termination checking , specLazy :: !(S.HashSet Var) -- ^ ? FIX THIS+ , autoSize :: !(S.HashSet TC.TyCon) -- ^ ? FIX THIS , tyConEmbed :: !(F.TCEmb TC.TyCon) -- ^ primitive Sorts into which TyCons should be embedded , kuts :: !(F.Kuts) -- ^ Fixpoint Kut variables (denoting "back-edges"/recursive KVars)- , lits :: ![(F.Symbol, F.Sort)] -- ^ ? FIX THIS - , tcheck :: !Bool -- ^ Check Termination (?) + , lits :: ![(F.Symbol, F.Sort)] -- ^ ? FIX THIS+ , tcheck :: !Bool -- ^ Check Termination (?) , scheck :: !Bool -- ^ Check Strata (?) , trustghc :: !Bool -- ^ Trust ghc auto generated bindings , pruneRefs :: !Bool -- ^ prune unsorted refinements- , logErrors :: ![TError SpecType] -- ^ Errors during coontraint generation- , kvProf :: !KVProf -- ^ Profiling distribution of KVars + , logErrors :: ![TError SpecType] -- ^ Errors during constraint generation+ , kvProf :: !KVProf -- ^ Profiling distribution of KVars , recCount :: !Int -- ^ number of recursive functions seen (for benchmarks)- } -- deriving (Data, Typeable)+ , bindSpans :: M.HashMap F.BindId SrcSpan -- ^ Source Span associated with Fixpoint Binder+ } -instance PPrint CGInfo where - pprint cgi = {-# SCC "ppr_CGI" #-} ppr_CGInfo cgi+instance PPrint CGInfo where+ pprint cgi = {-# SCC "ppr_CGI" #-} pprCGInfo cgi -ppr_CGInfo _cgi - = (text "*********** Constraint Information ***********")+pprCGInfo _cgi+ = text "*********** Constraint Information ***********" -- -$$ (text "*********** Haskell SubConstraints ***********") -- -$$ (pprintLongList $ hsCs cgi) -- -$$ (text "*********** Haskell WFConstraints ************")@@ -173,10 +175,10 @@ type RTyConInv = M.HashMap RTyCon [SpecType] type RTyConIAl = M.HashMap RTyCon [SpecType] -mkRTyConInv :: [F.Located SpecType] -> RTyConInv +mkRTyConInv :: [F.Located SpecType] -> RTyConInv mkRTyConInv ts = group [ (c, t) | t@(RApp c _ _ _) <- strip <$> ts]- where - strip = fourth4 . bkUniv . val + where+ strip = fourth4 . bkUniv . val mkRTyConIAl = mkRTyConInv . fmap snd @@ -184,15 +186,15 @@ addRTyConInv m t@(RApp c _ _ _) = case M.lookup c m of Nothing -> t- Just ts -> L.foldl' conjoinInvariant' t ts-addRTyConInv _ t - = t + Just ts -> L.foldl' conjoinInvariantShift t ts+addRTyConInv _ t+ = t addRInv :: RTyConInv -> (Var, SpecType) -> (Var, SpecType)-addRInv m (x, t) +addRInv m (x, t) | x `elem` ids , (RApp c _ _ _) <- res t, Just invs <- M.lookup c m- = (x, addInvCond t (mconcat $ catMaybes (stripRTypeBase <$> invs))) - | otherwise + = (x, addInvCond t (mconcat $ catMaybes (stripRTypeBase <$> invs)))+ | otherwise = (x, t) where ids = [id | tc <- M.keys m@@ -200,28 +202,25 @@ , id <- DC.dataConImplicitIds dc] res = ty_res . toRTypeRep -conjoinInvariant' t1 t2 - = conjoinInvariantShift t1 t2--conjoinInvariantShift t1 t2 - = conjoinInvariant t1 (shiftVV t2 (rTypeValueVar t1)) +conjoinInvariantShift t1 t2+ = conjoinInvariant t1 (shiftVV t2 (rTypeValueVar t1)) -conjoinInvariant (RApp c ts rs r) (RApp ic its _ ir) - | (c == ic && length ts == length its)+conjoinInvariant (RApp c ts rs r) (RApp ic its _ ir)+ | c == ic && length ts == length its = RApp c (zipWith conjoinInvariantShift ts its) rs (r `F.meet` ir) -conjoinInvariant t@(RApp _ _ _ r) (RVar _ ir) +conjoinInvariant t@(RApp _ _ _ r) (RVar _ ir) = t { rt_reft = r `F.meet` ir } -conjoinInvariant t@(RVar _ r) (RVar _ ir) +conjoinInvariant t@(RVar _ r) (RVar _ ir) = t { rt_reft = r `F.meet` ir } -conjoinInvariant t _ +conjoinInvariant t _ = t -grapBindsWithType tx γ +grapBindsWithType tx γ = fst <$> toListREnv (filterREnv ((== toRSort tx) . toRSort) (renv γ)) ---------------------------------------------------------------@@ -237,7 +236,6 @@ insertREnv x y (REnv env) = REnv (M.insert x y env) lookupREnv x (REnv env) = M.lookup x env memberREnv x (REnv env) = M.member x env-
src/Language/Haskell/Liquid/CoreToLogic.hs view
@@ -388,6 +388,7 @@ where -- auto generated undefined case: (\_ -> (patError @type "error message")) void isUndefinedExpr (C.App (C.Var x) _) | (show x) `elem` perrors = True+ isUndefinedExpr (C.Let _ e) = isUndefinedExpr e -- otherwise isUndefinedExpr _ = False
+ src/Language/Haskell/Liquid/Desugar710/Check.hs view
@@ -0,0 +1,773 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1997-1998++Author: Juan J. Quintela <quintela@krilin.dc.fi.udc.es>+-}++{-# LANGUAGE CPP #-}++module Language.Haskell.Liquid.Desugar710.Check ( check , ExhaustivePat ) where++-- #include "HsVersions.h"++import HsSyn+import TcHsSyn+import Language.Haskell.Liquid.Desugar710.DsUtils+import Language.Haskell.Liquid.Desugar710.MatchLit+import Id+import ConLike+import DataCon+import PatSyn+import Name+import TysWiredIn+import PrelNames+import TyCon+import SrcLoc+import UniqSet+import Util+import BasicTypes+import Outputable+import FastString++{-+This module performs checks about if one list of equations are:+\begin{itemize}+\item Overlapped+\item Non exhaustive+\end{itemize}+To discover that we go through the list of equations in a tree-like fashion.++If you like theory, a similar algorithm is described in:+\begin{quotation}+ {\em Two Techniques for Compiling Lazy Pattern Matching},+ Luc Maranguet,+ INRIA Rocquencourt (RR-2385, 1994)+\end{quotation}+The algorithm is based on the first technique, but there are some differences:+\begin{itemize}+\item We don't generate code+\item We have constructors and literals (not only literals as in the+ article)+\item We don't use directions, we must select the columns from+ left-to-right+\end{itemize}+(By the way the second technique is really similar to the one used in+ @Match.lhs@ to generate code)++This function takes the equations of a pattern and returns:+\begin{itemize}+\item The patterns that are not recognized+\item The equations that are not overlapped+\end{itemize}+It simplify the patterns and then call @check'@ (the same semantics), and it+needs to reconstruct the patterns again ....++The problem appear with things like:+\begin{verbatim}+ f [x,y] = ....+ f (x:xs) = .....+\end{verbatim}+We want to put the two patterns with the same syntax, (prefix form) and+then all the constructors are equal:+\begin{verbatim}+ f (: x (: y [])) = ....+ f (: x xs) = .....+\end{verbatim}+(more about that in @tidy_eqns@)++We would prefer to have a @WarningPat@ of type @String@, but Strings and the+Pretty Printer are not friends.++We use @InPat@ in @WarningPat@ instead of @OutPat@+because we need to print the+warning messages in the same way they are introduced, i.e. if the user+wrote:+\begin{verbatim}+ f [x,y] = ..+\end{verbatim}+He don't want a warning message written:+\begin{verbatim}+ f (: x (: y [])) ........+\end{verbatim}+Then we need to use InPats.+\begin{quotation}+ Juan Quintela 5 JUL 1998\\+ User-friendliness and compiler writers are no friends.+\end{quotation}+-}++type WarningPat = InPat Name+type ExhaustivePat = ([WarningPat], [(Name, [HsLit])])+type EqnNo = Int+type EqnSet = UniqSet EqnNo+++check :: [EquationInfo] -> ([ExhaustivePat], [EquationInfo])+ -- Second result is the shadowed equations+ -- if there are view patterns, just give up - don't know what the function is+check qs = (untidy_warns, shadowed_eqns)+ where+ tidy_qs = map tidy_eqn qs+ (warns, used_nos) = check' ([1..] `zip` tidy_qs)+ untidy_warns = map untidy_exhaustive warns+ shadowed_eqns = [eqn | (eqn,i) <- qs `zip` [1..],+ not (i `elementOfUniqSet` used_nos)]++untidy_exhaustive :: ExhaustivePat -> ExhaustivePat+untidy_exhaustive ([pat], messages) =+ ([untidy_no_pars pat], map untidy_message messages)+untidy_exhaustive (pats, messages) =+ (map untidy_pars pats, map untidy_message messages)++untidy_message :: (Name, [HsLit]) -> (Name, [HsLit])+untidy_message (string, lits) = (string, map untidy_lit lits)++-- The function @untidy@ does the reverse work of the @tidy_pat@ function.++type NeedPars = Bool++untidy_no_pars :: WarningPat -> WarningPat+untidy_no_pars p = untidy False p++untidy_pars :: WarningPat -> WarningPat+untidy_pars p = untidy True p++untidy :: NeedPars -> WarningPat -> WarningPat+untidy b (L loc p) = L loc (untidy' b p)+ where+ untidy' _ p@(WildPat _) = p+ untidy' _ p@(VarPat _) = p+ untidy' _ (LitPat lit) = LitPat (untidy_lit lit)+ untidy' _ p@(ConPatIn _ (PrefixCon [])) = p+ untidy' b (ConPatIn name ps) = pars b (L loc (ConPatIn name (untidy_con ps)))+ untidy' _ (ListPat pats ty Nothing) = ListPat (map untidy_no_pars pats) ty Nothing+ untidy' _ (TuplePat pats box tys) = TuplePat (map untidy_no_pars pats) box tys+ untidy' _ (ListPat _ _ (Just _)) = panic "Check.untidy: Overloaded ListPat"+ untidy' _ (PArrPat _ _) = panic "Check.untidy: Shouldn't get a parallel array here!"+ untidy' _ (SigPatIn _ _) = panic "Check.untidy: SigPat"+ untidy' _ (LazyPat {}) = panic "Check.untidy: LazyPat"+ untidy' _ (AsPat {}) = panic "Check.untidy: AsPat"+ untidy' _ (ParPat {}) = panic "Check.untidy: ParPat"+ untidy' _ (BangPat {}) = panic "Check.untidy: BangPat"+ untidy' _ (ConPatOut {}) = panic "Check.untidy: ConPatOut"+ untidy' _ (ViewPat {}) = panic "Check.untidy: ViewPat"+ untidy' _ (SplicePat {}) = panic "Check.untidy: SplicePat"+ untidy' _ (QuasiQuotePat {}) = panic "Check.untidy: QuasiQuotePat"+ untidy' _ (NPat {}) = panic "Check.untidy: NPat"+ untidy' _ (NPlusKPat {}) = panic "Check.untidy: NPlusKPat"+ untidy' _ (SigPatOut {}) = panic "Check.untidy: SigPatOut"+ untidy' _ (CoPat {}) = panic "Check.untidy: CoPat"++untidy_con :: HsConPatDetails Name -> HsConPatDetails Name+untidy_con (PrefixCon pats) = PrefixCon (map untidy_pars pats)+untidy_con (InfixCon p1 p2) = InfixCon (untidy_pars p1) (untidy_pars p2)+untidy_con (RecCon (HsRecFields flds dd))+ = RecCon (HsRecFields [ L l (fld { hsRecFieldArg+ = untidy_pars (hsRecFieldArg fld) })+ | L l fld <- flds ] dd)++pars :: NeedPars -> WarningPat -> Pat Name+pars True p = ParPat p+pars _ p = unLoc p++untidy_lit :: HsLit -> HsLit+untidy_lit (HsCharPrim src c) = HsChar src c+untidy_lit lit = lit++{-+This equation is the same that check, the only difference is that the+boring work is done, that work needs to be done only once, this is+the reason top have two functions, check is the external interface,+@check'@ is called recursively.++There are several cases:++\begin{itemize}+\item There are no equations: Everything is OK.+\item There are only one equation, that can fail, and all the patterns are+ variables. Then that equation is used and the same equation is+ non-exhaustive.+\item All the patterns are variables, and the match can fail, there are+ more equations then the results is the result of the rest of equations+ and this equation is used also.++\item The general case, if all the patterns are variables (here the match+ can't fail) then the result is that this equation is used and this+ equation doesn't generate non-exhaustive cases.++\item In the general case, there can exist literals ,constructors or only+ vars in the first column, we actuate in consequence.++\end{itemize}+-}++check' :: [(EqnNo, EquationInfo)]+ -> ([ExhaustivePat], -- Pattern scheme that might not be matched at all+ EqnSet) -- Eqns that are used (others are overlapped)++check' [] = ([],emptyUniqSet)+ -- Was ([([],[])], emptyUniqSet)+ -- But that (a) seems weird, and (b) triggered Trac #7669+ -- So now I'm just doing the simple obvious thing++check' ((n, EqnInfo { eqn_pats = ps, eqn_rhs = MatchResult can_fail _ }) : rs)+ | first_eqn_all_vars && case can_fail of { CantFail -> True; CanFail -> False }+ = ([], unitUniqSet n) -- One eqn, which can't fail++ | first_eqn_all_vars && null rs -- One eqn, but it can fail+ = ([(takeList ps (repeat nlWildPatName),[])], unitUniqSet n)++ | first_eqn_all_vars -- Several eqns, first can fail+ = (pats, addOneToUniqSet indexs n)+ where+ first_eqn_all_vars = all_vars ps+ (pats,indexs) = check' rs++check' qs+ | some_literals = split_by_literals qs+ | some_constructors = split_by_constructor qs+ | only_vars = first_column_only_vars qs+ | otherwise = pprPanic "Check.check': Not implemented :-(" (ppr first_pats)+ -- Shouldn't happen+ where+ -- Note: RecPats will have been simplified to ConPats+ -- at this stage.+ first_pats = {- ASSERT2( okGroup qs, pprGroup qs ) -} map firstPatN qs+ some_constructors = any is_con first_pats+ some_literals = any is_lit first_pats+ only_vars = all is_var first_pats++{-+Here begins the code to deal with literals, we need to split the matrix+in different matrix beginning by each literal and a last matrix with the+rest of values.+-}++split_by_literals :: [(EqnNo, EquationInfo)] -> ([ExhaustivePat], EqnSet)+split_by_literals qs = process_literals used_lits qs+ where+ used_lits = get_used_lits qs++{-+@process_explicit_literals@ is a function that process each literal that appears+in the column of the matrix.+-}++process_explicit_literals :: [HsLit] -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)+process_explicit_literals lits qs = (concat pats, unionManyUniqSets indexs)+ where+ pats_indexs = map (\x -> construct_literal_matrix x qs) lits+ (pats,indexs) = unzip pats_indexs++{-+@process_literals@ calls @process_explicit_literals@ to deal with the literals+that appears in the matrix and deal also with the rest of the cases. It+must be one Variable to be complete.+-}++process_literals :: [HsLit] -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)+process_literals used_lits qs+ | null default_eqns = {- ASSERT( not (null qs) ) -} ([make_row_vars used_lits (head qs)] ++ pats,indexs)+ | otherwise = (pats_default,indexs_default)+ where+ (pats,indexs) = process_explicit_literals used_lits qs+ default_eqns = -- ASSERT2( okGroup qs, pprGroup qs )+ [remove_var q | q <- qs, is_var (firstPatN q)]+ (pats',indexs') = check' default_eqns+ pats_default = [(nlWildPatName:ps,constraints) |+ (ps,constraints) <- (pats')] ++ pats+ indexs_default = unionUniqSets indexs' indexs++{-+Here we have selected the literal and we will select all the equations that+begins for that literal and create a new matrix.+-}++construct_literal_matrix :: HsLit -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)+construct_literal_matrix lit qs =+ (map (\ (xs,ys) -> (new_lit:xs,ys)) pats,indexs)+ where+ (pats,indexs) = (check' (remove_first_column_lit lit qs))+ new_lit = nlLitPat lit++remove_first_column_lit :: HsLit+ -> [(EqnNo, EquationInfo)]+ -> [(EqnNo, EquationInfo)]+remove_first_column_lit lit qs+ = -- ASSERT2( okGroup qs, pprGroup qs )+ [(n, shift_pat eqn) | q@(n,eqn) <- qs, is_var_lit lit (firstPatN q)]+ where+ shift_pat eqn@(EqnInfo { eqn_pats = _:ps}) = eqn { eqn_pats = ps }+ shift_pat _ = panic "Check.shift_var: no patterns"++{-+This function splits the equations @qs@ in groups that deal with the+same constructor.+-}++split_by_constructor :: [(EqnNo, EquationInfo)] -> ([ExhaustivePat], EqnSet)+split_by_constructor qs+ | null used_cons = ([], mkUniqSet $ map fst qs)+ | notNull unused_cons = need_default_case used_cons unused_cons qs+ | otherwise = no_need_default_case used_cons qs+ where+ used_cons = get_used_cons qs+ unused_cons = get_unused_cons used_cons++{-+The first column of the patterns matrix only have vars, then there is+nothing to do.+-}++first_column_only_vars :: [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)+first_column_only_vars qs+ = (map (\ (xs,ys) -> (nlWildPatName:xs,ys)) pats,indexs)+ where+ (pats, indexs) = check' (map remove_var qs)++{-+This equation takes a matrix of patterns and split the equations by+constructor, using all the constructors that appears in the first column+of the pattern matching.++We can need a default clause or not ...., it depends if we used all the+constructors or not explicitly. The reasoning is similar to @process_literals@,+the difference is that here the default case is not always needed.+-}++no_need_default_case :: [Pat Id] -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)+no_need_default_case cons qs = (concat pats, unionManyUniqSets indexs)+ where+ pats_indexs = map (\x -> construct_matrix x qs) cons+ (pats,indexs) = unzip pats_indexs++need_default_case :: [Pat Id] -> [DataCon] -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)+need_default_case used_cons unused_cons qs+ | null default_eqns = (pats_default_no_eqns,indexs)+ | otherwise = (pats_default,indexs_default)+ where+ (pats,indexs) = no_need_default_case used_cons qs+ default_eqns = -- ASSERT2( okGroup qs, pprGroup qs )+ [remove_var q | q <- qs, is_var (firstPatN q)]+ (pats',indexs') = check' default_eqns+ pats_default = [(make_whole_con c:ps,constraints) |+ c <- unused_cons, (ps,constraints) <- pats'] ++ pats+ new_wilds = {- ASSERT( not (null qs) ) -} make_row_vars_for_constructor (head qs)+ pats_default_no_eqns = [(make_whole_con c:new_wilds,[]) | c <- unused_cons] ++ pats+ indexs_default = unionUniqSets indexs' indexs++construct_matrix :: Pat Id -> [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet)+construct_matrix con qs =+ (map (make_con con) pats,indexs)+ where+ (pats,indexs) = (check' (remove_first_column con qs))++{-+Here remove first column is more difficult that with literals due to the fact+that constructors can have arguments.++For instance, the matrix+\begin{verbatim}+ (: x xs) y+ z y+\end{verbatim}+is transformed in:+\begin{verbatim}+ x xs y+ _ _ y+\end{verbatim}+-}++remove_first_column :: Pat Id -- Constructor+ -> [(EqnNo, EquationInfo)]+ -> [(EqnNo, EquationInfo)]+remove_first_column (ConPatOut{ pat_con = L _ con, pat_args = PrefixCon con_pats }) qs+ = -- ASSERT2( okGroup qs, pprGroup qs )+ [(n, shift_var eqn) | q@(n, eqn) <- qs, is_var_con con (firstPatN q)]+ where+ new_wilds = [WildPat (hsLPatType arg_pat) | arg_pat <- con_pats]+ shift_var eqn@(EqnInfo { eqn_pats = ConPatOut{ pat_args = PrefixCon ps' } : ps})+ = eqn { eqn_pats = map unLoc ps' ++ ps }+ shift_var eqn@(EqnInfo { eqn_pats = WildPat _ : ps })+ = eqn { eqn_pats = new_wilds ++ ps }+ shift_var _ = panic "Check.Shift_var:No done"+remove_first_column _ _ = panic "Check.remove_first_column: Not ConPatOut"++make_row_vars :: [HsLit] -> (EqnNo, EquationInfo) -> ExhaustivePat+make_row_vars used_lits (_, EqnInfo { eqn_pats = pats})+ = (nlVarPat new_var:takeList (tail pats) (repeat nlWildPatName)+ ,[(new_var,used_lits)])+ where+ new_var = hash_x++hash_x :: Name+hash_x = mkInternalName unboundKey {- doesn't matter much -}+ (mkVarOccFS (fsLit "#x"))+ noSrcSpan++make_row_vars_for_constructor :: (EqnNo, EquationInfo) -> [WarningPat]+make_row_vars_for_constructor (_, EqnInfo { eqn_pats = pats})+ = takeList (tail pats) (repeat nlWildPatName)++compare_cons :: Pat Id -> Pat Id -> Bool+compare_cons (ConPatOut{ pat_con = L _ con1 }) (ConPatOut{ pat_con = L _ con2 })+ = case (con1, con2) of+ (RealDataCon id1, RealDataCon id2) -> id1 == id2+ _ -> False+compare_cons _ _ = panic "Check.compare_cons: Not ConPatOut with RealDataCon"++remove_dups :: [Pat Id] -> [Pat Id]+remove_dups [] = []+remove_dups (x:xs) | any (\y -> compare_cons x y) xs = remove_dups xs+ | otherwise = x : remove_dups xs++get_used_cons :: [(EqnNo, EquationInfo)] -> [Pat Id]+get_used_cons qs = remove_dups [pat | q <- qs, let pat = firstPatN q,+ isConPatOut pat]++isConPatOut :: Pat Id -> Bool+isConPatOut ConPatOut{ pat_con = L _ RealDataCon{} } = True+isConPatOut _ = False++remove_dups' :: [HsLit] -> [HsLit]+remove_dups' [] = []+remove_dups' (x:xs) | x `elem` xs = remove_dups' xs+ | otherwise = x : remove_dups' xs+++get_used_lits :: [(EqnNo, EquationInfo)] -> [HsLit]+get_used_lits qs = remove_dups' all_literals+ where+ all_literals = get_used_lits' qs++get_used_lits' :: [(EqnNo, EquationInfo)] -> [HsLit]+get_used_lits' [] = []+get_used_lits' (q:qs)+ | Just lit <- get_lit (firstPatN q) = lit : get_used_lits' qs+ | otherwise = get_used_lits qs++get_lit :: Pat id -> Maybe HsLit+-- Get a representative HsLit to stand for the OverLit+-- It doesn't matter which one, because they will only be compared+-- with other HsLits gotten in the same way+get_lit (LitPat lit) = Just lit+get_lit (NPat (L _ (OverLit { ol_val = HsIntegral src i})) mb _)+ = Just (HsIntPrim src (mb_neg negate mb i))+get_lit (NPat (L _ (OverLit { ol_val = HsFractional f })) mb _)+ = Just (HsFloatPrim (mb_neg negateFractionalLit mb f))+get_lit (NPat (L _ (OverLit { ol_val = HsIsString src s })) _ _)+ = Just (HsStringPrim src (fastStringToByteString s))+get_lit _ = Nothing++mb_neg :: (a -> a) -> Maybe b -> a -> a+mb_neg _ Nothing v = v+mb_neg negate (Just _) v = negate v++get_unused_cons :: [Pat Id] -> [DataCon]+get_unused_cons used_cons = {- ASSERT( not (null used_cons) ) -} unused_cons+ where+ used_set :: UniqSet DataCon+ used_set = mkUniqSet [d | ConPatOut{ pat_con = L _ (RealDataCon d) } <- used_cons]+ (ConPatOut { pat_con = L _ (RealDataCon con1), pat_arg_tys = inst_tys }) = head used_cons+ ty_con = dataConTyCon con1+ unused_cons = filterOut is_used (tyConDataCons ty_con)+ is_used con = con `elementOfUniqSet` used_set+ || dataConCannotMatch inst_tys con++all_vars :: [Pat Id] -> Bool+all_vars [] = True+all_vars (WildPat _:ps) = all_vars ps+all_vars _ = False++remove_var :: (EqnNo, EquationInfo) -> (EqnNo, EquationInfo)+remove_var (n, eqn@(EqnInfo { eqn_pats = WildPat _ : ps})) = (n, eqn { eqn_pats = ps })+remove_var _ = panic "Check.remove_var: equation does not begin with a variable"++-----------------------+{-+eqnPats :: (EqnNo, EquationInfo) -> [Pat Id]+eqnPats (_, eqn) = eqn_pats eqn+okGroup :: [(EqnNo, EquationInfo)] -> Bool+-- True if all equations have at least one pattern, and+-- all have the same number of patterns+okGroup [] = True+okGroup (e:es) = n_pats > 0 && and [length (eqnPats e) == n_pats | e <- es]+ where+ n_pats = length (eqnPats e)+-}+-- Half-baked print+-- pprGroup :: [(EqnNo, EquationInfo)] -> SDoc+-- pprEqnInfo :: (EqnNo, EquationInfo) -> SDoc+-- pprGroup es = vcat (map pprEqnInfo es)+-- pprEqnInfo e = ppr (eqnPats e)+++firstPatN :: (EqnNo, EquationInfo) -> Pat Id+firstPatN (_, eqn) = firstPat eqn++is_con :: Pat Id -> Bool+is_con (ConPatOut {}) = True+is_con _ = False++is_lit :: Pat Id -> Bool+is_lit (LitPat _) = True+is_lit (NPat _ _ _) = True+is_lit _ = False++is_var :: Pat Id -> Bool+is_var (WildPat _) = True+is_var _ = False++is_var_con :: ConLike -> Pat Id -> Bool+is_var_con _ (WildPat _) = True+is_var_con con (ConPatOut{ pat_con = L _ id }) = id == con+is_var_con _ _ = False++is_var_lit :: HsLit -> Pat Id -> Bool+is_var_lit _ (WildPat _) = True+is_var_lit lit pat+ | Just lit' <- get_lit pat = lit == lit'+ | otherwise = False++{-+The difference beteewn @make_con@ and @make_whole_con@ is that+@make_wole_con@ creates a new constructor with all their arguments, and+@make_con@ takes a list of argumntes, creates the contructor getting their+arguments from the list. See where \fbox{\ ???\ } are used for details.++We need to reconstruct the patterns (make the constructors infix and+similar) at the same time that we create the constructors.++You can tell tuple constructors using+\begin{verbatim}+ Id.isTupleDataCon+\end{verbatim}+You can see if one constructor is infix with this clearer code :-))))))))))+\begin{verbatim}+ Lex.isLexConSym (Name.occNameString (Name.getOccName con))+\end{verbatim}++ Rather clumsy but it works. (Simon Peyton Jones)+++We don't mind the @nilDataCon@ because it doesn't change the way to+print the message, we are searching only for things like: @[1,2,3]@,+not @x:xs@ ....++In @reconstruct_pat@ we want to ``undo'' the work+that we have done in @tidy_pat@.+In particular:+\begin{tabular}{lll}+ @((,) x y)@ & returns to be & @(x, y)@+\\ @((:) x xs)@ & returns to be & @(x:xs)@+\\ @(x:(...:[])@ & returns to be & @[x,...]@+\end{tabular}++The difficult case is the third one becouse we need to follow all the+contructors until the @[]@ to know that we need to use the second case,+not the second. \fbox{\ ???\ }+-}++isInfixCon :: DataCon -> Bool+isInfixCon con = isDataSymOcc (getOccName con)++is_nil :: Pat Name -> Bool+is_nil (ConPatIn con (PrefixCon [])) = unLoc con == getName nilDataCon+is_nil _ = False++is_list :: Pat Name -> Bool+is_list (ListPat _ _ Nothing) = True+is_list _ = False++return_list :: DataCon -> Pat Name -> Bool+return_list id q = id == consDataCon && (is_nil q || is_list q)++make_list :: LPat Name -> Pat Name -> Pat Name+make_list p q | is_nil q = ListPat [p] placeHolderType Nothing+make_list p (ListPat ps ty Nothing) = ListPat (p:ps) ty Nothing+make_list _ _ = panic "Check.make_list: Invalid argument"++make_con :: Pat Id -> ExhaustivePat -> ExhaustivePat+make_con (ConPatOut{ pat_con = L _ (RealDataCon id) }) (lp:lq:ps, constraints)+ | return_list id q = (noLoc (make_list lp q) : ps, constraints)+ | isInfixCon id = (nlInfixConPat (getName id) lp lq : ps, constraints)+ where q = unLoc lq++make_con (ConPatOut{ pat_con = L _ (RealDataCon id), pat_args = PrefixCon pats})+ (ps, constraints)+ | isTupleTyCon tc = (noLoc (TuplePat pats_con (tupleTyConBoxity tc) [])+ : rest_pats, constraints)+ | isPArrFakeCon id = (noLoc (PArrPat pats_con placeHolderType)+ : rest_pats, constraints)+ | otherwise = (nlConPatName name pats_con+ : rest_pats, constraints)+ where+ name = getName id+ (pats_con, rest_pats) = splitAtList pats ps+ tc = dataConTyCon id++make_con _ _ = panic "Check.make_con: Not ConPatOut"++-- reconstruct parallel array pattern+--+-- * don't check for the type only; we need to make sure that we are really+-- dealing with one of the fake constructors and not with the real+-- representation++make_whole_con :: DataCon -> WarningPat+make_whole_con con | isInfixCon con = nlInfixConPat name+ nlWildPatName nlWildPatName+ | otherwise = nlConPatName name pats+ where+ name = getName con+ pats = [nlWildPatName | _ <- dataConOrigArgTys con]++{-+------------------------------------------------------------------------+ Tidying equations+------------------------------------------------------------------------++tidy_eqn does more or less the same thing as @tidy@ in @Match.lhs@;+that is, it removes syntactic sugar, reducing the number of cases that+must be handled by the main checking algorithm. One difference is+that here we can do *all* the tidying at once (recursively), rather+than doing it incrementally.+-}++tidy_eqn :: EquationInfo -> EquationInfo+tidy_eqn eqn = eqn { eqn_pats = map tidy_pat (eqn_pats eqn),+ eqn_rhs = tidy_rhs (eqn_rhs eqn) }+ where+ -- Horrible hack. The tidy_pat stuff converts "might-fail" patterns to+ -- WildPats which of course loses the info that they can fail to match.+ -- So we stick in a CanFail as if it were a guard.+ tidy_rhs (MatchResult can_fail body)+ | any might_fail_pat (eqn_pats eqn) = MatchResult CanFail body+ | otherwise = MatchResult can_fail body++--------------+might_fail_pat :: Pat Id -> Bool+-- Returns True of patterns that might fail (i.e. fall through) in a way+-- that is not covered by the checking algorithm. Specifically:+-- NPlusKPat+-- ViewPat (if refutable)+-- ConPatOut of a PatSynCon++-- First the two special cases+might_fail_pat (NPlusKPat {}) = True+might_fail_pat (ViewPat _ p _) = not (isIrrefutableHsPat p)++-- Now the recursive stuff+might_fail_pat (ParPat p) = might_fail_lpat p+might_fail_pat (AsPat _ p) = might_fail_lpat p+might_fail_pat (SigPatOut p _ ) = might_fail_lpat p+might_fail_pat (ListPat ps _ Nothing) = any might_fail_lpat ps+might_fail_pat (ListPat _ _ (Just _)) = True+might_fail_pat (TuplePat ps _ _) = any might_fail_lpat ps+might_fail_pat (PArrPat ps _) = any might_fail_lpat ps+might_fail_pat (BangPat p) = might_fail_lpat p+might_fail_pat (ConPatOut { pat_con = con, pat_args = ps })+ = case unLoc con of+ RealDataCon _dcon -> any might_fail_lpat (hsConPatArgs ps)+ PatSynCon _psyn -> True++-- Finally the ones that are sure to succeed, or which are covered by the checking algorithm+might_fail_pat (LazyPat _) = False -- Always succeeds+might_fail_pat _ = False -- VarPat, WildPat, LitPat, NPat++--------------+might_fail_lpat :: LPat Id -> Bool+might_fail_lpat (L _ p) = might_fail_pat p++--------------+tidy_lpat :: LPat Id -> LPat Id+tidy_lpat p = fmap tidy_pat p++--------------+tidy_pat :: Pat Id -> Pat Id+tidy_pat pat@(WildPat _) = pat+tidy_pat (VarPat id) = WildPat (idType id)+tidy_pat (ParPat p) = tidy_pat (unLoc p)+tidy_pat (LazyPat p) = WildPat (hsLPatType p) -- For overlap and exhaustiveness checking+ -- purposes, a ~pat is like a wildcard+tidy_pat (BangPat p) = tidy_pat (unLoc p)+tidy_pat (AsPat _ p) = tidy_pat (unLoc p)+tidy_pat (SigPatOut p _) = tidy_pat (unLoc p)+tidy_pat (CoPat _ pat _) = tidy_pat pat++-- These two are might_fail patterns, so we map them to+-- WildPats. The might_fail_pat stuff arranges that the+-- guard says "this equation might fall through".+tidy_pat (NPlusKPat id _ _ _) = WildPat (idType (unLoc id))+tidy_pat (ViewPat _ _ ty) = WildPat ty+tidy_pat (ListPat _ _ (Just (ty,_))) = WildPat ty+tidy_pat (ConPatOut { pat_con = L _ (PatSynCon syn), pat_arg_tys = tys })+ = WildPat (patSynInstResTy syn tys)++tidy_pat pat@(ConPatOut { pat_con = L _ con, pat_args = ps })+ = pat { pat_args = tidy_con con ps }++tidy_pat (ListPat ps ty Nothing)+ = unLoc $ foldr (\ x y -> mkPrefixConPat consDataCon [x,y] [ty])+ (mkNilPat ty)+ (map tidy_lpat ps)++-- introduce fake parallel array constructors to be able to handle parallel+-- arrays with the existing machinery for constructor pattern+--+tidy_pat (PArrPat ps ty)+ = unLoc $ mkPrefixConPat (parrFakeCon (length ps))+ (map tidy_lpat ps)+ [ty]++tidy_pat (TuplePat ps boxity tys)+ = unLoc $ mkPrefixConPat (tupleCon (boxityNormalTupleSort boxity) arity)+ (map tidy_lpat ps) tys+ where+ arity = length ps++tidy_pat (NPat (L _ lit) mb_neg eq) = tidyNPat tidy_lit_pat lit mb_neg eq+tidy_pat (LitPat lit) = tidy_lit_pat lit++tidy_pat (ConPatIn {}) = panic "Check.tidy_pat: ConPatIn"+tidy_pat (SplicePat {}) = panic "Check.tidy_pat: SplicePat"+tidy_pat (QuasiQuotePat {}) = panic "Check.tidy_pat: QuasiQuotePat"+tidy_pat (SigPatIn {}) = panic "Check.tidy_pat: SigPatIn"++tidy_lit_pat :: HsLit -> Pat Id+-- Unpack string patterns fully, so we can see when they+-- overlap with each other, or even explicit lists of Chars.+tidy_lit_pat lit+ | HsString src s <- lit+ = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon+ [mkCharLitPat src c, pat] [charTy])+ (mkPrefixConPat nilDataCon [] [charTy]) (unpackFS s)+ | otherwise+ = tidyLitPat lit++-----------------+tidy_con :: ConLike -> HsConPatDetails Id -> HsConPatDetails Id+tidy_con _ (PrefixCon ps) = PrefixCon (map tidy_lpat ps)+tidy_con _ (InfixCon p1 p2) = PrefixCon [tidy_lpat p1, tidy_lpat p2]+tidy_con con (RecCon (HsRecFields fs _))+ | null fs = PrefixCon (replicate arity nlWildPatId)+ -- Special case for null patterns; maybe not a record at all+ | otherwise = PrefixCon (map (tidy_lpat.snd) all_pats)+ where+ arity = case con of+ RealDataCon dcon -> dataConSourceArity dcon+ PatSynCon psyn -> patSynArity psyn++ -- pad out all the missing fields with WildPats.+ field_pats = case con of+ RealDataCon dc -> map (\ f -> (f, nlWildPatId)) (dataConFieldLabels dc)+ PatSynCon{} -> panic "Check.tidy_con: pattern synonym with record syntax"+ all_pats = foldr (\(L _ (HsRecField id p _)) acc+ -> insertNm (getName (unLoc id)) p acc)+ field_pats fs++ insertNm nm p [] = [(nm,p)]+ insertNm nm p (x@(n,_):xs)+ | nm == n = (nm,p):xs+ | otherwise = x : insertNm nm p xs
+ src/Language/Haskell/Liquid/Desugar710/Coverage.hs view
@@ -0,0 +1,1274 @@+{-+(c) Galois, 2006+(c) University of Glasgow, 2007+-}++{-# LANGUAGE NondecreasingIndentation #-}++module Language.Haskell.Liquid.Desugar710.Coverage (addTicksToBinds, hpcInitCode) where++import Type+import HsSyn+import Module+import Outputable+import DynFlags+import Control.Monad+import SrcLoc+import ErrUtils+import NameSet hiding (FreeVars)+import Name+import Bag+import CostCentre+import CoreSyn+import Id+import VarSet+import Data.List+import FastString+import HscTypes+import TyCon+import UniqSupply+import BasicTypes+import MonadUtils+import Maybes+import CLabel+import Util++import Data.Array+import Data.Time+import System.Directory++import Trace.Hpc.Mix+import Trace.Hpc.Util++import BreakArray+import Data.Map (Map)+import qualified Data.Map as Map++{-+************************************************************************+* *+* The main function: addTicksToBinds+* *+************************************************************************+-}++addTicksToBinds+ :: DynFlags+ -> Module+ -> ModLocation -- ... off the current module+ -> NameSet -- Exported Ids. When we call addTicksToBinds,+ -- isExportedId doesn't work yet (the desugarer+ -- hasn't set it), so we have to work from this set.+ -> [TyCon] -- Type constructor in this module+ -> LHsBinds Id+ -> IO (LHsBinds Id, HpcInfo, ModBreaks)++addTicksToBinds dflags mod mod_loc exports tyCons binds+ | let passes = coveragePasses dflags, not (null passes),+ Just orig_file <- ml_hs_file mod_loc = do++ if "boot" `isSuffixOf` orig_file+ then return (binds, emptyHpcInfo False, emptyModBreaks)+ else do++ us <- mkSplitUniqSupply 'C' -- for cost centres+ let orig_file2 = guessSourceFile binds orig_file++ tickPass tickish (binds,st) =+ let env = TTE+ { fileName = mkFastString orig_file2+ , declPath = []+ , tte_dflags = dflags+ , exports = exports+ , inlines = emptyVarSet+ , inScope = emptyVarSet+ , blackList = Map.fromList+ [ (getSrcSpan (tyConName tyCon),())+ | tyCon <- tyCons ]+ , density = mkDensity tickish dflags+ , this_mod = mod+ , tickishType = tickish+ }+ (binds',_,st') = unTM (addTickLHsBinds binds) env st+ in (binds', st')++ initState = TT { tickBoxCount = 0+ , mixEntries = []+ , breakCount = 0+ , breaks = []+ , uniqSupply = us+ }++ (binds1,st) = foldr tickPass (binds, initState) passes++ let tickCount = tickBoxCount st+ hashNo <- writeMixEntries dflags mod tickCount (reverse $ mixEntries st)+ orig_file2+ modBreaks <- mkModBreaks dflags (breakCount st) (reverse $ breaks st)++ when (dopt Opt_D_dump_ticked dflags) $+ log_action dflags dflags SevDump noSrcSpan defaultDumpStyle+ (pprLHsBinds binds1)++ return (binds1, HpcInfo tickCount hashNo, modBreaks)++ | otherwise = return (binds, emptyHpcInfo False, emptyModBreaks)++guessSourceFile :: LHsBinds Id -> FilePath -> FilePath+guessSourceFile binds orig_file =+ -- Try look for a file generated from a .hsc file to a+ -- .hs file, by peeking ahead.+ let top_pos = catMaybes $ foldrBag (\ (L pos _) rest ->+ srcSpanFileName_maybe pos : rest) [] binds+ in+ case top_pos of+ (file_name:_) | ".hsc" `isSuffixOf` unpackFS file_name+ -> unpackFS file_name+ _ -> orig_file+++mkModBreaks :: DynFlags -> Int -> [MixEntry_] -> IO ModBreaks+mkModBreaks dflags count entries = do+ breakArray <- newBreakArray dflags $ length entries+ let+ locsTicks = listArray (0,count-1) [ span | (span,_,_,_) <- entries ]+ varsTicks = listArray (0,count-1) [ vars | (_,_,vars,_) <- entries ]+ declsTicks= listArray (0,count-1) [ decls | (_,decls,_,_) <- entries ]+ modBreaks = emptyModBreaks+ { modBreaks_flags = breakArray+ , modBreaks_locs = locsTicks+ , modBreaks_vars = varsTicks+ , modBreaks_decls = declsTicks+ }+ --+ return modBreaks+++writeMixEntries :: DynFlags -> Module -> Int -> [MixEntry_] -> FilePath -> IO Int+writeMixEntries dflags mod count entries filename+ | not (gopt Opt_Hpc dflags) = return 0+ | otherwise = do+ let+ hpc_dir = hpcDir dflags+ mod_name = moduleNameString (moduleName mod)++ hpc_mod_dir+ | modulePackageKey mod == mainPackageKey = hpc_dir+ | otherwise = hpc_dir ++ "/" ++ packageKeyString (modulePackageKey mod)++ tabStop = 8 -- <tab> counts as a normal char in GHC's location ranges.++ createDirectoryIfMissing True hpc_mod_dir+ modTime <- getModificationUTCTime filename+ let entries' = [ (hpcPos, box)+ | (span,_,_,box) <- entries, hpcPos <- [mkHpcPos span] ]+ when (length entries' /= count) $ do+ panic "the number of .mix entries are inconsistent"+ let hashNo = mixHash filename modTime tabStop entries'+ mixCreate hpc_mod_dir mod_name+ $ Mix filename modTime (toHash hashNo) tabStop entries'+ return hashNo+++-- -----------------------------------------------------------------------------+-- TickDensity: where to insert ticks++data TickDensity+ = TickForCoverage -- for Hpc+ | TickForBreakPoints -- for GHCi+ | TickAllFunctions -- for -prof-auto-all+ | TickTopFunctions -- for -prof-auto-top+ | TickExportedFunctions -- for -prof-auto-exported+ | TickCallSites -- for stack tracing+ deriving Eq++mkDensity :: TickishType -> DynFlags -> TickDensity+mkDensity tickish dflags = case tickish of+ HpcTicks -> TickForCoverage+ SourceNotes -> TickForCoverage+ Breakpoints -> TickForBreakPoints+ ProfNotes ->+ case profAuto dflags of+ ProfAutoAll -> TickAllFunctions+ ProfAutoTop -> TickTopFunctions+ ProfAutoExports -> TickExportedFunctions+ ProfAutoCalls -> TickCallSites+ _other -> panic "mkDensity"++-- | Decide whether to add a tick to a binding or not.+shouldTickBind :: TickDensity+ -> Bool -- top level?+ -> Bool -- exported?+ -> Bool -- simple pat bind?+ -> Bool -- INLINE pragma?+ -> Bool++shouldTickBind density top_lev exported simple_pat inline+ = case density of+ TickForBreakPoints -> not simple_pat+ -- we never add breakpoints to simple pattern bindings+ -- (there's always a tick on the rhs anyway).+ TickAllFunctions -> not inline+ TickTopFunctions -> top_lev && not inline+ TickExportedFunctions -> exported && not inline+ TickForCoverage -> True+ TickCallSites -> False++shouldTickPatBind :: TickDensity -> Bool -> Bool+shouldTickPatBind density top_lev+ = case density of+ TickForBreakPoints -> False+ TickAllFunctions -> True+ TickTopFunctions -> top_lev+ TickExportedFunctions -> False+ TickForCoverage -> False+ TickCallSites -> False++-- -----------------------------------------------------------------------------+-- Adding ticks to bindings++addTickLHsBinds :: LHsBinds Id -> TM (LHsBinds Id)+addTickLHsBinds = mapBagM addTickLHsBind++addTickLHsBind :: LHsBind Id -> TM (LHsBind Id)+addTickLHsBind (L pos bind@(AbsBinds { abs_binds = binds,+ abs_exports = abs_exports })) = do+ withEnv add_exports $ do+ withEnv add_inlines $ do+ binds' <- addTickLHsBinds binds+ return $ L pos $ bind { abs_binds = binds' }+ where+ -- in AbsBinds, the Id on each binding is not the actual top-level+ -- Id that we are defining, they are related by the abs_exports+ -- field of AbsBinds. So if we're doing TickExportedFunctions we need+ -- to add the local Ids to the set of exported Names so that we know to+ -- tick the right bindings.+ add_exports env =+ env{ exports = exports env `extendNameSetList`+ [ idName mid+ | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports+ , idName pid `elemNameSet` (exports env) ] }++ add_inlines env =+ env{ inlines = inlines env `extendVarSetList`+ [ mid+ | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports+ , isAnyInlinePragma (idInlinePragma pid) ] }+++addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id) }))) = do+ let name = getOccString id+ decl_path <- getPathEntry+ density <- getDensity++ inline_ids <- liftM inlines getEnv+ let inline = isAnyInlinePragma (idInlinePragma id)+ || id `elemVarSet` inline_ids++ -- See Note [inline sccs]+ tickish <- tickishType `liftM` getEnv+ if inline && tickish == ProfNotes then return (L pos funBind) else do++ (fvs, mg@(MG { mg_alts = matches' })) <-+ getFreeVars $+ addPathEntry name $+ addTickMatchGroup False (fun_matches funBind)++ blackListed <- isBlackListed pos+ exported_names <- liftM exports getEnv++ -- We don't want to generate code for blacklisted positions+ -- We don't want redundant ticks on simple pattern bindings+ -- We don't want to tick non-exported bindings in TickExportedFunctions+ let simple = isSimplePatBind funBind+ toplev = null decl_path+ exported = idName id `elemNameSet` exported_names++ tick <- if not blackListed &&+ shouldTickBind density toplev exported simple inline+ then+ bindTick density name pos fvs+ else+ return Nothing++ let mbCons = maybe Prelude.id (:)+ return $ L pos $ funBind { fun_matches = mg { mg_alts = matches' }+ , fun_tick = tick `mbCons` fun_tick funBind }++ where+ -- a binding is a simple pattern binding if it is a funbind with zero patterns+ isSimplePatBind :: HsBind a -> Bool+ isSimplePatBind funBind = matchGroupArity (fun_matches funBind) == 0++-- TODO: Revisit this+addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs, pat_rhs = rhs }))) = do+ let name = "(...)"+ (fvs, rhs') <- getFreeVars $ addPathEntry name $ addTickGRHSs False False rhs+ let pat' = pat { pat_rhs = rhs'}++ -- Should create ticks here?+ density <- getDensity+ decl_path <- getPathEntry+ let top_lev = null decl_path+ if not (shouldTickPatBind density top_lev) then return (L pos pat') else do++ -- Allocate the ticks+ rhs_tick <- bindTick density name pos fvs+ let patvars = map getOccString (collectPatBinders lhs)+ patvar_ticks <- mapM (\v -> bindTick density v pos fvs) patvars++ -- Add to pattern+ let mbCons = maybe id (:)+ rhs_ticks = rhs_tick `mbCons` fst (pat_ticks pat')+ patvar_tickss = zipWith mbCons patvar_ticks+ (snd (pat_ticks pat') ++ repeat [])+ return $ L pos $ pat' { pat_ticks = (rhs_ticks, patvar_tickss) }++-- Only internal stuff, not from source, uses VarBind, so we ignore it.+addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind+addTickLHsBind patsyn_bind@(L _ (PatSynBind {})) = return patsyn_bind+++bindTick :: TickDensity -> String -> SrcSpan -> FreeVars -> TM (Maybe (Tickish Id))+bindTick density name pos fvs = do+ decl_path <- getPathEntry+ let+ toplev = null decl_path+ count_entries = toplev || density == TickAllFunctions+ top_only = density /= TickAllFunctions+ box_label = if toplev then TopLevelBox [name]+ else LocalBox (decl_path ++ [name])+ --+ allocATickBox box_label count_entries top_only pos fvs+++-- Note [inline sccs]+--+-- It should be reasonable to add ticks to INLINE functions; however+-- currently this tickles a bug later on because the SCCfinal pass+-- does not look inside unfoldings to find CostCentres. It would be+-- difficult to fix that, because SCCfinal currently works on STG and+-- not Core (and since it also generates CostCentres for CAFs,+-- changing this would be difficult too).+--+-- Another reason not to add ticks to INLINE functions is that this+-- sometimes handy for avoiding adding a tick to a particular function+-- (see #6131)+--+-- So for now we do not add any ticks to INLINE functions at all.++-- -----------------------------------------------------------------------------+-- Decorate an LHsExpr with ticks++-- selectively add ticks to interesting expressions+addTickLHsExpr :: LHsExpr Id -> TM (LHsExpr Id)+addTickLHsExpr e@(L pos e0) = do+ d <- getDensity+ case d of+ TickForBreakPoints | isGoodBreakExpr e0 -> tick_it+ TickForCoverage -> tick_it+ TickCallSites | isCallSite e0 -> tick_it+ _other -> dont_tick_it+ where+ tick_it = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0+ dont_tick_it = addTickLHsExprNever e++-- Add a tick to an expression which is the RHS of an equation or a binding.+-- We always consider these to be breakpoints, unless the expression is a 'let'+-- (because the body will definitely have a tick somewhere). ToDo: perhaps+-- we should treat 'case' and 'if' the same way?+addTickLHsExprRHS :: LHsExpr Id -> TM (LHsExpr Id)+addTickLHsExprRHS e@(L pos e0) = do+ d <- getDensity+ case d of+ TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it+ | otherwise -> tick_it+ TickForCoverage -> tick_it+ TickCallSites | isCallSite e0 -> tick_it+ _other -> dont_tick_it+ where+ tick_it = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0+ dont_tick_it = addTickLHsExprNever e++-- The inner expression of an evaluation context:+-- let binds in [], ( [] )+-- we never tick these if we're doing HPC, but otherwise+-- we treat it like an ordinary expression.+addTickLHsExprEvalInner :: LHsExpr Id -> TM (LHsExpr Id)+addTickLHsExprEvalInner e = do+ d <- getDensity+ case d of+ TickForCoverage -> addTickLHsExprNever e+ _otherwise -> addTickLHsExpr e++-- | A let body is treated differently from addTickLHsExprEvalInner+-- above with TickForBreakPoints, because for breakpoints we always+-- want to tick the body, even if it is not a redex. See test+-- break012. This gives the user the opportunity to inspect the+-- values of the let-bound variables.+addTickLHsExprLetBody :: LHsExpr Id -> TM (LHsExpr Id)+addTickLHsExprLetBody e@(L pos e0) = do+ d <- getDensity+ case d of+ TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it+ | otherwise -> tick_it+ _other -> addTickLHsExprEvalInner e+ where+ tick_it = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0+ dont_tick_it = addTickLHsExprNever e++-- version of addTick that does not actually add a tick,+-- because the scope of this tick is completely subsumed by+-- another.+addTickLHsExprNever :: LHsExpr Id -> TM (LHsExpr Id)+addTickLHsExprNever (L pos e0) = do+ e1 <- addTickHsExpr e0+ return $ L pos e1++-- general heuristic: expressions which do not denote values are good break points+isGoodBreakExpr :: HsExpr Id -> Bool+isGoodBreakExpr (HsApp {}) = True+isGoodBreakExpr (OpApp {}) = True+isGoodBreakExpr (NegApp {}) = True+isGoodBreakExpr (HsIf {}) = True+isGoodBreakExpr (HsMultiIf {}) = True+isGoodBreakExpr (HsCase {}) = True+isGoodBreakExpr (RecordCon {}) = True+isGoodBreakExpr (RecordUpd {}) = True+isGoodBreakExpr (ArithSeq {}) = True+isGoodBreakExpr (PArrSeq {}) = True+isGoodBreakExpr _other = False++isCallSite :: HsExpr Id -> Bool+isCallSite HsApp{} = True+isCallSite OpApp{} = True+isCallSite _ = False++addTickLHsExprOptAlt :: Bool -> LHsExpr Id -> TM (LHsExpr Id)+addTickLHsExprOptAlt oneOfMany (L pos e0)+ = ifDensity TickForCoverage+ (allocTickBox (ExpBox oneOfMany) False False pos $ addTickHsExpr e0)+ (addTickLHsExpr (L pos e0))++addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)+addBinTickLHsExpr boxLabel (L pos e0)+ = ifDensity TickForCoverage+ (allocBinTickBox boxLabel pos $ addTickHsExpr e0)+ (addTickLHsExpr (L pos e0))+++-- -----------------------------------------------------------------------------+-- Decoarate an HsExpr with ticks++addTickHsExpr :: HsExpr Id -> TM (HsExpr Id)+addTickHsExpr e@(HsVar id) = do freeVar id; return e+addTickHsExpr e@(HsIPVar _) = return e+addTickHsExpr e@(HsOverLit _) = return e+addTickHsExpr e@(HsLit _) = return e+addTickHsExpr (HsLam matchgroup) =+ liftM HsLam (addTickMatchGroup True matchgroup)+addTickHsExpr (HsLamCase ty mgs) =+ liftM (HsLamCase ty) (addTickMatchGroup True mgs)+addTickHsExpr (HsApp e1 e2) =+ liftM2 HsApp (addTickLHsExprNever e1) (addTickLHsExpr e2)+addTickHsExpr (OpApp e1 e2 fix e3) =+ liftM4 OpApp+ (addTickLHsExpr e1)+ (addTickLHsExprNever e2)+ (return fix)+ (addTickLHsExpr e3)+addTickHsExpr (NegApp e neg) =+ liftM2 NegApp+ (addTickLHsExpr e)+ (addTickSyntaxExpr hpcSrcSpan neg)+addTickHsExpr (HsPar e) =+ liftM HsPar (addTickLHsExprEvalInner e)+addTickHsExpr (SectionL e1 e2) =+ liftM2 SectionL+ (addTickLHsExpr e1)+ (addTickLHsExprNever e2)+addTickHsExpr (SectionR e1 e2) =+ liftM2 SectionR+ (addTickLHsExprNever e1)+ (addTickLHsExpr e2)+addTickHsExpr (ExplicitTuple es boxity) =+ liftM2 ExplicitTuple+ (mapM addTickTupArg es)+ (return boxity)+addTickHsExpr (HsCase e mgs) =+ liftM2 HsCase+ (addTickLHsExpr e) -- not an EvalInner; e might not necessarily+ -- be evaluated.+ (addTickMatchGroup False mgs)+addTickHsExpr (HsIf cnd e1 e2 e3) =+ liftM3 (HsIf cnd)+ (addBinTickLHsExpr (BinBox CondBinBox) e1)+ (addTickLHsExprOptAlt True e2)+ (addTickLHsExprOptAlt True e3)+addTickHsExpr (HsMultiIf ty alts)+ = do { let isOneOfMany = case alts of [_] -> False; _ -> True+ ; alts' <- mapM (liftL $ addTickGRHS isOneOfMany False) alts+ ; return $ HsMultiIf ty alts' }+addTickHsExpr (HsLet binds e) =+ bindLocals (collectLocalBinders binds) $+ liftM2 HsLet+ (addTickHsLocalBinds binds) -- to think about: !patterns.+ (addTickLHsExprLetBody e)+addTickHsExpr (HsDo cxt stmts srcloc)+ = do { (stmts', _) <- addTickLStmts' forQual stmts (return ())+ ; return (HsDo cxt stmts' srcloc) }+ where+ forQual = case cxt of+ ListComp -> Just $ BinBox QualBinBox+ _ -> Nothing+addTickHsExpr (ExplicitList ty wit es) =+ liftM3 ExplicitList+ (return ty)+ (addTickWit wit)+ (mapM (addTickLHsExpr) es)+ where addTickWit Nothing = return Nothing+ addTickWit (Just fln) = do fln' <- addTickHsExpr fln+ return (Just fln')+addTickHsExpr (ExplicitPArr ty es) =+ liftM2 ExplicitPArr+ (return ty)+ (mapM (addTickLHsExpr) es)++addTickHsExpr (HsStatic e) = HsStatic <$> addTickLHsExpr e++addTickHsExpr (RecordCon id ty rec_binds) =+ liftM3 RecordCon+ (return id)+ (return ty)+ (addTickHsRecordBinds rec_binds)+addTickHsExpr (RecordUpd e rec_binds cons tys1 tys2) =+ liftM5 RecordUpd+ (addTickLHsExpr e)+ (addTickHsRecordBinds rec_binds)+ (return cons) (return tys1) (return tys2)++addTickHsExpr (ExprWithTySigOut e ty) =+ liftM2 ExprWithTySigOut+ (addTickLHsExprNever e) -- No need to tick the inner expression+ -- for expressions with signatures+ (return ty)+addTickHsExpr (ArithSeq ty wit arith_seq) =+ liftM3 ArithSeq+ (return ty)+ (addTickWit wit)+ (addTickArithSeqInfo arith_seq)+ where addTickWit Nothing = return Nothing+ addTickWit (Just fl) = do fl' <- addTickHsExpr fl+ return (Just fl')++-- We might encounter existing ticks (multiple Coverage passes)+addTickHsExpr (HsTick t e) =+ liftM (HsTick t) (addTickLHsExprNever e)+addTickHsExpr (HsBinTick t0 t1 e) =+ liftM (HsBinTick t0 t1) (addTickLHsExprNever e)++addTickHsExpr (HsTickPragma _ _ (L pos e0)) = do+ e2 <- allocTickBox (ExpBox False) False False pos $+ addTickHsExpr e0+ return $ unLoc e2+addTickHsExpr (PArrSeq ty arith_seq) =+ liftM2 PArrSeq+ (return ty)+ (addTickArithSeqInfo arith_seq)+addTickHsExpr (HsSCC src nm e) =+ liftM3 HsSCC+ (return src)+ (return nm)+ (addTickLHsExpr e)+addTickHsExpr (HsCoreAnn src nm e) =+ liftM3 HsCoreAnn+ (return src)+ (return nm)+ (addTickLHsExpr e)+addTickHsExpr e@(HsBracket {}) = return e+addTickHsExpr e@(HsTcBracketOut {}) = return e+addTickHsExpr e@(HsRnBracketOut {}) = return e+addTickHsExpr e@(HsSpliceE {}) = return e+addTickHsExpr (HsProc pat cmdtop) =+ liftM2 HsProc+ (addTickLPat pat)+ (liftL (addTickHsCmdTop) cmdtop)+addTickHsExpr (HsWrap w e) =+ liftM2 HsWrap+ (return w)+ (addTickHsExpr e) -- explicitly no tick on inside++addTickHsExpr e@(HsType _) = return e+addTickHsExpr (HsUnboundVar {}) = panic "addTickHsExpr.HsUnboundVar"++-- Others dhould never happen in expression content.+addTickHsExpr e = pprPanic "addTickHsExpr" (ppr e)++addTickTupArg :: LHsTupArg Id -> TM (LHsTupArg Id)+addTickTupArg (L l (Present e)) = do { e' <- addTickLHsExpr e+ ; return (L l (Present e')) }+addTickTupArg (L l (Missing ty)) = return (L l (Missing ty))++addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup Id (LHsExpr Id) -> TM (MatchGroup Id (LHsExpr Id))+addTickMatchGroup is_lam mg@(MG { mg_alts = matches }) = do+ let isOneOfMany = matchesOneOfMany matches+ matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches+ return $ mg { mg_alts = matches' }++addTickMatch :: Bool -> Bool -> Match Id (LHsExpr Id) -> TM (Match Id (LHsExpr Id))+addTickMatch isOneOfMany isLambda (Match mf pats opSig gRHSs) =+ bindLocals (collectPatsBinders pats) $ do+ gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs+ return $ Match mf pats opSig gRHSs'++addTickGRHSs :: Bool -> Bool -> GRHSs Id (LHsExpr Id) -> TM (GRHSs Id (LHsExpr Id))+addTickGRHSs isOneOfMany isLambda (GRHSs guarded local_binds) = do+ bindLocals binders $ do+ local_binds' <- addTickHsLocalBinds local_binds+ guarded' <- mapM (liftL (addTickGRHS isOneOfMany isLambda)) guarded+ return $ GRHSs guarded' local_binds'+ where+ binders = collectLocalBinders local_binds++addTickGRHS :: Bool -> Bool -> GRHS Id (LHsExpr Id) -> TM (GRHS Id (LHsExpr Id))+addTickGRHS isOneOfMany isLambda (GRHS stmts expr) = do+ (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts+ (addTickGRHSBody isOneOfMany isLambda expr)+ return $ GRHS stmts' expr'++addTickGRHSBody :: Bool -> Bool -> LHsExpr Id -> TM (LHsExpr Id)+addTickGRHSBody isOneOfMany isLambda expr@(L pos e0) = do+ d <- getDensity+ case d of+ TickForCoverage -> addTickLHsExprOptAlt isOneOfMany expr+ TickAllFunctions | isLambda ->+ addPathEntry "\\" $+ allocTickBox (ExpBox False) True{-count-} False{-not top-} pos $+ addTickHsExpr e0+ _otherwise ->+ addTickLHsExprRHS expr++addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt Id] -> TM [ExprLStmt Id]+addTickLStmts isGuard stmts = do+ (stmts, _) <- addTickLStmts' isGuard stmts (return ())+ return stmts++addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt Id] -> TM a+ -> TM ([ExprLStmt Id], a)+addTickLStmts' isGuard lstmts res+ = bindLocals (collectLStmtsBinders lstmts) $+ do { lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts+ ; a <- res+ ; return (lstmts', a) }++addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id (LHsExpr Id) -> TM (Stmt Id (LHsExpr Id))+addTickStmt _isGuard (LastStmt e ret) = do+ liftM2 LastStmt+ (addTickLHsExpr e)+ (addTickSyntaxExpr hpcSrcSpan ret)+addTickStmt _isGuard (BindStmt pat e bind fail) = do+ liftM4 BindStmt+ (addTickLPat pat)+ (addTickLHsExprRHS e)+ (addTickSyntaxExpr hpcSrcSpan bind)+ (addTickSyntaxExpr hpcSrcSpan fail)+addTickStmt isGuard (BodyStmt e bind' guard' ty) = do+ liftM4 BodyStmt+ (addTick isGuard e)+ (addTickSyntaxExpr hpcSrcSpan bind')+ (addTickSyntaxExpr hpcSrcSpan guard')+ (return ty)+addTickStmt _isGuard (LetStmt binds) = do+ liftM LetStmt+ (addTickHsLocalBinds binds)+addTickStmt isGuard (ParStmt pairs mzipExpr bindExpr) = do+ liftM3 ParStmt+ (mapM (addTickStmtAndBinders isGuard) pairs)+ (addTickSyntaxExpr hpcSrcSpan mzipExpr)+ (addTickSyntaxExpr hpcSrcSpan bindExpr)++addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts+ , trS_by = by, trS_using = using+ , trS_ret = returnExpr, trS_bind = bindExpr+ , trS_fmap = liftMExpr }) = do+ t_s <- addTickLStmts isGuard stmts+ t_y <- fmapMaybeM addTickLHsExprRHS by+ t_u <- addTickLHsExprRHS using+ t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr+ t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr+ t_m <- addTickSyntaxExpr hpcSrcSpan liftMExpr+ return $ stmt { trS_stmts = t_s, trS_by = t_y, trS_using = t_u+ , trS_ret = t_f, trS_bind = t_b, trS_fmap = t_m }++addTickStmt isGuard stmt@(RecStmt {})+ = do { stmts' <- addTickLStmts isGuard (recS_stmts stmt)+ ; ret' <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)+ ; mfix' <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt)+ ; bind' <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)+ ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret'+ , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }++addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)+addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e+ | otherwise = addTickLHsExprRHS e++addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock Id Id+ -> TM (ParStmtBlock Id Id)+addTickStmtAndBinders isGuard (ParStmtBlock stmts ids returnExpr) =+ liftM3 ParStmtBlock+ (addTickLStmts isGuard stmts)+ (return ids)+ (addTickSyntaxExpr hpcSrcSpan returnExpr)++addTickHsLocalBinds :: HsLocalBinds Id -> TM (HsLocalBinds Id)+addTickHsLocalBinds (HsValBinds binds) =+ liftM HsValBinds+ (addTickHsValBinds binds)+addTickHsLocalBinds (HsIPBinds binds) =+ liftM HsIPBinds+ (addTickHsIPBinds binds)+addTickHsLocalBinds (EmptyLocalBinds) = return EmptyLocalBinds++addTickHsValBinds :: HsValBindsLR Id a -> TM (HsValBindsLR Id b)+addTickHsValBinds (ValBindsOut binds sigs) =+ liftM2 ValBindsOut+ (mapM (\ (rec,binds') ->+ liftM2 (,)+ (return rec)+ (addTickLHsBinds binds'))+ binds)+ (return sigs)+addTickHsValBinds _ = panic "addTickHsValBinds"++addTickHsIPBinds :: HsIPBinds Id -> TM (HsIPBinds Id)+addTickHsIPBinds (IPBinds ipbinds dictbinds) =+ liftM2 IPBinds+ (mapM (liftL (addTickIPBind)) ipbinds)+ (return dictbinds)++addTickIPBind :: IPBind Id -> TM (IPBind Id)+addTickIPBind (IPBind nm e) =+ liftM2 IPBind+ (return nm)+ (addTickLHsExpr e)++-- There is no location here, so we might need to use a context location??+addTickSyntaxExpr :: SrcSpan -> SyntaxExpr Id -> TM (SyntaxExpr Id)+addTickSyntaxExpr pos x = do+ L _ x' <- addTickLHsExpr (L pos x)+ return $ x'+-- we do not walk into patterns.+addTickLPat :: LPat Id -> TM (LPat Id)+addTickLPat pat = return pat++addTickHsCmdTop :: HsCmdTop Id -> TM (HsCmdTop Id)+addTickHsCmdTop (HsCmdTop cmd tys ty syntaxtable) =+ liftM4 HsCmdTop+ (addTickLHsCmd cmd)+ (return tys)+ (return ty)+ (return syntaxtable)++addTickLHsCmd :: LHsCmd Id -> TM (LHsCmd Id)+addTickLHsCmd (L pos c0) = do+ c1 <- addTickHsCmd c0+ return $ L pos c1++addTickHsCmd :: HsCmd Id -> TM (HsCmd Id)+addTickHsCmd (HsCmdLam matchgroup) =+ liftM HsCmdLam (addTickCmdMatchGroup matchgroup)+addTickHsCmd (HsCmdApp c e) =+ liftM2 HsCmdApp (addTickLHsCmd c) (addTickLHsExpr e)+{-+addTickHsCmd (OpApp e1 c2 fix c3) =+ liftM4 OpApp+ (addTickLHsExpr e1)+ (addTickLHsCmd c2)+ (return fix)+ (addTickLHsCmd c3)+-}+addTickHsCmd (HsCmdPar e) = liftM HsCmdPar (addTickLHsCmd e)+addTickHsCmd (HsCmdCase e mgs) =+ liftM2 HsCmdCase+ (addTickLHsExpr e)+ (addTickCmdMatchGroup mgs)+addTickHsCmd (HsCmdIf cnd e1 c2 c3) =+ liftM3 (HsCmdIf cnd)+ (addBinTickLHsExpr (BinBox CondBinBox) e1)+ (addTickLHsCmd c2)+ (addTickLHsCmd c3)+addTickHsCmd (HsCmdLet binds c) =+ bindLocals (collectLocalBinders binds) $+ liftM2 HsCmdLet+ (addTickHsLocalBinds binds) -- to think about: !patterns.+ (addTickLHsCmd c)+addTickHsCmd (HsCmdDo stmts srcloc)+ = do { (stmts', _) <- addTickLCmdStmts' stmts (return ())+ ; return (HsCmdDo stmts' srcloc) }++addTickHsCmd (HsCmdArrApp e1 e2 ty1 arr_ty lr) =+ liftM5 HsCmdArrApp+ (addTickLHsExpr e1)+ (addTickLHsExpr e2)+ (return ty1)+ (return arr_ty)+ (return lr)+addTickHsCmd (HsCmdArrForm e fix cmdtop) =+ liftM3 HsCmdArrForm+ (addTickLHsExpr e)+ (return fix)+ (mapM (liftL (addTickHsCmdTop)) cmdtop)++addTickHsCmd (HsCmdCast co cmd)+ = liftM2 HsCmdCast (return co) (addTickHsCmd cmd)++-- Others should never happen in a command context.+--addTickHsCmd e = pprPanic "addTickHsCmd" (ppr e)++addTickCmdMatchGroup :: MatchGroup Id (LHsCmd Id) -> TM (MatchGroup Id (LHsCmd Id))+addTickCmdMatchGroup mg@(MG { mg_alts = matches }) = do+ matches' <- mapM (liftL addTickCmdMatch) matches+ return $ mg { mg_alts = matches' }++addTickCmdMatch :: Match Id (LHsCmd Id) -> TM (Match Id (LHsCmd Id))+addTickCmdMatch (Match mf pats opSig gRHSs) =+ bindLocals (collectPatsBinders pats) $ do+ gRHSs' <- addTickCmdGRHSs gRHSs+ return $ Match mf pats opSig gRHSs'++addTickCmdGRHSs :: GRHSs Id (LHsCmd Id) -> TM (GRHSs Id (LHsCmd Id))+addTickCmdGRHSs (GRHSs guarded local_binds) = do+ bindLocals binders $ do+ local_binds' <- addTickHsLocalBinds local_binds+ guarded' <- mapM (liftL addTickCmdGRHS) guarded+ return $ GRHSs guarded' local_binds'+ where+ binders = collectLocalBinders local_binds++addTickCmdGRHS :: GRHS Id (LHsCmd Id) -> TM (GRHS Id (LHsCmd Id))+-- The *guards* are *not* Cmds, although the body is+-- C.f. addTickGRHS for the BinBox stuff+addTickCmdGRHS (GRHS stmts cmd)+ = do { (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox)+ stmts (addTickLHsCmd cmd)+ ; return $ GRHS stmts' expr' }++addTickLCmdStmts :: [LStmt Id (LHsCmd Id)] -> TM [LStmt Id (LHsCmd Id)]+addTickLCmdStmts stmts = do+ (stmts, _) <- addTickLCmdStmts' stmts (return ())+ return stmts++addTickLCmdStmts' :: [LStmt Id (LHsCmd Id)] -> TM a -> TM ([LStmt Id (LHsCmd Id)], a)+addTickLCmdStmts' lstmts res+ = bindLocals binders $ do+ lstmts' <- mapM (liftL addTickCmdStmt) lstmts+ a <- res+ return (lstmts', a)+ where+ binders = collectLStmtsBinders lstmts++addTickCmdStmt :: Stmt Id (LHsCmd Id) -> TM (Stmt Id (LHsCmd Id))+addTickCmdStmt (BindStmt pat c bind fail) = do+ liftM4 BindStmt+ (addTickLPat pat)+ (addTickLHsCmd c)+ (return bind)+ (return fail)+addTickCmdStmt (LastStmt c ret) = do+ liftM2 LastStmt+ (addTickLHsCmd c)+ (addTickSyntaxExpr hpcSrcSpan ret)+addTickCmdStmt (BodyStmt c bind' guard' ty) = do+ liftM4 BodyStmt+ (addTickLHsCmd c)+ (addTickSyntaxExpr hpcSrcSpan bind')+ (addTickSyntaxExpr hpcSrcSpan guard')+ (return ty)+addTickCmdStmt (LetStmt binds) = do+ liftM LetStmt+ (addTickHsLocalBinds binds)+addTickCmdStmt stmt@(RecStmt {})+ = do { stmts' <- addTickLCmdStmts (recS_stmts stmt)+ ; ret' <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)+ ; mfix' <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt)+ ; bind' <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)+ ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret'+ , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }++-- Others should never happen in a command context.+addTickCmdStmt stmt = pprPanic "addTickHsCmd" (ppr stmt)++addTickHsRecordBinds :: HsRecordBinds Id -> TM (HsRecordBinds Id)+addTickHsRecordBinds (HsRecFields fields dd)+ = do { fields' <- mapM process fields+ ; return (HsRecFields fields' dd) }+ where+ process (L l (HsRecField ids expr doc))+ = do { expr' <- addTickLHsExpr expr+ ; return (L l (HsRecField ids expr' doc)) }++addTickArithSeqInfo :: ArithSeqInfo Id -> TM (ArithSeqInfo Id)+addTickArithSeqInfo (From e1) =+ liftM From+ (addTickLHsExpr e1)+addTickArithSeqInfo (FromThen e1 e2) =+ liftM2 FromThen+ (addTickLHsExpr e1)+ (addTickLHsExpr e2)+addTickArithSeqInfo (FromTo e1 e2) =+ liftM2 FromTo+ (addTickLHsExpr e1)+ (addTickLHsExpr e2)+addTickArithSeqInfo (FromThenTo e1 e2 e3) =+ liftM3 FromThenTo+ (addTickLHsExpr e1)+ (addTickLHsExpr e2)+ (addTickLHsExpr e3)++liftL :: (Monad m) => (a -> m a) -> Located a -> m (Located a)+liftL f (L loc a) = do+ a' <- f a+ return $ L loc a'++data TickTransState = TT { tickBoxCount:: Int+ , mixEntries :: [MixEntry_]+ , breakCount :: Int+ , breaks :: [MixEntry_]+ , uniqSupply :: UniqSupply+ }++data TickTransEnv = TTE { fileName :: FastString+ , density :: TickDensity+ , tte_dflags :: DynFlags+ , exports :: NameSet+ , inlines :: VarSet+ , declPath :: [String]+ , inScope :: VarSet+ , blackList :: Map SrcSpan ()+ , this_mod :: Module+ , tickishType :: TickishType+ }++-- deriving Show++data TickishType = ProfNotes | HpcTicks | Breakpoints | SourceNotes+ deriving (Eq)++coveragePasses :: DynFlags -> [TickishType]+coveragePasses dflags =+ ifa (hscTarget dflags == HscInterpreted) Breakpoints $+ ifa (gopt Opt_Hpc dflags) HpcTicks $+ ifa (gopt Opt_SccProfilingOn dflags &&+ profAuto dflags /= NoProfAuto) ProfNotes $+ ifa (gopt Opt_Debug dflags) SourceNotes []+ where ifa f x xs | f = x:xs+ | otherwise = xs++-- | Tickishs that only make sense when their source code location+-- refers to the current file. This might not always be true due to+-- LINE pragmas in the code - which would confuse at least HPC.+tickSameFileOnly :: TickishType -> Bool+tickSameFileOnly HpcTicks = True+tickSameFileOnly _other = False++type FreeVars = OccEnv Id+noFVs :: FreeVars+noFVs = emptyOccEnv++-- Note [freevars]+-- For breakpoints we want to collect the free variables of an+-- expression for pinning on the HsTick. We don't want to collect+-- *all* free variables though: in particular there's no point pinning+-- on free variables that are will otherwise be in scope at the GHCi+-- prompt, which means all top-level bindings. Unfortunately detecting+-- top-level bindings isn't easy (collectHsBindsBinders on the top-level+-- bindings doesn't do it), so we keep track of a set of "in-scope"+-- variables in addition to the free variables, and the former is used+-- to filter additions to the latter. This gives us complete control+-- over what free variables we track.++data TM a = TM { unTM :: TickTransEnv -> TickTransState -> (a,FreeVars,TickTransState) }+ -- a combination of a state monad (TickTransState) and a writer+ -- monad (FreeVars).++instance Functor TM where+ fmap = liftM++instance Applicative TM where+ pure = return+ (<*>) = ap++instance Monad TM where+ return a = TM $ \ _env st -> (a,noFVs,st)+ (TM m) >>= k = TM $ \ env st ->+ case m env st of+ (r1,fv1,st1) ->+ case unTM (k r1) env st1 of+ (r2,fv2,st2) ->+ (r2, fv1 `plusOccEnv` fv2, st2)++instance HasDynFlags TM where+ getDynFlags = TM $ \ env st -> (tte_dflags env, noFVs, st)++instance MonadUnique TM where+ getUniqueSupplyM = TM $ \_ st -> (uniqSupply st, noFVs, st)+ getUniqueM = TM $ \_ st -> let (u, us') = takeUniqFromSupply (uniqSupply st)+ in (u, noFVs, st { uniqSupply = us' })++getState :: TM TickTransState+getState = TM $ \ _ st -> (st, noFVs, st)++setState :: (TickTransState -> TickTransState) -> TM ()+setState f = TM $ \ _ st -> ((), noFVs, f st)++getEnv :: TM TickTransEnv+getEnv = TM $ \ env st -> (env, noFVs, st)++withEnv :: (TickTransEnv -> TickTransEnv) -> TM a -> TM a+withEnv f (TM m) = TM $ \ env st ->+ case m (f env) st of+ (a, fvs, st') -> (a, fvs, st')++getDensity :: TM TickDensity+getDensity = TM $ \env st -> (density env, noFVs, st)++ifDensity :: TickDensity -> TM a -> TM a -> TM a+ifDensity d th el = do d0 <- getDensity; if d == d0 then th else el++getFreeVars :: TM a -> TM (FreeVars, a)+getFreeVars (TM m)+ = TM $ \ env st -> case m env st of (a, fv, st') -> ((fv,a), fv, st')++freeVar :: Id -> TM ()+freeVar id = TM $ \ env st ->+ if id `elemVarSet` inScope env+ then ((), unitOccEnv (nameOccName (idName id)) id, st)+ else ((), noFVs, st)++addPathEntry :: String -> TM a -> TM a+addPathEntry nm = withEnv (\ env -> env { declPath = declPath env ++ [nm] })++getPathEntry :: TM [String]+getPathEntry = declPath `liftM` getEnv++getFileName :: TM FastString+getFileName = fileName `liftM` getEnv++isGoodSrcSpan' :: SrcSpan -> Bool+isGoodSrcSpan' pos@(RealSrcSpan _) = srcSpanStart pos /= srcSpanEnd pos+isGoodSrcSpan' (UnhelpfulSpan _) = False++isGoodTickSrcSpan :: SrcSpan -> TM Bool+isGoodTickSrcSpan pos = do+ file_name <- getFileName+ tickish <- tickishType `liftM` getEnv+ let need_same_file = tickSameFileOnly tickish+ same_file = Just file_name == srcSpanFileName_maybe pos+ return (isGoodSrcSpan' pos && (not need_same_file || same_file))++ifGoodTickSrcSpan :: SrcSpan -> TM a -> TM a -> TM a+ifGoodTickSrcSpan pos then_code else_code = do+ good <- isGoodTickSrcSpan pos+ if good then then_code else else_code++bindLocals :: [Id] -> TM a -> TM a+bindLocals new_ids (TM m)+ = TM $ \ env st ->+ case m env{ inScope = inScope env `extendVarSetList` new_ids } st of+ (r, fv, st') -> (r, fv `delListFromOccEnv` occs, st')+ where occs = [ nameOccName (idName id) | id <- new_ids ]++isBlackListed :: SrcSpan -> TM Bool+isBlackListed pos = TM $ \ env st ->+ case Map.lookup pos (blackList env) of+ Nothing -> (False,noFVs,st)+ Just () -> (True,noFVs,st)++-- the tick application inherits the source position of its+-- expression argument to support nested box allocations+allocTickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> TM (HsExpr Id)+ -> TM (LHsExpr Id)+allocTickBox boxLabel countEntries topOnly pos m =+ ifGoodTickSrcSpan pos (do+ (fvs, e) <- getFreeVars m+ env <- getEnv+ tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env)+ return (L pos (HsTick tickish (L pos e)))+ ) (do+ e <- m+ return (L pos e)+ )++-- the tick application inherits the source position of its+-- expression argument to support nested box allocations+allocATickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> FreeVars+ -> TM (Maybe (Tickish Id))+allocATickBox boxLabel countEntries topOnly pos fvs =+ ifGoodTickSrcSpan pos (do+ let+ mydecl_path = case boxLabel of+ TopLevelBox x -> x+ LocalBox xs -> xs+ _ -> panic "allocATickBox"+ tickish <- mkTickish boxLabel countEntries topOnly pos fvs mydecl_path+ return (Just tickish)+ ) (return Nothing)+++mkTickish :: BoxLabel -> Bool -> Bool -> SrcSpan -> OccEnv Id -> [String]+ -> TM (Tickish Id)+mkTickish boxLabel countEntries topOnly pos fvs decl_path = do++ let ids = filter (not . isUnLiftedType . idType) $ occEnvElts fvs+ -- unlifted types cause two problems here:+ -- * we can't bind them at the GHCi prompt+ -- (bindLocalsAtBreakpoint already fliters them out),+ -- * the simplifier might try to substitute a literal for+ -- the Id, and we can't handle that.++ me = (pos, decl_path, map (nameOccName.idName) ids, boxLabel)++ cc_name | topOnly = head decl_path+ | otherwise = concat (intersperse "." decl_path)++ dflags <- getDynFlags+ env <- getEnv+ case tickishType env of+ HpcTicks -> do+ c <- liftM tickBoxCount getState+ setState $ \st -> st { tickBoxCount = c + 1+ , mixEntries = me : mixEntries st }+ return $ HpcTick (this_mod env) c++ ProfNotes -> do+ ccUnique <- getUniqueM+ let cc = mkUserCC (mkFastString cc_name) (this_mod env) pos ccUnique+ count = countEntries && gopt Opt_ProfCountEntries dflags+ return $ ProfNote cc count True{-scopes-}++ Breakpoints -> do+ c <- liftM breakCount getState+ setState $ \st -> st { breakCount = c + 1+ , breaks = me:breaks st }+ return $ Breakpoint c ids++ SourceNotes | RealSrcSpan pos' <- pos ->+ return $ SourceNote pos' cc_name++ _otherwise -> panic "mkTickish: bad source span!"+++allocBinTickBox :: (Bool -> BoxLabel) -> SrcSpan -> TM (HsExpr Id)+ -> TM (LHsExpr Id)+allocBinTickBox boxLabel pos m = do+ env <- getEnv+ case tickishType env of+ HpcTicks -> do e <- liftM (L pos) m+ ifGoodTickSrcSpan pos+ (mkBinTickBoxHpc boxLabel pos e)+ (return e)+ _other -> allocTickBox (ExpBox False) False False pos m++mkBinTickBoxHpc :: (Bool -> BoxLabel) -> SrcSpan -> LHsExpr Id+ -> TM (LHsExpr Id)+mkBinTickBoxHpc boxLabel pos e =+ TM $ \ env st ->+ let meT = (pos,declPath env, [],boxLabel True)+ meF = (pos,declPath env, [],boxLabel False)+ meE = (pos,declPath env, [],ExpBox False)+ c = tickBoxCount st+ mes = mixEntries st+ in+ ( L pos $ HsTick (HpcTick (this_mod env) c) $ L pos $ HsBinTick (c+1) (c+2) e+ -- notice that F and T are reversed,+ -- because we are building the list in+ -- reverse...+ , noFVs+ , st {tickBoxCount=c+3 , mixEntries=meF:meT:meE:mes}+ )++mkHpcPos :: SrcSpan -> HpcPos+mkHpcPos pos@(RealSrcSpan s)+ | isGoodSrcSpan' pos = toHpcPos (srcSpanStartLine s,+ srcSpanStartCol s,+ srcSpanEndLine s,+ srcSpanEndCol s - 1)+ -- the end column of a SrcSpan is one+ -- greater than the last column of the+ -- span (see SrcLoc), whereas HPC+ -- expects to the column range to be+ -- inclusive, hence we subtract one above.+mkHpcPos _ = panic "bad source span; expected such spans to be filtered out"++hpcSrcSpan :: SrcSpan+hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals")++matchesOneOfMany :: [LMatch Id body] -> Bool+matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1+ where+ matchCount (L _ (Match _ _pats _ty (GRHSs grhss _binds))) = length grhss++type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel)++-- For the hash value, we hash everything: the file name,+-- the timestamp of the original source file, the tab stop,+-- and the mix entries. We cheat, and hash the show'd string.+-- This hash only has to be hashed at Mix creation time,+-- and is for sanity checking only.++mixHash :: FilePath -> UTCTime -> Int -> [MixEntry] -> Int+mixHash file tm tabstop entries = fromIntegral $ hashString+ (show $ Mix file tm 0 tabstop entries)++{-+************************************************************************+* *+* initialisation+* *+************************************************************************++Each module compiled with -fhpc declares an initialisation function of+the form `hpc_init_<module>()`, which is emitted into the _stub.c file+and annotated with __attribute__((constructor)) so that it gets+executed at startup time.++The function's purpose is to call hs_hpc_module to register this+module with the RTS, and it looks something like this:++static void hpc_init_Main(void) __attribute__((constructor));+static void hpc_init_Main(void)+{extern StgWord64 _hpc_tickboxes_Main_hpc[];+ hs_hpc_module("Main",8,1150288664,_hpc_tickboxes_Main_hpc);}+-}++hpcInitCode :: Module -> HpcInfo -> SDoc+hpcInitCode _ (NoHpcInfo {}) = Outputable.empty+hpcInitCode this_mod (HpcInfo tickCount hashNo)+ = vcat+ [ text "static void hpc_init_" <> ppr this_mod+ <> text "(void) __attribute__((constructor));"+ , text "static void hpc_init_" <> ppr this_mod <> text "(void)"+ , braces (vcat [+ ptext (sLit "extern StgWord64 ") <> tickboxes <>+ ptext (sLit "[]") <> semi,+ ptext (sLit "hs_hpc_module") <>+ parens (hcat (punctuate comma [+ doubleQuotes full_name_str,+ int tickCount, -- really StgWord32+ int hashNo, -- really StgWord32+ tickboxes+ ])) <> semi+ ])+ ]+ where+ tickboxes = ppr (mkHpcTicksLabel $ this_mod)++ module_name = hcat (map (text.charToC) $+ bytesFS (moduleNameFS (Module.moduleName this_mod)))+ package_name = hcat (map (text.charToC) $+ bytesFS (packageKeyFS (modulePackageKey this_mod)))+ full_name_str+ | modulePackageKey this_mod == mainPackageKey+ = module_name+ | otherwise+ = package_name <> char '/' <> module_name
+ src/Language/Haskell/Liquid/Desugar710/Desugar.hs view
@@ -0,0 +1,484 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++The Desugarer: turning HsSyn into Core.+-}++{-# LANGUAGE CPP #-}++module Language.Haskell.Liquid.Desugar710.Desugar ( deSugarWithLoc, deSugar, deSugarExpr ) where++import DynFlags+import HscTypes+import HsSyn+import TcRnTypes+import TcRnMonad ( finalSafeMode )+import MkIface+import Id+import Name+import Type+import FamInstEnv+import Coercion+import InstEnv+import Class+import Avail+import CoreSyn+import CoreSubst+import PprCore+import DsMonad+import Language.Haskell.Liquid.Desugar710.DsExpr+import Language.Haskell.Liquid.Desugar710.DsBinds+import Language.Haskell.Liquid.Desugar710.DsForeign+import Module+import NameSet+import NameEnv+import Rules+import TysPrim (eqReprPrimTyCon)+import TysWiredIn (coercibleTyCon )+import BasicTypes ( Activation(.. ) )+import CoreMonad ( CoreToDo(..) )+import CoreLint ( endPassIO )+import MkCore+import FastString+import ErrUtils+import Outputable+import SrcLoc+import Coverage+import Util+import MonadUtils+import OrdList+import StaticPtrTable+import Data.List+import Data.IORef+import Control.Monad( when )++{-+************************************************************************+* *+* The main function: deSugar+* *+************************************************************************+-}++-- | Main entry point to the desugarer.+deSugarWithLoc, deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts)+-- Can modify PCS by faulting in more declarations++deSugarWithLoc = deSugar ++deSugar hsc_env+ mod_loc+ tcg_env@(TcGblEnv { tcg_mod = mod,+ tcg_src = hsc_src,+ tcg_type_env = type_env,+ tcg_imports = imports,+ tcg_exports = exports,+ tcg_keep = keep_var,+ tcg_th_splice_used = tc_splice_used,+ tcg_rdr_env = rdr_env,+ tcg_fix_env = fix_env,+ tcg_inst_env = inst_env,+ tcg_fam_inst_env = fam_inst_env,+ tcg_warns = warns,+ tcg_anns = anns,+ tcg_binds = binds,+ tcg_imp_specs = imp_specs,+ tcg_dependent_files = dependent_files,+ tcg_ev_binds = ev_binds,+ tcg_fords = fords,+ tcg_rules = rules,+ tcg_vects = vects,+ tcg_patsyns = patsyns,+ tcg_tcs = tcs,+ tcg_insts = insts,+ tcg_fam_insts = fam_insts,+ tcg_hpc = other_hpc_info})++ = do { let dflags = hsc_dflags hsc_env+ print_unqual = mkPrintUnqualified dflags rdr_env+ ; showPass dflags "Desugar"++ -- Desugar the program+ ; let export_set = availsToNameSet exports+ target = hscTarget dflags+ hpcInfo = emptyHpcInfo other_hpc_info++ ; (binds_cvr, ds_hpc_info, modBreaks)+ <- if not (isHsBootOrSig hsc_src)+ then addTicksToBinds dflags mod mod_loc export_set+ (typeEnvTyCons type_env) binds+ else return (binds, hpcInfo, emptyModBreaks)++ ; (msgs, mb_res) <- initDs hsc_env mod rdr_env type_env fam_inst_env $+ do { ds_ev_binds <- dsEvBinds ev_binds+ ; core_prs <- dsTopLHsBinds binds_cvr+ ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs+ ; (ds_fords, foreign_prs) <- dsForeigns fords+ ; ds_rules <- mapMaybeM dsRule rules+ ; ds_vects <- mapM dsVect vects+ ; stBinds <- dsGetStaticBindsVar >>=+ liftIO . readIORef+ ; let hpc_init+ | gopt Opt_Hpc dflags = hpcInitCode mod ds_hpc_info+ | otherwise = empty+ -- Stub to insert the static entries of the+ -- module into the static pointer table+ spt_init = sptInitCode mod stBinds+ ; return ( ds_ev_binds+ , foreign_prs `appOL` core_prs `appOL` spec_prs+ `appOL` toOL (map snd stBinds)+ , spec_rules ++ ds_rules, ds_vects+ , ds_fords `appendStubC` hpc_init+ `appendStubC` spt_init) }++ ; case mb_res of {+ Nothing -> return (msgs, Nothing) ;+ Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords) -> do++ do { -- Add export flags to bindings+ keep_alive <- readIORef keep_var+ ; let (rules_for_locals, rules_for_imps) = partition isLocalRule all_rules+ final_prs = addExportFlagsAndRules target export_set keep_alive+ rules_for_locals (fromOL all_prs)++ final_pgm = combineEvBinds ds_ev_binds final_prs+ -- Notice that we put the whole lot in a big Rec, even the foreign binds+ -- When compiling PrelFloat, which defines data Float = F# Float#+ -- we want F# to be in scope in the foreign marshalling code!+ -- You might think it doesn't matter, but the simplifier brings all top-level+ -- things into the in-scope set before simplifying; so we get no unfolding for F#!++ ; (ds_binds, ds_rules_for_imps, ds_vects)+ <- simpleOptPgm dflags mod final_pgm rules_for_imps vects0+ -- The simpleOptPgm gets rid of type+ -- bindings plus any stupid dead code++ ; endPassIO hsc_env print_unqual CoreDesugarOpt ds_binds ds_rules_for_imps++ ; let used_names = mkUsedNames tcg_env+ ; deps <- mkDependencies tcg_env++ ; used_th <- readIORef tc_splice_used+ ; dep_files <- readIORef dependent_files+ ; safe_mode <- finalSafeMode dflags tcg_env++ ; let mod_guts = ModGuts {+ mg_module = mod,+ mg_boot = hsc_src == HsBootFile,+ mg_exports = exports,+ mg_deps = deps,+ mg_used_names = used_names,+ mg_used_th = used_th,+ mg_dir_imps = imp_mods imports,+ mg_rdr_env = rdr_env,+ mg_fix_env = fix_env,+ mg_warns = warns,+ mg_anns = anns,+ mg_tcs = tcs,+ mg_insts = insts,+ mg_fam_insts = fam_insts,+ mg_inst_env = inst_env,+ mg_fam_inst_env = fam_inst_env,+ mg_patsyns = patsyns,+ mg_rules = ds_rules_for_imps,+ mg_binds = ds_binds,+ mg_foreign = ds_fords,+ mg_hpc_info = ds_hpc_info,+ mg_modBreaks = modBreaks,+ mg_vect_decls = ds_vects,+ mg_vect_info = noVectInfo,+ mg_safe_haskell = safe_mode,+ mg_trust_pkg = imp_trust_own_pkg imports,+ mg_dependent_files = dep_files+ }+ ; return (msgs, Just mod_guts)+ }}}++dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])+dsImpSpecs imp_specs+ = do { spec_prs <- mapMaybeM (dsSpec Nothing) imp_specs+ ; let (spec_binds, spec_rules) = unzip spec_prs+ ; return (concatOL spec_binds, spec_rules) }++combineEvBinds :: [CoreBind] -> [(Id,CoreExpr)] -> [CoreBind]+-- Top-level bindings can include coercion bindings, but not via superclasses+-- See Note [Top-level evidence]+combineEvBinds [] val_prs+ = [Rec val_prs]+combineEvBinds (NonRec b r : bs) val_prs+ | isId b = combineEvBinds bs ((b,r):val_prs)+ | otherwise = NonRec b r : combineEvBinds bs val_prs+combineEvBinds (Rec prs : bs) val_prs+ = combineEvBinds bs (prs ++ val_prs)++{-+Note [Top-level evidence]+~~~~~~~~~~~~~~~~~~~~~~~~~+Top-level evidence bindings may be mutually recursive with the top-level value+bindings, so we must put those in a Rec. But we can't put them *all* in a Rec+because the occurrence analyser doesn't teke account of type/coercion variables+when computing dependencies.++So we pull out the type/coercion variables (which are in dependency order),+and Rec the rest.+-}++deSugarExpr :: HscEnv -> LHsExpr Id -> IO (Messages, Maybe CoreExpr)++deSugarExpr hsc_env tc_expr+ = do { let dflags = hsc_dflags hsc_env+ icntxt = hsc_IC hsc_env+ rdr_env = ic_rn_gbl_env icntxt+ type_env = mkTypeEnvWithImplicits (ic_tythings icntxt)+ fam_insts = snd (ic_instances icntxt)+ fam_inst_env = extendFamInstEnvList emptyFamInstEnv fam_insts+ -- This stuff is a half baked version of TcRnDriver.setInteractiveContext++ ; showPass dflags "Desugar"++ -- Do desugaring+ ; (msgs, mb_core_expr) <- initDs hsc_env (icInteractiveModule icntxt) rdr_env+ type_env fam_inst_env $+ dsLExpr tc_expr++ ; case mb_core_expr of+ Nothing -> return ()+ Just expr -> dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr)++ ; return (msgs, mb_core_expr) }++{-+************************************************************************+* *+* Add rules and export flags to binders+* *+************************************************************************+-}++addExportFlagsAndRules+ :: HscTarget -> NameSet -> NameSet -> [CoreRule]+ -> [(Id, t)] -> [(Id, t)]+addExportFlagsAndRules target exports keep_alive rules prs+ = mapFst add_one prs+ where+ add_one bndr = add_rules name (add_export name bndr)+ where+ name = idName bndr++ ---------- Rules --------+ -- See Note [Attach rules to local ids]+ -- NB: the binder might have some existing rules,+ -- arising from specialisation pragmas+ add_rules name bndr+ | Just rules <- lookupNameEnv rule_base name+ = bndr `addIdSpecialisations` rules+ | otherwise+ = bndr+ rule_base = extendRuleBaseList emptyRuleBase rules++ ---------- Export flag --------+ -- See Note [Adding export flags]+ add_export name bndr+ | dont_discard name = setIdExported bndr+ | otherwise = bndr++ dont_discard :: Name -> Bool+ dont_discard name = is_exported name+ || name `elemNameSet` keep_alive++ -- In interactive mode, we don't want to discard any top-level+ -- entities at all (eg. do not inline them away during+ -- simplification), and retain them all in the TypeEnv so they are+ -- available from the command line.+ --+ -- isExternalName separates the user-defined top-level names from those+ -- introduced by the type checker.+ is_exported :: Name -> Bool+ is_exported | targetRetainsAllBindings target = isExternalName+ | otherwise = (`elemNameSet` exports)++{-+Note [Adding export flags]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Set the no-discard flag if either+ a) the Id is exported+ b) it's mentioned in the RHS of an orphan rule+ c) it's in the keep-alive set++It means that the binding won't be discarded EVEN if the binding+ends up being trivial (v = w) -- the simplifier would usually just+substitute w for v throughout, but we don't apply the substitution to+the rules (maybe we should?), so this substitution would make the rule+bogus.++You might wonder why exported Ids aren't already marked as such;+it's just because the type checker is rather busy already and+I didn't want to pass in yet another mapping.++Note [Attach rules to local ids]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Find the rules for locally-defined Ids; then we can attach them+to the binders in the top-level bindings++Reason+ - It makes the rules easier to look up+ - It means that transformation rules and specialisations for+ locally defined Ids are handled uniformly+ - It keeps alive things that are referred to only from a rule+ (the occurrence analyser knows about rules attached to Ids)+ - It makes sure that, when we apply a rule, the free vars+ of the RHS are more likely to be in scope+ - The imported rules are carried in the in-scope set+ which is extended on each iteration by the new wave of+ local binders; any rules which aren't on the binding will+ thereby get dropped+++************************************************************************+* *+* Desugaring transformation rules+* *+************************************************************************+-}++dsRule :: LRuleDecl Id -> DsM (Maybe CoreRule)+dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))+ = putSrcSpanDs loc $+ do { let bndrs' = [var | L _ (RuleBndr (L _ var)) <- vars]++ ; lhs' <- unsetGOptM Opt_EnableRewriteRules $+ unsetWOptM Opt_WarnIdentities $+ dsLExpr lhs -- Note [Desugaring RULE left hand sides]++ ; rhs' <- dsLExpr rhs+ ; dflags <- getDynFlags++ ; (bndrs'', lhs'', rhs'') <- unfold_coerce bndrs' lhs' rhs'++ -- Substitute the dict bindings eagerly,+ -- and take the body apart into a (f args) form+ ; case decomposeRuleLhs bndrs'' lhs'' of {+ Left msg -> do { warnDs msg; return Nothing } ;+ Right (final_bndrs, fn_id, args) -> do++ { let is_local = isLocalId fn_id+ -- NB: isLocalId is False of implicit Ids. This is good because+ -- we don't want to attach rules to the bindings of implicit Ids,+ -- because they don't show up in the bindings until just before code gen+ fn_name = idName fn_id+ final_rhs = simpleOptExpr rhs'' -- De-crap it+ rule = mkRule False {- Not auto -} is_local+ (unLoc name) act fn_name final_bndrs args+ final_rhs++ inline_shadows_rule -- Function can be inlined before rule fires+ | wopt Opt_WarnInlineRuleShadowing dflags+ , isLocalId fn_id || hasSomeUnfolding (idUnfolding fn_id)+ -- If imported with no unfolding, no worries+ = case (idInlineActivation fn_id, act) of+ (NeverActive, _) -> False+ (AlwaysActive, _) -> True+ (ActiveBefore {}, _) -> True+ (ActiveAfter {}, NeverActive) -> True+ (ActiveAfter n, ActiveAfter r) -> r < n -- Rule active strictly first+ (ActiveAfter {}, AlwaysActive) -> False+ (ActiveAfter {}, ActiveBefore {}) -> False+ | otherwise = False++ ; when inline_shadows_rule $+ warnDs (vcat [ hang (ptext (sLit "Rule")+ <+> doubleQuotes (ftext $ unLoc name)+ <+> ptext (sLit "may never fire"))+ 2 (ptext (sLit "because") <+> quotes (ppr fn_id)+ <+> ptext (sLit "might inline first"))+ , ptext (sLit "Probable fix: add an INLINE[n] or NOINLINE[n] pragma on")+ <+> quotes (ppr fn_id) ])++ ; return (Just rule)+ } } }++-- See Note [Desugaring coerce as cast]+unfold_coerce :: [Id] -> CoreExpr -> CoreExpr -> DsM ([Var], CoreExpr, CoreExpr)+unfold_coerce bndrs lhs rhs = do+ (bndrs', wrap) <- go bndrs+ return (bndrs', wrap lhs, wrap rhs)+ where+ go :: [Id] -> DsM ([Id], CoreExpr -> CoreExpr)+ go [] = return ([], id)+ go (v:vs)+ | Just (tc, args) <- splitTyConApp_maybe (idType v)+ , tc == coercibleTyCon = do+ let ty' = mkTyConApp eqReprPrimTyCon args+ v' <- mkDerivedLocalM mkRepEqOcc v ty'++ (bndrs, wrap) <- go vs+ return (v':bndrs, mkCoreLet (NonRec v (mkEqBox (mkCoVarCo v'))) . wrap)+ | otherwise = do+ (bndrs,wrap) <- go vs+ return (v:bndrs, wrap)++{-+Note [Desugaring RULE left hand sides]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For the LHS of a RULE we do *not* want to desugar+ [x] to build (\cn. x `c` n)+We want to leave explicit lists simply as chains+of cons's. We can achieve that slightly indirectly by+switching off EnableRewriteRules. See DsExpr.dsExplicitList.++That keeps the desugaring of list comprehensions simple too.++++Nor do we want to warn of conversion identities on the LHS;+the rule is precisly to optimise them:+ {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}+++Note [Desugaring coerce as cast]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We want the user to express a rule saying roughly “mapping a coercion over a+list can be replaced by a coercion”. But the cast operator of Core (▷) cannot+be written in Haskell. So we use `coerce` for that (#2110). The user writes+ map coerce = coerce+as a RULE, and this optimizes any kind of mapped' casts aways, including `map+MkNewtype`.++For that we replace any forall'ed `c :: Coercible a b` value in a RULE by+corresponding `co :: a ~#R b` and wrap the LHS and the RHS in+`let c = MkCoercible co in ...`. This is later simplified to the desired form+by simpleOptExpr (for the LHS) resp. the simplifiers (for the RHS).++************************************************************************+* *+* Desugaring vectorisation declarations+* *+************************************************************************+-}++dsVect :: LVectDecl Id -> DsM CoreVect+dsVect (L loc (HsVect _ (L _ v) rhs))+ = putSrcSpanDs loc $+ do { rhs' <- dsLExpr rhs+ ; return $ Vect v rhs'+ }+dsVect (L _loc (HsNoVect _ (L _ v)))+ = return $ NoVect v+dsVect (L _loc (HsVectTypeOut isScalar tycon rhs_tycon))+ = return $ VectType isScalar tycon' rhs_tycon+ where+ tycon' | Just ty <- coreView $ mkTyConTy tycon+ , (tycon', []) <- splitTyConApp ty = tycon'+ | otherwise = tycon+dsVect vd@(L _ (HsVectTypeIn _ _ _ _))+ = pprPanic "Desugar.dsVect: unexpected 'HsVectTypeIn'" (ppr vd)+dsVect (L _loc (HsVectClassOut cls))+ = return $ VectClass (classTyCon cls)+dsVect vc@(L _ (HsVectClassIn _ _))+ = pprPanic "Desugar.dsVect: unexpected 'HsVectClassIn'" (ppr vc)+dsVect (L _loc (HsVectInstOut inst))+ = return $ VectInst (instanceDFunId inst)+dsVect vi@(L _ (HsVectInstIn _))+ = pprPanic "Desugar.dsVect: unexpected 'HsVectInstIn'" (ppr vi)
+ src/Language/Haskell/Liquid/Desugar710/DsArrows.hs view
@@ -0,0 +1,1178 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++Desugaring arrow commands+-}++{-# LANGUAGE CPP #-}++module Language.Haskell.Liquid.Desugar710.DsArrows ( dsProcExpr ) where++-- #include "HsVersions.h"++import Language.Haskell.Liquid.Desugar710.Match+import Language.Haskell.Liquid.Desugar710.DsUtils+import DsMonad++import HsSyn hiding (collectPatBinders, collectPatsBinders, collectLStmtsBinders, collectLStmtBinders, collectStmtBinders )+import TcHsSyn++-- NB: The desugarer, which straddles the source and Core worlds, sometimes+-- needs to see source types (newtypes etc), and sometimes not+-- So WATCH OUT; check each use of split*Ty functions.+-- Sigh. This is a pain.++import {-# SOURCE #-} Language.Haskell.Liquid.Desugar710.DsExpr ( dsExpr, dsLExpr, dsLocalBinds )++import TcType+import TcEvidence+import CoreSyn+import CoreFVs+import CoreUtils+import MkCore+import Language.Haskell.Liquid.Desugar710.DsBinds (dsHsWrapper)++import Name+import Var+import Id+import DataCon+import TysWiredIn+import BasicTypes+import PrelNames+import Outputable+import Bag+import VarSet+import SrcLoc+import ListSetOps( assocDefault )+import FastString+import Data.List++data DsCmdEnv = DsCmdEnv {+ arr_id, compose_id, first_id, app_id, choice_id, loop_id :: CoreExpr+ }++mkCmdEnv :: CmdSyntaxTable Id -> DsM ([CoreBind], DsCmdEnv)+-- See Note [CmdSyntaxTable] in HsExpr+mkCmdEnv tc_meths+ = do { (meth_binds, prs) <- mapAndUnzipM mk_bind tc_meths+ ; return (meth_binds, DsCmdEnv {+ arr_id = Var (find_meth prs arrAName),+ compose_id = Var (find_meth prs composeAName),+ first_id = Var (find_meth prs firstAName),+ app_id = Var (find_meth prs appAName),+ choice_id = Var (find_meth prs choiceAName),+ loop_id = Var (find_meth prs loopAName)+ }) }+ where+ mk_bind (std_name, expr)+ = do { rhs <- dsExpr expr+ ; id <- newSysLocalDs (exprType rhs)+ ; return (NonRec id rhs, (std_name, id)) }++ find_meth prs std_name+ = assocDefault (mk_panic std_name) prs std_name+ mk_panic std_name = pprPanic "mkCmdEnv" (ptext (sLit "Not found:") <+> ppr std_name)++-- arr :: forall b c. (b -> c) -> a b c+do_arr :: DsCmdEnv -> Type -> Type -> CoreExpr -> CoreExpr+do_arr ids b_ty c_ty f = mkApps (arr_id ids) [Type b_ty, Type c_ty, f]++-- (>>>) :: forall b c d. a b c -> a c d -> a b d+do_compose :: DsCmdEnv -> Type -> Type -> Type ->+ CoreExpr -> CoreExpr -> CoreExpr+do_compose ids b_ty c_ty d_ty f g+ = mkApps (compose_id ids) [Type b_ty, Type c_ty, Type d_ty, f, g]++-- first :: forall b c d. a b c -> a (b,d) (c,d)+do_first :: DsCmdEnv -> Type -> Type -> Type -> CoreExpr -> CoreExpr+do_first ids b_ty c_ty d_ty f+ = mkApps (first_id ids) [Type b_ty, Type c_ty, Type d_ty, f]++-- app :: forall b c. a (a b c, b) c+do_app :: DsCmdEnv -> Type -> Type -> CoreExpr+do_app ids b_ty c_ty = mkApps (app_id ids) [Type b_ty, Type c_ty]++-- (|||) :: forall b d c. a b d -> a c d -> a (Either b c) d+-- note the swapping of d and c+do_choice :: DsCmdEnv -> Type -> Type -> Type ->+ CoreExpr -> CoreExpr -> CoreExpr+do_choice ids b_ty c_ty d_ty f g+ = mkApps (choice_id ids) [Type b_ty, Type d_ty, Type c_ty, f, g]++-- loop :: forall b d c. a (b,d) (c,d) -> a b c+-- note the swapping of d and c+do_loop :: DsCmdEnv -> Type -> Type -> Type -> CoreExpr -> CoreExpr+do_loop ids b_ty c_ty d_ty f+ = mkApps (loop_id ids) [Type b_ty, Type d_ty, Type c_ty, f]++-- premap :: forall b c d. (b -> c) -> a c d -> a b d+-- premap f g = arr f >>> g+do_premap :: DsCmdEnv -> Type -> Type -> Type ->+ CoreExpr -> CoreExpr -> CoreExpr+do_premap ids b_ty c_ty d_ty f g+ = do_compose ids b_ty c_ty d_ty (do_arr ids b_ty c_ty f) g++mkFailExpr :: HsMatchContext Id -> Type -> DsM CoreExpr+mkFailExpr ctxt ty+ = mkErrorAppDs pAT_ERROR_ID ty (matchContextErrString ctxt)++-- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> a+mkFstExpr :: Type -> Type -> DsM CoreExpr+mkFstExpr a_ty b_ty = do+ a_var <- newSysLocalDs a_ty+ b_var <- newSysLocalDs b_ty+ pair_var <- newSysLocalDs (mkCorePairTy a_ty b_ty)+ return (Lam pair_var+ (coreCasePair pair_var a_var b_var (Var a_var)))++-- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> b+mkSndExpr :: Type -> Type -> DsM CoreExpr+mkSndExpr a_ty b_ty = do+ a_var <- newSysLocalDs a_ty+ b_var <- newSysLocalDs b_ty+ pair_var <- newSysLocalDs (mkCorePairTy a_ty b_ty)+ return (Lam pair_var+ (coreCasePair pair_var a_var b_var (Var b_var)))++{-+Build case analysis of a tuple. This cannot be done in the DsM monad,+because the list of variables is typically not yet defined.+-}++-- coreCaseTuple [u1..] v [x1..xn] body+-- = case v of v { (x1, .., xn) -> body }+-- But the matching may be nested if the tuple is very big++coreCaseTuple :: UniqSupply -> Id -> [Id] -> CoreExpr -> CoreExpr+coreCaseTuple uniqs scrut_var vars body+ = mkTupleCase uniqs vars body scrut_var (Var scrut_var)++coreCasePair :: Id -> Id -> Id -> CoreExpr -> CoreExpr+coreCasePair scrut_var var1 var2 body+ = Case (Var scrut_var) scrut_var (exprType body)+ [(DataAlt (tupleCon BoxedTuple 2), [var1, var2], body)]++mkCorePairTy :: Type -> Type -> Type+mkCorePairTy t1 t2 = mkBoxedTupleTy [t1, t2]++mkCorePairExpr :: CoreExpr -> CoreExpr -> CoreExpr+mkCorePairExpr e1 e2 = mkCoreTup [e1, e2]++mkCoreUnitExpr :: CoreExpr+mkCoreUnitExpr = mkCoreTup []++{-+The input is divided into a local environment, which is a flat tuple+(unless it's too big), and a stack, which is a right-nested pair.+In general, the input has the form++ ((x1,...,xn), (s1,...(sk,())...))++where xi are the environment values, and si the ones on the stack,+with s1 being the "top", the first one to be matched with a lambda.+-}++envStackType :: [Id] -> Type -> Type+envStackType ids stack_ty = mkCorePairTy (mkBigCoreVarTupTy ids) stack_ty++-- splitTypeAt n (t1,... (tn,t)...) = ([t1, ..., tn], t)+splitTypeAt :: Int -> Type -> ([Type], Type)+splitTypeAt n ty+ | n == 0 = ([], ty)+ | otherwise = case tcTyConAppArgs ty of+ [t, ty'] -> let (ts, ty_r) = splitTypeAt (n-1) ty' in (t:ts, ty_r)+ _ -> pprPanic "splitTypeAt" (ppr ty)++----------------------------------------------+-- buildEnvStack+--+-- ((x1,...,xn),stk)++buildEnvStack :: [Id] -> Id -> CoreExpr+buildEnvStack env_ids stack_id+ = mkCorePairExpr (mkBigCoreVarTup env_ids) (Var stack_id)++----------------------------------------------+-- matchEnvStack+--+-- \ ((x1,...,xn),stk) -> body+-- =>+-- \ pair ->+-- case pair of (tup,stk) ->+-- case tup of (x1,...,xn) ->+-- body++matchEnvStack :: [Id] -- x1..xn+ -> Id -- stk+ -> CoreExpr -- e+ -> DsM CoreExpr+matchEnvStack env_ids stack_id body = do+ uniqs <- newUniqueSupply+ tup_var <- newSysLocalDs (mkBigCoreVarTupTy env_ids)+ let match_env = coreCaseTuple uniqs tup_var env_ids body+ pair_id <- newSysLocalDs (mkCorePairTy (idType tup_var) (idType stack_id))+ return (Lam pair_id (coreCasePair pair_id tup_var stack_id match_env))++----------------------------------------------+-- matchEnv+--+-- \ (x1,...,xn) -> body+-- =>+-- \ tup ->+-- case tup of (x1,...,xn) ->+-- body++matchEnv :: [Id] -- x1..xn+ -> CoreExpr -- e+ -> DsM CoreExpr+matchEnv env_ids body = do+ uniqs <- newUniqueSupply+ tup_id <- newSysLocalDs (mkBigCoreVarTupTy env_ids)+ return (Lam tup_id (coreCaseTuple uniqs tup_id env_ids body))++----------------------------------------------+-- matchVarStack+--+-- case (x1, ...(xn, s)...) -> e+-- =>+-- case z0 of (x1,z1) ->+-- case zn-1 of (xn,s) ->+-- e+matchVarStack :: [Id] -> Id -> CoreExpr -> DsM (Id, CoreExpr)+matchVarStack [] stack_id body = return (stack_id, body)+matchVarStack (param_id:param_ids) stack_id body = do+ (tail_id, tail_code) <- matchVarStack param_ids stack_id body+ pair_id <- newSysLocalDs (mkCorePairTy (idType param_id) (idType tail_id))+ return (pair_id, coreCasePair pair_id param_id tail_id tail_code)++mkHsEnvStackExpr :: [Id] -> Id -> LHsExpr Id+mkHsEnvStackExpr env_ids stack_id+ = mkLHsTupleExpr [mkLHsVarTuple env_ids, nlHsVar stack_id]++-- Translation of arrow abstraction++-- D; xs |-a c : () --> t' ---> c'+-- --------------------------+-- D |- proc p -> c :: a t t' ---> premap (\ p -> ((xs),())) c'+--+-- where (xs) is the tuple of variables bound by p++dsProcExpr+ :: LPat Id+ -> LHsCmdTop Id+ -> DsM CoreExpr+dsProcExpr pat (L _ (HsCmdTop cmd _unitTy cmd_ty ids)) = do+ (meth_binds, meth_ids) <- mkCmdEnv ids+ let locals = mkVarSet (collectPatBinders pat)+ (core_cmd, _free_vars, env_ids) <- dsfixCmd meth_ids locals unitTy cmd_ty cmd+ let env_ty = mkBigCoreVarTupTy env_ids+ let env_stk_ty = mkCorePairTy env_ty unitTy+ let env_stk_expr = mkCorePairExpr (mkBigCoreVarTup env_ids) mkCoreUnitExpr+ fail_expr <- mkFailExpr ProcExpr env_stk_ty+ var <- selectSimpleMatchVarL pat+ match_code <- matchSimply (Var var) ProcExpr pat env_stk_expr fail_expr+ let pat_ty = hsLPatType pat+ proc_code = do_premap meth_ids pat_ty env_stk_ty cmd_ty+ (Lam var match_code)+ core_cmd+ return (mkLets meth_binds proc_code)++{-+Translation of a command judgement of the form++ D; xs |-a c : stk --> t++to an expression e such that++ D |- e :: a (xs, stk) t+-}++dsLCmd :: DsCmdEnv -> IdSet -> Type -> Type -> LHsCmd Id -> [Id]+ -> DsM (CoreExpr, IdSet)+dsLCmd ids local_vars stk_ty res_ty cmd env_ids+ = dsCmd ids local_vars stk_ty res_ty (unLoc cmd) env_ids++dsCmd :: DsCmdEnv -- arrow combinators+ -> IdSet -- set of local vars available to this command+ -> Type -- type of the stack (right-nested tuple)+ -> Type -- return type of the command+ -> HsCmd Id -- command to desugar+ -> [Id] -- list of vars in the input to this command+ -- This is typically fed back,+ -- so don't pull on it too early+ -> DsM (CoreExpr, -- desugared expression+ IdSet) -- subset of local vars that occur free++-- D |- fun :: a t1 t2+-- D, xs |- arg :: t1+-- -----------------------------+-- D; xs |-a fun -< arg : stk --> t2+--+-- ---> premap (\ ((xs), _stk) -> arg) fun++dsCmd ids local_vars stack_ty res_ty+ (HsCmdArrApp arrow arg arrow_ty HsFirstOrderApp _)+ env_ids = do+ let+ (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty+ (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty+ core_arrow <- dsLExpr arrow+ core_arg <- dsLExpr arg+ stack_id <- newSysLocalDs stack_ty+ core_make_arg <- matchEnvStack env_ids stack_id core_arg+ return (do_premap ids+ (envStackType env_ids stack_ty)+ arg_ty+ res_ty+ core_make_arg+ core_arrow,+ exprFreeIds core_arg `intersectVarSet` local_vars)++-- D, xs |- fun :: a t1 t2+-- D, xs |- arg :: t1+-- ------------------------------+-- D; xs |-a fun -<< arg : stk --> t2+--+-- ---> premap (\ ((xs), _stk) -> (fun, arg)) app++dsCmd ids local_vars stack_ty res_ty+ (HsCmdArrApp arrow arg arrow_ty HsHigherOrderApp _)+ env_ids = do+ let+ (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty+ (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty++ core_arrow <- dsLExpr arrow+ core_arg <- dsLExpr arg+ stack_id <- newSysLocalDs stack_ty+ core_make_pair <- matchEnvStack env_ids stack_id+ (mkCorePairExpr core_arrow core_arg)++ return (do_premap ids+ (envStackType env_ids stack_ty)+ (mkCorePairTy arrow_ty arg_ty)+ res_ty+ core_make_pair+ (do_app ids arg_ty res_ty),+ (exprFreeIds core_arrow `unionVarSet` exprFreeIds core_arg)+ `intersectVarSet` local_vars)++-- D; ys |-a cmd : (t,stk) --> t'+-- D, xs |- exp :: t+-- ------------------------+-- D; xs |-a cmd exp : stk --> t'+--+-- ---> premap (\ ((xs),stk) -> ((ys),(e,stk))) cmd++dsCmd ids local_vars stack_ty res_ty (HsCmdApp cmd arg) env_ids = do+ core_arg <- dsLExpr arg+ let+ arg_ty = exprType core_arg+ stack_ty' = mkCorePairTy arg_ty stack_ty+ (core_cmd, free_vars, env_ids')+ <- dsfixCmd ids local_vars stack_ty' res_ty cmd+ stack_id <- newSysLocalDs stack_ty+ arg_id <- newSysLocalDs arg_ty+ -- push the argument expression onto the stack+ let+ stack' = mkCorePairExpr (Var arg_id) (Var stack_id)+ core_body = bindNonRec arg_id core_arg+ (mkCorePairExpr (mkBigCoreVarTup env_ids') stack')++ -- match the environment and stack against the input+ core_map <- matchEnvStack env_ids stack_id core_body+ return (do_premap ids+ (envStackType env_ids stack_ty)+ (envStackType env_ids' stack_ty')+ res_ty+ core_map+ core_cmd,+ free_vars `unionVarSet`+ (exprFreeIds core_arg `intersectVarSet` local_vars))++-- D; ys |-a cmd : stk t'+-- -----------------------------------------------+-- D; xs |-a \ p1 ... pk -> cmd : (t1,...(tk,stk)...) t'+--+-- ---> premap (\ ((xs), (p1, ... (pk,stk)...)) -> ((ys),stk)) cmd++dsCmd ids local_vars stack_ty res_ty+ (HsCmdLam (MG { mg_alts = [L _ (Match _ pats _+ (GRHSs [L _ (GRHS [] body)] _ ))] }))+ env_ids = do+ let+ pat_vars = mkVarSet (collectPatsBinders pats)+ local_vars' = pat_vars `unionVarSet` local_vars+ (pat_tys, stack_ty') = splitTypeAt (length pats) stack_ty+ (core_body, free_vars, env_ids') <- dsfixCmd ids local_vars' stack_ty' res_ty body+ param_ids <- mapM newSysLocalDs pat_tys+ stack_id' <- newSysLocalDs stack_ty'++ -- the expression is built from the inside out, so the actions+ -- are presented in reverse order++ let+ -- build a new environment, plus what's left of the stack+ core_expr = buildEnvStack env_ids' stack_id'+ in_ty = envStackType env_ids stack_ty+ in_ty' = envStackType env_ids' stack_ty'++ fail_expr <- mkFailExpr LambdaExpr in_ty'+ -- match the patterns against the parameters+ match_code <- matchSimplys (map Var param_ids) LambdaExpr pats core_expr fail_expr+ -- match the parameters against the top of the old stack+ (stack_id, param_code) <- matchVarStack param_ids stack_id' match_code+ -- match the old environment and stack against the input+ select_code <- matchEnvStack env_ids stack_id param_code+ return (do_premap ids in_ty in_ty' res_ty select_code core_body,+ free_vars `minusVarSet` pat_vars)++dsCmd ids local_vars stack_ty res_ty (HsCmdPar cmd) env_ids+ = dsLCmd ids local_vars stack_ty res_ty cmd env_ids++-- D, xs |- e :: Bool+-- D; xs1 |-a c1 : stk --> t+-- D; xs2 |-a c2 : stk --> t+-- ----------------------------------------+-- D; xs |-a if e then c1 else c2 : stk --> t+--+-- ---> premap (\ ((xs),stk) ->+-- if e then Left ((xs1),stk) else Right ((xs2),stk))+-- (c1 ||| c2)++dsCmd ids local_vars stack_ty res_ty (HsCmdIf mb_fun cond then_cmd else_cmd)+ env_ids = do+ core_cond <- dsLExpr cond+ (core_then, fvs_then, then_ids) <- dsfixCmd ids local_vars stack_ty res_ty then_cmd+ (core_else, fvs_else, else_ids) <- dsfixCmd ids local_vars stack_ty res_ty else_cmd+ stack_id <- newSysLocalDs stack_ty+ either_con <- dsLookupTyCon eitherTyConName+ left_con <- dsLookupDataCon leftDataConName+ right_con <- dsLookupDataCon rightDataConName++ let mk_left_expr ty1 ty2 e = mkConApp left_con [Type ty1, Type ty2, e]+ mk_right_expr ty1 ty2 e = mkConApp right_con [Type ty1, Type ty2, e]++ in_ty = envStackType env_ids stack_ty+ then_ty = envStackType then_ids stack_ty+ else_ty = envStackType else_ids stack_ty+ sum_ty = mkTyConApp either_con [then_ty, else_ty]+ fvs_cond = exprFreeIds core_cond `intersectVarSet` local_vars++ core_left = mk_left_expr then_ty else_ty (buildEnvStack then_ids stack_id)+ core_right = mk_right_expr then_ty else_ty (buildEnvStack else_ids stack_id)++ core_if <- case mb_fun of+ Just fun -> do { core_fun <- dsExpr fun+ ; matchEnvStack env_ids stack_id $+ mkCoreApps core_fun [core_cond, core_left, core_right] }+ Nothing -> matchEnvStack env_ids stack_id $+ mkIfThenElse core_cond core_left core_right++ return (do_premap ids in_ty sum_ty res_ty+ core_if+ (do_choice ids then_ty else_ty res_ty core_then core_else),+ fvs_cond `unionVarSet` fvs_then `unionVarSet` fvs_else)++{-+Case commands are treated in much the same way as if commands+(see above) except that there are more alternatives. For example++ case e of { p1 -> c1; p2 -> c2; p3 -> c3 }++is translated to++ premap (\ ((xs)*ts) -> case e of+ p1 -> (Left (Left (xs1)*ts))+ p2 -> Left ((Right (xs2)*ts))+ p3 -> Right ((xs3)*ts))+ ((c1 ||| c2) ||| c3)++The idea is to extract the commands from the case, build a balanced tree+of choices, and replace the commands with expressions that build tagged+tuples, obtaining a case expression that can be desugared normally.+To build all this, we use triples describing segments of the list of+case bodies, containing the following fields:+ * a list of expressions of the form (Left|Right)* ((xs)*ts), to be put+ into the case replacing the commands+ * a sum type that is the common type of these expressions, and also the+ input type of the arrow+ * a CoreExpr for an arrow built by combining the translated command+ bodies with |||.+-}++dsCmd ids local_vars stack_ty res_ty+ (HsCmdCase exp (MG { mg_alts = matches, mg_arg_tys = arg_tys, mg_origin = origin }))+ env_ids = do+ stack_id <- newSysLocalDs stack_ty++ -- Extract and desugar the leaf commands in the case, building tuple+ -- expressions that will (after tagging) replace these leaves++ let+ leaves = concatMap leavesMatch matches+ make_branch (leaf, bound_vars) = do+ (core_leaf, _fvs, leaf_ids) <-+ dsfixCmd ids (bound_vars `unionVarSet` local_vars) stack_ty res_ty leaf+ return ([mkHsEnvStackExpr leaf_ids stack_id],+ envStackType leaf_ids stack_ty,+ core_leaf)++ branches <- mapM make_branch leaves+ either_con <- dsLookupTyCon eitherTyConName+ left_con <- dsLookupDataCon leftDataConName+ right_con <- dsLookupDataCon rightDataConName+ let+ left_id = HsVar (dataConWrapId left_con)+ right_id = HsVar (dataConWrapId right_con)+ left_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ HsWrap (mkWpTyApps [ty1, ty2]) left_id ) e+ right_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ HsWrap (mkWpTyApps [ty1, ty2]) right_id) e++ -- Prefix each tuple with a distinct series of Left's and Right's,+ -- in a balanced way, keeping track of the types.++ merge_branches (builds1, in_ty1, core_exp1)+ (builds2, in_ty2, core_exp2)+ = (map (left_expr in_ty1 in_ty2) builds1 +++ map (right_expr in_ty1 in_ty2) builds2,+ mkTyConApp either_con [in_ty1, in_ty2],+ do_choice ids in_ty1 in_ty2 res_ty core_exp1 core_exp2)+ (leaves', sum_ty, core_choices) = foldb merge_branches branches++ -- Replace the commands in the case with these tagged tuples,+ -- yielding a HsExpr Id we can feed to dsExpr.++ (_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches+ in_ty = envStackType env_ids stack_ty++ core_body <- dsExpr (HsCase exp (MG { mg_alts = matches', mg_arg_tys = arg_tys+ , mg_res_ty = sum_ty, mg_origin = origin }))+ -- Note that we replace the HsCase result type by sum_ty,+ -- which is the type of matches'++ core_matches <- matchEnvStack env_ids stack_id core_body+ return (do_premap ids in_ty sum_ty res_ty core_matches core_choices,+ exprFreeIds core_body `intersectVarSet` local_vars)++-- D; ys |-a cmd : stk --> t+-- ----------------------------------+-- D; xs |-a let binds in cmd : stk --> t+--+-- ---> premap (\ ((xs),stk) -> let binds in ((ys),stk)) c++dsCmd ids local_vars stack_ty res_ty (HsCmdLet binds body) env_ids = do+ let+ defined_vars = mkVarSet (collectLocalBinders binds)+ local_vars' = defined_vars `unionVarSet` local_vars++ (core_body, _free_vars, env_ids') <- dsfixCmd ids local_vars' stack_ty res_ty body+ stack_id <- newSysLocalDs stack_ty+ -- build a new environment, plus the stack, using the let bindings+ core_binds <- dsLocalBinds binds (buildEnvStack env_ids' stack_id)+ -- match the old environment and stack against the input+ core_map <- matchEnvStack env_ids stack_id core_binds+ return (do_premap ids+ (envStackType env_ids stack_ty)+ (envStackType env_ids' stack_ty)+ res_ty+ core_map+ core_body,+ exprFreeIds core_binds `intersectVarSet` local_vars)++-- D; xs |-a ss : t+-- ----------------------------------+-- D; xs |-a do { ss } : () --> t+--+-- ---> premap (\ (env,stk) -> env) c++dsCmd ids local_vars stack_ty res_ty (HsCmdDo stmts _) env_ids = do+ (core_stmts, env_ids') <- dsCmdDo ids local_vars res_ty stmts env_ids+ let env_ty = mkBigCoreVarTupTy env_ids+ core_fst <- mkFstExpr env_ty stack_ty+ return (do_premap ids+ (mkCorePairTy env_ty stack_ty)+ env_ty+ res_ty+ core_fst+ core_stmts,+ env_ids')++-- D |- e :: forall e. a1 (e,stk1) t1 -> ... an (e,stkn) tn -> a (e,stk) t+-- D; xs |-a ci :: stki --> ti+-- -----------------------------------+-- D; xs |-a (|e c1 ... cn|) :: stk --> t ---> e [t_xs] c1 ... cn++dsCmd _ids local_vars _stack_ty _res_ty (HsCmdArrForm op _ args) env_ids = do+ let env_ty = mkBigCoreVarTupTy env_ids+ core_op <- dsLExpr op+ (core_args, fv_sets) <- mapAndUnzipM (dsTrimCmdArg local_vars env_ids) args+ return (mkApps (App core_op (Type env_ty)) core_args,+ unionVarSets fv_sets)++dsCmd ids local_vars stack_ty res_ty (HsCmdCast coercion cmd) env_ids = do+ (core_cmd, env_ids') <- dsCmd ids local_vars stack_ty res_ty cmd env_ids+ wrapped_cmd <- dsHsWrapper (mkWpCast coercion) core_cmd+ return (wrapped_cmd, env_ids')++dsCmd _ _ _ _ _ c = pprPanic "dsCmd" (ppr c)++-- D; ys |-a c : stk --> t (ys <= xs)+-- ---------------------+-- D; xs |-a c : stk --> t ---> premap (\ ((xs),stk) -> ((ys),stk)) c++dsTrimCmdArg+ :: IdSet -- set of local vars available to this command+ -> [Id] -- list of vars in the input to this command+ -> LHsCmdTop Id -- command argument to desugar+ -> DsM (CoreExpr, -- desugared expression+ IdSet) -- subset of local vars that occur free+dsTrimCmdArg local_vars env_ids (L _ (HsCmdTop cmd stack_ty cmd_ty ids)) = do+ (meth_binds, meth_ids) <- mkCmdEnv ids+ (core_cmd, free_vars, env_ids') <- dsfixCmd meth_ids local_vars stack_ty cmd_ty cmd+ stack_id <- newSysLocalDs stack_ty+ trim_code <- matchEnvStack env_ids stack_id (buildEnvStack env_ids' stack_id)+ let+ in_ty = envStackType env_ids stack_ty+ in_ty' = envStackType env_ids' stack_ty+ arg_code = if env_ids' == env_ids then core_cmd else+ do_premap meth_ids in_ty in_ty' cmd_ty trim_code core_cmd+ return (mkLets meth_binds arg_code, free_vars)++-- Given D; xs |-a c : stk --> t, builds c with xs fed back.+-- Typically needs to be prefixed with arr (\(p, stk) -> ((xs),stk))++dsfixCmd+ :: DsCmdEnv -- arrow combinators+ -> IdSet -- set of local vars available to this command+ -> Type -- type of the stack (right-nested tuple)+ -> Type -- return type of the command+ -> LHsCmd Id -- command to desugar+ -> DsM (CoreExpr, -- desugared expression+ IdSet, -- subset of local vars that occur free+ [Id]) -- the same local vars as a list, fed back+dsfixCmd ids local_vars stk_ty cmd_ty cmd+ = trimInput (dsLCmd ids local_vars stk_ty cmd_ty cmd)++-- Feed back the list of local variables actually used a command,+-- for use as the input tuple of the generated arrow.++trimInput+ :: ([Id] -> DsM (CoreExpr, IdSet))+ -> DsM (CoreExpr, -- desugared expression+ IdSet, -- subset of local vars that occur free+ [Id]) -- same local vars as a list, fed back to+ -- the inner function to form the tuple of+ -- inputs to the arrow.+trimInput build_arrow+ = fixDs (\ ~(_,_,env_ids) -> do+ (core_cmd, free_vars) <- build_arrow env_ids+ return (core_cmd, free_vars, varSetElems free_vars))++{-+Translation of command judgements of the form++ D |-a do { ss } : t+-}++dsCmdDo :: DsCmdEnv -- arrow combinators+ -> IdSet -- set of local vars available to this statement+ -> Type -- return type of the statement+ -> [CmdLStmt Id] -- statements to desugar+ -> [Id] -- list of vars in the input to this statement+ -- This is typically fed back,+ -- so don't pull on it too early+ -> DsM (CoreExpr, -- desugared expression+ IdSet) -- subset of local vars that occur free++dsCmdDo _ _ _ [] _ = panic "dsCmdDo"++-- D; xs |-a c : () --> t+-- --------------------------+-- D; xs |-a do { c } : t+--+-- ---> premap (\ (xs) -> ((xs), ())) c++dsCmdDo ids local_vars res_ty [L _ (LastStmt body _)] env_ids = do+ (core_body, env_ids') <- dsLCmd ids local_vars unitTy res_ty body env_ids+ let env_ty = mkBigCoreVarTupTy env_ids+ env_var <- newSysLocalDs env_ty+ let core_map = Lam env_var (mkCorePairExpr (Var env_var) mkCoreUnitExpr)+ return (do_premap ids+ env_ty+ (mkCorePairTy env_ty unitTy)+ res_ty+ core_map+ core_body,+ env_ids')++dsCmdDo ids local_vars res_ty (stmt:stmts) env_ids = do+ let+ bound_vars = mkVarSet (collectLStmtBinders stmt)+ local_vars' = bound_vars `unionVarSet` local_vars+ (core_stmts, _, env_ids') <- trimInput (dsCmdDo ids local_vars' res_ty stmts)+ (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids+ return (do_compose ids+ (mkBigCoreVarTupTy env_ids)+ (mkBigCoreVarTupTy env_ids')+ res_ty+ core_stmt+ core_stmts,+ fv_stmt)++{-+A statement maps one local environment to another, and is represented+as an arrow from one tuple type to another. A statement sequence is+translated to a composition of such arrows.+-}++dsCmdLStmt :: DsCmdEnv -> IdSet -> [Id] -> CmdLStmt Id -> [Id]+ -> DsM (CoreExpr, IdSet)+dsCmdLStmt ids local_vars out_ids cmd env_ids+ = dsCmdStmt ids local_vars out_ids (unLoc cmd) env_ids++dsCmdStmt+ :: DsCmdEnv -- arrow combinators+ -> IdSet -- set of local vars available to this statement+ -> [Id] -- list of vars in the output of this statement+ -> CmdStmt Id -- statement to desugar+ -> [Id] -- list of vars in the input to this statement+ -- This is typically fed back,+ -- so don't pull on it too early+ -> DsM (CoreExpr, -- desugared expression+ IdSet) -- subset of local vars that occur free++-- D; xs1 |-a c : () --> t+-- D; xs' |-a do { ss } : t'+-- ------------------------------+-- D; xs |-a do { c; ss } : t'+--+-- ---> premap (\ ((xs)) -> (((xs1),()),(xs')))+-- (first c >>> arr snd) >>> ss++dsCmdStmt ids local_vars out_ids (BodyStmt cmd _ _ c_ty) env_ids = do+ (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy c_ty cmd+ core_mux <- matchEnv env_ids+ (mkCorePairExpr+ (mkCorePairExpr (mkBigCoreVarTup env_ids1) mkCoreUnitExpr)+ (mkBigCoreVarTup out_ids))+ let+ in_ty = mkBigCoreVarTupTy env_ids+ in_ty1 = mkCorePairTy (mkBigCoreVarTupTy env_ids1) unitTy+ out_ty = mkBigCoreVarTupTy out_ids+ before_c_ty = mkCorePairTy in_ty1 out_ty+ after_c_ty = mkCorePairTy c_ty out_ty+ snd_fn <- mkSndExpr c_ty out_ty+ return (do_premap ids in_ty before_c_ty out_ty core_mux $+ do_compose ids before_c_ty after_c_ty out_ty+ (do_first ids in_ty1 c_ty out_ty core_cmd) $+ do_arr ids after_c_ty out_ty snd_fn,+ extendVarSetList fv_cmd out_ids)++-- D; xs1 |-a c : () --> t+-- D; xs' |-a do { ss } : t' xs2 = xs' - defs(p)+-- -----------------------------------+-- D; xs |-a do { p <- c; ss } : t'+--+-- ---> premap (\ (xs) -> (((xs1),()),(xs2)))+-- (first c >>> arr (\ (p, (xs2)) -> (xs'))) >>> ss+--+-- It would be simpler and more consistent to do this using second,+-- but that's likely to be defined in terms of first.++dsCmdStmt ids local_vars out_ids (BindStmt pat cmd _ _) env_ids = do+ (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy (hsLPatType pat) cmd+ let+ pat_ty = hsLPatType pat+ pat_vars = mkVarSet (collectPatBinders pat)+ env_ids2 = varSetElems (mkVarSet out_ids `minusVarSet` pat_vars)+ env_ty2 = mkBigCoreVarTupTy env_ids2++ -- multiplexing function+ -- \ (xs) -> (((xs1),()),(xs2))++ core_mux <- matchEnv env_ids+ (mkCorePairExpr+ (mkCorePairExpr (mkBigCoreVarTup env_ids1) mkCoreUnitExpr)+ (mkBigCoreVarTup env_ids2))++ -- projection function+ -- \ (p, (xs2)) -> (zs)++ env_id <- newSysLocalDs env_ty2+ uniqs <- newUniqueSupply+ let+ after_c_ty = mkCorePairTy pat_ty env_ty2+ out_ty = mkBigCoreVarTupTy out_ids+ body_expr = coreCaseTuple uniqs env_id env_ids2 (mkBigCoreVarTup out_ids)++ fail_expr <- mkFailExpr (StmtCtxt DoExpr) out_ty+ pat_id <- selectSimpleMatchVarL pat+ match_code <- matchSimply (Var pat_id) (StmtCtxt DoExpr) pat body_expr fail_expr+ pair_id <- newSysLocalDs after_c_ty+ let+ proj_expr = Lam pair_id (coreCasePair pair_id pat_id env_id match_code)++ -- put it all together+ let+ in_ty = mkBigCoreVarTupTy env_ids+ in_ty1 = mkCorePairTy (mkBigCoreVarTupTy env_ids1) unitTy+ in_ty2 = mkBigCoreVarTupTy env_ids2+ before_c_ty = mkCorePairTy in_ty1 in_ty2+ return (do_premap ids in_ty before_c_ty out_ty core_mux $+ do_compose ids before_c_ty after_c_ty out_ty+ (do_first ids in_ty1 pat_ty in_ty2 core_cmd) $+ do_arr ids after_c_ty out_ty proj_expr,+ fv_cmd `unionVarSet` (mkVarSet out_ids `minusVarSet` pat_vars))++-- D; xs' |-a do { ss } : t+-- --------------------------------------+-- D; xs |-a do { let binds; ss } : t+--+-- ---> arr (\ (xs) -> let binds in (xs')) >>> ss++dsCmdStmt ids local_vars out_ids (LetStmt binds) env_ids = do+ -- build a new environment using the let bindings+ core_binds <- dsLocalBinds binds (mkBigCoreVarTup out_ids)+ -- match the old environment against the input+ core_map <- matchEnv env_ids core_binds+ return (do_arr ids+ (mkBigCoreVarTupTy env_ids)+ (mkBigCoreVarTupTy out_ids)+ core_map,+ exprFreeIds core_binds `intersectVarSet` local_vars)++-- D; ys |-a do { ss; returnA -< ((xs1), (ys2)) } : ...+-- D; xs' |-a do { ss' } : t+-- ------------------------------------+-- D; xs |-a do { rec ss; ss' } : t+--+-- xs1 = xs' /\ defs(ss)+-- xs2 = xs' - defs(ss)+-- ys1 = ys - defs(ss)+-- ys2 = ys /\ defs(ss)+--+-- ---> arr (\(xs) -> ((ys1),(xs2))) >>>+-- first (loop (arr (\((ys1),~(ys2)) -> (ys)) >>> ss)) >>>+-- arr (\((xs1),(xs2)) -> (xs')) >>> ss'++dsCmdStmt ids local_vars out_ids+ (RecStmt { recS_stmts = stmts+ , recS_later_ids = later_ids, recS_rec_ids = rec_ids+ , recS_later_rets = later_rets, recS_rec_rets = rec_rets })+ env_ids = do+ let+ env2_id_set = mkVarSet out_ids `minusVarSet` mkVarSet later_ids+ env2_ids = varSetElems env2_id_set+ env2_ty = mkBigCoreVarTupTy env2_ids++ -- post_loop_fn = \((later_ids),(env2_ids)) -> (out_ids)++ uniqs <- newUniqueSupply+ env2_id <- newSysLocalDs env2_ty+ let+ later_ty = mkBigCoreVarTupTy later_ids+ post_pair_ty = mkCorePairTy later_ty env2_ty+ post_loop_body = coreCaseTuple uniqs env2_id env2_ids (mkBigCoreVarTup out_ids)++ post_loop_fn <- matchEnvStack later_ids env2_id post_loop_body++ --- loop (...)++ (core_loop, env1_id_set, env1_ids)+ <- dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets++ -- pre_loop_fn = \(env_ids) -> ((env1_ids),(env2_ids))++ let+ env1_ty = mkBigCoreVarTupTy env1_ids+ pre_pair_ty = mkCorePairTy env1_ty env2_ty+ pre_loop_body = mkCorePairExpr (mkBigCoreVarTup env1_ids)+ (mkBigCoreVarTup env2_ids)++ pre_loop_fn <- matchEnv env_ids pre_loop_body++ -- arr pre_loop_fn >>> first (loop (...)) >>> arr post_loop_fn++ let+ env_ty = mkBigCoreVarTupTy env_ids+ out_ty = mkBigCoreVarTupTy out_ids+ core_body = do_premap ids env_ty pre_pair_ty out_ty+ pre_loop_fn+ (do_compose ids pre_pair_ty post_pair_ty out_ty+ (do_first ids env1_ty later_ty env2_ty+ core_loop)+ (do_arr ids post_pair_ty out_ty+ post_loop_fn))++ return (core_body, env1_id_set `unionVarSet` env2_id_set)++dsCmdStmt _ _ _ _ s = pprPanic "dsCmdStmt" (ppr s)++-- loop (premap (\ ((env1_ids), ~(rec_ids)) -> (env_ids))+-- (ss >>> arr (\ (out_ids) -> ((later_rets),(rec_rets))))) >>>++dsRecCmd+ :: DsCmdEnv -- arrow combinators+ -> IdSet -- set of local vars available to this statement+ -> [CmdLStmt Id] -- list of statements inside the RecCmd+ -> [Id] -- list of vars defined here and used later+ -> [HsExpr Id] -- expressions corresponding to later_ids+ -> [Id] -- list of vars fed back through the loop+ -> [HsExpr Id] -- expressions corresponding to rec_ids+ -> DsM (CoreExpr, -- desugared statement+ IdSet, -- subset of local vars that occur free+ [Id]) -- same local vars as a list++dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets = do+ let+ later_id_set = mkVarSet later_ids+ rec_id_set = mkVarSet rec_ids+ local_vars' = rec_id_set `unionVarSet` later_id_set `unionVarSet` local_vars++ -- mk_pair_fn = \ (out_ids) -> ((later_rets),(rec_rets))++ core_later_rets <- mapM dsExpr later_rets+ core_rec_rets <- mapM dsExpr rec_rets+ let+ -- possibly polymorphic version of vars of later_ids and rec_ids+ out_ids = varSetElems (unionVarSets (map exprFreeIds (core_later_rets ++ core_rec_rets)))+ out_ty = mkBigCoreVarTupTy out_ids++ later_tuple = mkBigCoreTup core_later_rets+ later_ty = mkBigCoreVarTupTy later_ids++ rec_tuple = mkBigCoreTup core_rec_rets+ rec_ty = mkBigCoreVarTupTy rec_ids++ out_pair = mkCorePairExpr later_tuple rec_tuple+ out_pair_ty = mkCorePairTy later_ty rec_ty++ mk_pair_fn <- matchEnv out_ids out_pair++ -- ss++ (core_stmts, fv_stmts, env_ids) <- dsfixCmdStmts ids local_vars' out_ids stmts++ -- squash_pair_fn = \ ((env1_ids), ~(rec_ids)) -> (env_ids)++ rec_id <- newSysLocalDs rec_ty+ let+ env1_id_set = fv_stmts `minusVarSet` rec_id_set+ env1_ids = varSetElems env1_id_set+ env1_ty = mkBigCoreVarTupTy env1_ids+ in_pair_ty = mkCorePairTy env1_ty rec_ty+ core_body = mkBigCoreTup (map selectVar env_ids)+ where+ selectVar v+ | v `elemVarSet` rec_id_set+ = mkTupleSelector rec_ids v rec_id (Var rec_id)+ | otherwise = Var v++ squash_pair_fn <- matchEnvStack env1_ids rec_id core_body++ -- loop (premap squash_pair_fn (ss >>> arr mk_pair_fn))++ let+ env_ty = mkBigCoreVarTupTy env_ids+ core_loop = do_loop ids env1_ty later_ty rec_ty+ (do_premap ids in_pair_ty env_ty out_pair_ty+ squash_pair_fn+ (do_compose ids env_ty out_ty out_pair_ty+ core_stmts+ (do_arr ids out_ty out_pair_ty mk_pair_fn)))++ return (core_loop, env1_id_set, env1_ids)++{-+A sequence of statements (as in a rec) is desugared to an arrow between+two environments (no stack)+-}++dsfixCmdStmts+ :: DsCmdEnv -- arrow combinators+ -> IdSet -- set of local vars available to this statement+ -> [Id] -- output vars of these statements+ -> [CmdLStmt Id] -- statements to desugar+ -> DsM (CoreExpr, -- desugared expression+ IdSet, -- subset of local vars that occur free+ [Id]) -- same local vars as a list++dsfixCmdStmts ids local_vars out_ids stmts+ = trimInput (dsCmdStmts ids local_vars out_ids stmts)++dsCmdStmts+ :: DsCmdEnv -- arrow combinators+ -> IdSet -- set of local vars available to this statement+ -> [Id] -- output vars of these statements+ -> [CmdLStmt Id] -- statements to desugar+ -> [Id] -- list of vars in the input to these statements+ -> DsM (CoreExpr, -- desugared expression+ IdSet) -- subset of local vars that occur free++dsCmdStmts ids local_vars out_ids [stmt] env_ids+ = dsCmdLStmt ids local_vars out_ids stmt env_ids++dsCmdStmts ids local_vars out_ids (stmt:stmts) env_ids = do+ let+ bound_vars = mkVarSet (collectLStmtBinders stmt)+ local_vars' = bound_vars `unionVarSet` local_vars+ (core_stmts, _fv_stmts, env_ids') <- dsfixCmdStmts ids local_vars' out_ids stmts+ (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids+ return (do_compose ids+ (mkBigCoreVarTupTy env_ids)+ (mkBigCoreVarTupTy env_ids')+ (mkBigCoreVarTupTy out_ids)+ core_stmt+ core_stmts,+ fv_stmt)++dsCmdStmts _ _ _ [] _ = panic "dsCmdStmts []"++-- Match a list of expressions against a list of patterns, left-to-right.++matchSimplys :: [CoreExpr] -- Scrutinees+ -> HsMatchContext Name -- Match kind+ -> [LPat Id] -- Patterns they should match+ -> CoreExpr -- Return this if they all match+ -> CoreExpr -- Return this if they don't+ -> DsM CoreExpr+matchSimplys [] _ctxt [] result_expr _fail_expr = return result_expr+matchSimplys (exp:exps) ctxt (pat:pats) result_expr fail_expr = do+ match_code <- matchSimplys exps ctxt pats result_expr fail_expr+ matchSimply exp ctxt pat match_code fail_expr+matchSimplys _ _ _ _ _ = panic "matchSimplys"++-- List of leaf expressions, with set of variables bound in each++leavesMatch :: LMatch Id (Located (body Id)) -> [(Located (body Id), IdSet)]+leavesMatch (L _ (Match _ pats _ (GRHSs grhss binds)))+ = let+ defined_vars = mkVarSet (collectPatsBinders pats)+ `unionVarSet`+ mkVarSet (collectLocalBinders binds)+ in+ [(body,+ mkVarSet (collectLStmtsBinders stmts)+ `unionVarSet` defined_vars)+ | L _ (GRHS stmts body) <- grhss]++-- Replace the leaf commands in a match++replaceLeavesMatch+ :: Type -- new result type+ -> [Located (body' Id)] -- replacement leaf expressions of that type+ -> LMatch Id (Located (body Id)) -- the matches of a case command+ -> ([Located (body' Id)], -- remaining leaf expressions+ LMatch Id (Located (body' Id))) -- updated match+replaceLeavesMatch _res_ty leaves (L loc (Match mf pat mt (GRHSs grhss binds)))+ = let+ (leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss+ in+ (leaves', L loc (Match mf pat mt (GRHSs grhss' binds)))++replaceLeavesGRHS+ :: [Located (body' Id)] -- replacement leaf expressions of that type+ -> LGRHS Id (Located (body Id)) -- rhss of a case command+ -> ([Located (body' Id)], -- remaining leaf expressions+ LGRHS Id (Located (body' Id))) -- updated GRHS+replaceLeavesGRHS (leaf:leaves) (L loc (GRHS stmts _))+ = (leaves, L loc (GRHS stmts leaf))+replaceLeavesGRHS [] _ = panic "replaceLeavesGRHS []"++-- Balanced fold of a non-empty list.++foldb :: (a -> a -> a) -> [a] -> a+foldb _ [] = error "foldb of empty list"+foldb _ [x] = x+foldb f xs = foldb f (fold_pairs xs)+ where+ fold_pairs [] = []+ fold_pairs [x] = [x]+ fold_pairs (x1:x2:xs) = f x1 x2:fold_pairs xs++{-+Note [Dictionary binders in ConPatOut] See also same Note in HsUtils+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The following functions to collect value variables from patterns are+copied from HsUtils, with one change: we also collect the dictionary+bindings (pat_binds) from ConPatOut. We need them for cases like++h :: Arrow a => Int -> a (Int,Int) Int+h x = proc (y,z) -> case compare x y of+ GT -> returnA -< z+x++The type checker turns the case into++ case compare x y of+ GT { p77 = plusInt } -> returnA -< p77 z x++Here p77 is a local binding for the (+) operation.++See comments in HsUtils for why the other version does not include+these bindings.+-}++collectPatBinders :: LPat Id -> [Id]+collectPatBinders pat = collectl pat []++collectPatsBinders :: [LPat Id] -> [Id]+collectPatsBinders pats = foldr collectl [] pats++---------------------+collectl :: LPat Id -> [Id] -> [Id]+-- See Note [Dictionary binders in ConPatOut]+collectl (L _ pat) bndrs+ = go pat+ where+ go (VarPat var) = var : bndrs+ go (WildPat _) = bndrs+ go (LazyPat pat) = collectl pat bndrs+ go (BangPat pat) = collectl pat bndrs+ go (AsPat (L _ a) pat) = a : collectl pat bndrs+ go (ParPat pat) = collectl pat bndrs++ go (ListPat pats _ _) = foldr collectl bndrs pats+ go (PArrPat pats _) = foldr collectl bndrs pats+ go (TuplePat pats _ _) = foldr collectl bndrs pats++ go (ConPatIn _ ps) = foldr collectl bndrs (hsConPatArgs ps)+ go (ConPatOut {pat_args=ps, pat_binds=ds}) =+ collectEvBinders ds+ ++ foldr collectl bndrs (hsConPatArgs ps)+ go (LitPat _) = bndrs+ go (NPat _ _ _) = bndrs+ go (NPlusKPat (L _ n) _ _ _) = n : bndrs++ go (SigPatIn pat _) = collectl pat bndrs+ go (SigPatOut pat _) = collectl pat bndrs+ go (CoPat _ pat _) = collectl (noLoc pat) bndrs+ go (ViewPat _ pat _) = collectl pat bndrs+ go p@(SplicePat {}) = pprPanic "collectl/go" (ppr p)+ go p@(QuasiQuotePat {}) = pprPanic "collectl/go" (ppr p)++collectEvBinders :: TcEvBinds -> [Id]+collectEvBinders (EvBinds bs) = foldrBag add_ev_bndr [] bs+collectEvBinders (TcEvBinds {}) = panic "ToDo: collectEvBinders"++add_ev_bndr :: EvBind -> [Id] -> [Id]+add_ev_bndr (EvBind b _) bs | isId b = b:bs+ | otherwise = bs+ -- A worry: what about coercion variable binders??++collectLStmtsBinders :: [LStmt Id body] -> [Id]+collectLStmtsBinders = concatMap collectLStmtBinders++collectLStmtBinders :: LStmt Id body -> [Id]+collectLStmtBinders = collectStmtBinders . unLoc++collectStmtBinders :: Stmt Id body -> [Id]+collectStmtBinders (BindStmt pat _ _ _) = collectPatBinders pat+collectStmtBinders (LetStmt binds) = collectLocalBinders binds+collectStmtBinders (BodyStmt {}) = []+collectStmtBinders (LastStmt {}) = []+collectStmtBinders (ParStmt xs _ _) = collectLStmtsBinders+ $ [ s | ParStmtBlock ss _ _ <- xs, s <- ss]+collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts+collectStmtBinders (RecStmt { recS_later_ids = later_ids }) = later_ids
+ src/Language/Haskell/Liquid/Desugar710/DsBinds.hs view
@@ -0,0 +1,1196 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++Pattern-matching bindings (HsBinds and MonoBinds)++Handles @HsBinds@; those at the top level require different handling,+in that the @Rec@/@NonRec@/etc structure is thrown away (whereas at+lower levels it is preserved with @let@/@letrec@s).+-}++{-# LANGUAGE CPP #-}++module Language.Haskell.Liquid.Desugar710.DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec,+ dsHsWrapper, dsTcEvBinds, dsEvBinds+ ) where++-- #include "HsVersions.h"++import {-# SOURCE #-} Language.Haskell.Liquid.Desugar710.DsExpr( dsLExpr )+import {-# SOURCE #-} Language.Haskell.Liquid.Desugar710.Match( matchWrapper )++import DsMonad+import Language.Haskell.Liquid.Desugar710.DsGRHSs+import Language.Haskell.Liquid.Desugar710.DsUtils++import HsSyn -- lots of things+import CoreSyn -- lots of things+import Literal ( Literal(MachStr) )+import CoreSubst+import OccurAnal ( occurAnalyseExpr )+import MkCore+import CoreUtils+import CoreArity ( etaExpand )+import CoreUnfold+import CoreFVs+import UniqSupply+import Digraph+import Module+import PrelNames+import TysPrim ( mkProxyPrimTy )+import TyCon ( tyConDataCons_maybe+ , tyConName, isPromotedTyCon, isPromotedDataCon )+import TcEvidence+import TcType+import Type+import Coercion hiding (substCo)+import TysWiredIn ( eqBoxDataCon, coercibleDataCon, mkListTy+ , mkBoxedTupleTy, stringTy, tupleCon )+import Id+import MkId(proxyHashId)+import Class+import DataCon ( dataConWorkId, dataConTyCon )+import Name+import MkId ( seqId )+import IdInfo ( IdDetails(..) )+import Var+import VarSet+import Rules+import VarEnv+import Outputable+import SrcLoc+import Maybes+import OrdList+import Bag+import BasicTypes hiding ( TopLevel )+import DynFlags+import FastString+import ErrUtils( MsgDoc )+import ListSetOps( getNth )+import Util+import Control.Monad( when )+import MonadUtils+import Control.Monad(liftM)+import Fingerprint(Fingerprint(..), fingerprintString)++{-+************************************************************************+* *+\subsection[dsMonoBinds]{Desugaring a @MonoBinds@}+* *+************************************************************************+-}++dsTopLHsBinds :: LHsBinds Id -> DsM (OrdList (Id,CoreExpr))+dsTopLHsBinds binds = ds_lhs_binds binds++dsLHsBinds :: LHsBinds Id -> DsM [(Id,CoreExpr)]+dsLHsBinds binds = do { binds' <- ds_lhs_binds binds+ ; return (fromOL binds') }++------------------------+ds_lhs_binds :: LHsBinds Id -> DsM (OrdList (Id,CoreExpr))++ds_lhs_binds binds = do { ds_bs <- mapBagM dsLHsBind binds+ ; return (foldBag appOL id nilOL ds_bs) }++dsLHsBind :: LHsBind Id -> DsM (OrdList (Id,CoreExpr))+dsLHsBind (L loc bind) = putSrcSpanDs loc $ dsHsBind bind++dsHsBind :: HsBind Id -> DsM (OrdList (Id,CoreExpr))++dsHsBind (VarBind { var_id = var, var_rhs = expr, var_inline = inline_regardless })+ = do { dflags <- getDynFlags+ ; core_expr <- dsLExpr expr++ -- Dictionary bindings are always VarBinds,+ -- so we only need do this here+ ; let var' | inline_regardless = var `setIdUnfolding` mkCompulsoryUnfolding core_expr+ | otherwise = var++ ; return (unitOL (makeCorePair dflags var' False 0 core_expr)) }++dsHsBind (FunBind { fun_id = L _ fun, fun_matches = matches+ , fun_co_fn = co_fn, fun_tick = tick+ , fun_infix = inf })+ = do { dflags <- getDynFlags+ ; (args, body) <- matchWrapper (FunRhs (idName fun) inf) matches+ ; let body' = mkOptTickBox tick body+ ; rhs <- dsHsWrapper co_fn (mkLams args body')+ ; {- pprTrace "dsHsBind" (ppr fun <+> ppr (idInlinePragma fun)) $ -}+ return (unitOL (makeCorePair dflags fun False 0 rhs)) }++dsHsBind (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty+ , pat_ticks = (rhs_tick, var_ticks) })+ = do { body_expr <- dsGuarded grhss ty+ ; let body' = mkOptTickBox rhs_tick body_expr+ ; sel_binds <- mkSelectorBinds var_ticks pat body'+ -- We silently ignore inline pragmas; no makeCorePair+ -- Not so cool, but really doesn't matter+ ; return (toOL sel_binds) }++ -- A common case: one exported variable+ -- Non-recursive bindings come through this way+ -- So do self-recursive bindings, and recursive bindings+ -- that have been chopped up with type signatures+dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts+ , abs_exports = [export]+ , abs_ev_binds = ev_binds, abs_binds = binds })+ | ABE { abe_wrap = wrap, abe_poly = global+ , abe_mono = local, abe_prags = prags } <- export+ = do { dflags <- getDynFlags+ ; bind_prs <- ds_lhs_binds binds+ ; let core_bind = Rec (fromOL bind_prs)+ ; ds_binds <- dsTcEvBinds ev_binds+ ; rhs <- dsHsWrapper wrap $ -- Usually the identity+ mkLams tyvars $ mkLams dicts $+ mkCoreLets ds_binds $+ Let core_bind $+ Var local++ ; (spec_binds, rules) <- dsSpecs rhs prags++ ; let global' = addIdSpecialisations global rules+ main_bind = makeCorePair dflags global' (isDefaultMethod prags)+ (dictArity dicts) rhs++ ; return (main_bind `consOL` spec_binds) }++dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts+ , abs_exports = exports, abs_ev_binds = ev_binds+ , abs_binds = binds })+ -- See Note [Desugaring AbsBinds]+ = do { dflags <- getDynFlags+ ; bind_prs <- ds_lhs_binds binds+ ; let core_bind = Rec [ makeCorePair dflags (add_inline lcl_id) False 0 rhs+ | (lcl_id, rhs) <- fromOL bind_prs ]+ -- Monomorphic recursion possible, hence Rec++ locals = map abe_mono exports+ tup_expr = mkBigCoreVarTup locals+ tup_ty = exprType tup_expr+ ; ds_binds <- dsTcEvBinds ev_binds+ ; let poly_tup_rhs = mkLams tyvars $ mkLams dicts $+ mkCoreLets ds_binds $+ Let core_bind $+ tup_expr++ ; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs)++ ; let mk_bind (ABE { abe_wrap = wrap, abe_poly = global+ , abe_mono = local, abe_prags = spec_prags })+ = do { tup_id <- newSysLocalDs tup_ty+ ; rhs <- dsHsWrapper wrap $+ mkLams tyvars $ mkLams dicts $+ mkTupleSelector locals local tup_id $+ mkVarApps (Var poly_tup_id) (tyvars ++ dicts)+ ; let rhs_for_spec = Let (NonRec poly_tup_id poly_tup_rhs) rhs+ ; (spec_binds, rules) <- dsSpecs rhs_for_spec spec_prags+ ; let global' = (global `setInlinePragma` defaultInlinePragma)+ `addIdSpecialisations` rules+ -- Kill the INLINE pragma because it applies to+ -- the user written (local) function. The global+ -- Id is just the selector. Hmm.+ ; return ((global', rhs) `consOL` spec_binds) }++ ; export_binds_s <- mapM mk_bind exports++ ; return ((poly_tup_id, poly_tup_rhs) `consOL`+ concatOL export_binds_s) }+ where+ inline_env :: IdEnv Id -- Maps a monomorphic local Id to one with+ -- the inline pragma from the source+ -- The type checker put the inline pragma+ -- on the *global* Id, so we need to transfer it+ inline_env = mkVarEnv [ (lcl_id, setInlinePragma lcl_id prag)+ | ABE { abe_mono = lcl_id, abe_poly = gbl_id } <- exports+ , let prag = idInlinePragma gbl_id ]++ add_inline :: Id -> Id -- tran+ add_inline lcl_id = lookupVarEnv inline_env lcl_id `orElse` lcl_id++dsHsBind (PatSynBind{}) = panic "dsHsBind: PatSynBind"++------------------------+makeCorePair :: DynFlags -> Id -> Bool -> Arity -> CoreExpr -> (Id, CoreExpr)+makeCorePair dflags gbl_id is_default_method dict_arity rhs+ | is_default_method -- Default methods are *always* inlined+ = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding rhs, rhs)++ | DFunId _ is_newtype <- idDetails gbl_id+ = (mk_dfun_w_stuff is_newtype, rhs)++ | otherwise+ = case inlinePragmaSpec inline_prag of+ EmptyInlineSpec -> (gbl_id, rhs)+ NoInline -> (gbl_id, rhs)+ Inlinable -> (gbl_id `setIdUnfolding` inlinable_unf, rhs)+ Inline -> inline_pair++ where+ inline_prag = idInlinePragma gbl_id+ inlinable_unf = mkInlinableUnfolding dflags rhs+ inline_pair+ | Just arity <- inlinePragmaSat inline_prag+ -- Add an Unfolding for an INLINE (but not for NOINLINE)+ -- And eta-expand the RHS; see Note [Eta-expanding INLINE things]+ , let real_arity = dict_arity + arity+ -- NB: The arity in the InlineRule takes account of the dictionaries+ = ( gbl_id `setIdUnfolding` mkInlineUnfolding (Just real_arity) rhs+ , etaExpand real_arity rhs)++ | otherwise+ = pprTrace "makeCorePair: arity missing" (ppr gbl_id) $+ (gbl_id `setIdUnfolding` mkInlineUnfolding Nothing rhs, rhs)++ -- See Note [ClassOp/DFun selection] in TcInstDcls+ -- See Note [Single-method classes] in TcInstDcls+ mk_dfun_w_stuff is_newtype+ | is_newtype+ = gbl_id `setIdUnfolding` mkInlineUnfolding (Just 0) rhs+ `setInlinePragma` alwaysInlinePragma { inl_sat = Just 0 }+ | otherwise+ = gbl_id `setIdUnfolding` mkDFunUnfolding dfun_bndrs dfun_constr dfun_args+ `setInlinePragma` dfunInlinePragma+ (dfun_bndrs, dfun_body) = collectBinders (simpleOptExpr rhs)+ (dfun_con, dfun_args, _) = collectArgsTicks (const True) dfun_body+ dfun_constr | Var id <- dfun_con+ , DataConWorkId con <- idDetails id+ = con+ | otherwise = pprPanic "makeCorePair: dfun" (ppr rhs)+++dictArity :: [Var] -> Arity+-- Don't count coercion variables in arity+dictArity dicts = count isId dicts++{-+[Desugaring AbsBinds]+~~~~~~~~~~~~~~~~~~~~~+In the general AbsBinds case we desugar the binding to this:++ tup a (d:Num a) = let fm = ...gm...+ gm = ...fm...+ in (fm,gm)+ f a d = case tup a d of { (fm,gm) -> fm }+ g a d = case tup a d of { (fm,gm) -> fm }++Note [Rules and inlining]+~~~~~~~~~~~~~~~~~~~~~~~~~+Common special case: no type or dictionary abstraction+This is a bit less trivial than you might suppose+The naive way woudl be to desguar to something like+ f_lcl = ...f_lcl... -- The "binds" from AbsBinds+ M.f = f_lcl -- Generated from "exports"+But we don't want that, because if M.f isn't exported,+it'll be inlined unconditionally at every call site (its rhs is+trivial). That would be ok unless it has RULES, which would+thereby be completely lost. Bad, bad, bad.++Instead we want to generate+ M.f = ...f_lcl...+ f_lcl = M.f+Now all is cool. The RULES are attached to M.f (by SimplCore),+and f_lcl is rapidly inlined away.++This does not happen in the same way to polymorphic binds,+because they desugar to+ M.f = /\a. let f_lcl = ...f_lcl... in f_lcl+Although I'm a bit worried about whether full laziness might+float the f_lcl binding out and then inline M.f at its call site++Note [Specialising in no-dict case]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Even if there are no tyvars or dicts, we may have specialisation pragmas.+Class methods can generate+ AbsBinds [] [] [( ... spec-prag]+ { AbsBinds [tvs] [dicts] ...blah }+So the overloading is in the nested AbsBinds. A good example is in GHC.Float:++ class (Real a, Fractional a) => RealFrac a where+ round :: (Integral b) => a -> b++ instance RealFrac Float where+ {-# SPECIALIZE round :: Float -> Int #-}++The top-level AbsBinds for $cround has no tyvars or dicts (because the+instance does not). But the method is locally overloaded!++Note [Abstracting over tyvars only]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When abstracting over type variable only (not dictionaries), we don't really need to+built a tuple and select from it, as we do in the general case. Instead we can take++ AbsBinds [a,b] [ ([a,b], fg, fl, _),+ ([b], gg, gl, _) ]+ { fl = e1+ gl = e2+ h = e3 }++and desugar it to++ fg = /\ab. let B in e1+ gg = /\b. let a = () in let B in S(e2)+ h = /\ab. let B in e3++where B is the *non-recursive* binding+ fl = fg a b+ gl = gg b+ h = h a b -- See (b); note shadowing!++Notice (a) g has a different number of type variables to f, so we must+ use the mkArbitraryType thing to fill in the gaps.+ We use a type-let to do that.++ (b) The local variable h isn't in the exports, and rather than+ clone a fresh copy we simply replace h by (h a b), where+ the two h's have different types! Shadowing happens here,+ which looks confusing but works fine.++ (c) The result is *still* quadratic-sized if there are a lot of+ small bindings. So if there are more than some small+ number (10), we filter the binding set B by the free+ variables of the particular RHS. Tiresome.++Why got to this trouble? It's a common case, and it removes the+quadratic-sized tuple desugaring. Less clutter, hopefully faster+compilation, especially in a case where there are a *lot* of+bindings.+++Note [Eta-expanding INLINE things]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+ foo :: Eq a => a -> a+ {-# INLINE foo #-}+ foo x = ...++If (foo d) ever gets floated out as a common sub-expression (which can+happen as a result of method sharing), there's a danger that we never+get to do the inlining, which is a Terribly Bad thing given that the+user said "inline"!++To avoid this we pre-emptively eta-expand the definition, so that foo+has the arity with which it is declared in the source code. In this+example it has arity 2 (one for the Eq and one for x). Doing this+should mean that (foo d) is a PAP and we don't share it.++Note [Nested arities]+~~~~~~~~~~~~~~~~~~~~~+For reasons that are not entirely clear, method bindings come out looking like+this:++ AbsBinds [] [] [$cfromT <= [] fromT]+ $cfromT [InlPrag=INLINE] :: T Bool -> Bool+ { AbsBinds [] [] [fromT <= [] fromT_1]+ fromT :: T Bool -> Bool+ { fromT_1 ((TBool b)) = not b } } }++Note the nested AbsBind. The arity for the InlineRule on $cfromT should be+gotten from the binding for fromT_1.++It might be better to have just one level of AbsBinds, but that requires more+thought!++Note [Implementing SPECIALISE pragmas]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Example:+ f :: (Eq a, Ix b) => a -> b -> Bool+ {-# SPECIALISE f :: (Ix p, Ix q) => Int -> (p,q) -> Bool #-}+ f = <poly_rhs>++From this the typechecker generates++ AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds++ SpecPrag (wrap_fn :: forall a b. (Eq a, Ix b) => XXX+ -> forall p q. (Ix p, Ix q) => XXX[ Int/a, (p,q)/b ])++Note that wrap_fn can transform *any* function with the right type prefix+ forall ab. (Eq a, Ix b) => XXX+regardless of XXX. It's sort of polymorphic in XXX. This is+useful: we use the same wrapper to transform each of the class ops, as+well as the dict.++From these we generate:++ Rule: forall p, q, (dp:Ix p), (dq:Ix q).+ f Int (p,q) dInt ($dfInPair dp dq) = f_spec p q dp dq++ Spec bind: f_spec = wrap_fn <poly_rhs>++Note that++ * The LHS of the rule may mention dictionary *expressions* (eg+ $dfIxPair dp dq), and that is essential because the dp, dq are+ needed on the RHS.++ * The RHS of f_spec, <poly_rhs> has a *copy* of 'binds', so that it+ can fully specialise it.+-}++------------------------+dsSpecs :: CoreExpr -- Its rhs+ -> TcSpecPrags+ -> DsM ( OrdList (Id,CoreExpr) -- Binding for specialised Ids+ , [CoreRule] ) -- Rules for the Global Ids+-- See Note [Implementing SPECIALISE pragmas]+dsSpecs _ IsDefaultMethod = return (nilOL, [])+dsSpecs poly_rhs (SpecPrags sps)+ = do { pairs <- mapMaybeM (dsSpec (Just poly_rhs)) sps+ ; let (spec_binds_s, rules) = unzip pairs+ ; return (concatOL spec_binds_s, rules) }++dsSpec :: Maybe CoreExpr -- Just rhs => RULE is for a local binding+ -- Nothing => RULE is for an imported Id+ -- rhs is in the Id's unfolding+ -> Located TcSpecPrag+ -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))+dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))+ | isJust (isClassOpId_maybe poly_id)+ = putSrcSpanDs loc $+ do { warnDs (ptext (sLit "Ignoring useless SPECIALISE pragma for class method selector")+ <+> quotes (ppr poly_id))+ ; return Nothing } -- There is no point in trying to specialise a class op+ -- Moreover, classops don't (currently) have an inl_sat arity set+ -- (it would be Just 0) and that in turn makes makeCorePair bleat++ | no_act_spec && isNeverActive rule_act+ = putSrcSpanDs loc $+ do { warnDs (ptext (sLit "Ignoring useless SPECIALISE pragma for NOINLINE function:")+ <+> quotes (ppr poly_id))+ ; return Nothing } -- Function is NOINLINE, and the specialiation inherits that+ -- See Note [Activation pragmas for SPECIALISE]++ | otherwise+ = putSrcSpanDs loc $+ do { uniq <- newUnique+ ; let poly_name = idName poly_id+ spec_occ = mkSpecOcc (getOccName poly_name)+ spec_name = mkInternalName uniq spec_occ (getSrcSpan poly_name)+ ; (bndrs, ds_lhs) <- liftM collectBinders+ (dsHsWrapper spec_co (Var poly_id))+ ; let spec_ty = mkPiTypes bndrs (exprType ds_lhs)+ ; -- pprTrace "dsRule" (vcat [ ptext (sLit "Id:") <+> ppr poly_id+ -- , ptext (sLit "spec_co:") <+> ppr spec_co+ -- , ptext (sLit "ds_rhs:") <+> ppr ds_lhs ]) $+ case decomposeRuleLhs bndrs ds_lhs of {+ Left msg -> do { warnDs msg; return Nothing } ;+ Right (rule_bndrs, _fn, args) -> do++ { dflags <- getDynFlags+ ; let fn_unf = realIdUnfolding poly_id+ unf_fvs = stableUnfoldingVars fn_unf `orElse` emptyVarSet+ in_scope = mkInScopeSet (unf_fvs `unionVarSet` exprsFreeVars args)+ spec_unf = specUnfolding dflags (mkEmptySubst in_scope) bndrs args fn_unf+ spec_id = mkLocalId spec_name spec_ty+ `setInlinePragma` inl_prag+ `setIdUnfolding` spec_unf+ rule = mkRule False {- Not auto -} is_local_id+ (mkFastString ("SPEC " ++ showPpr dflags poly_name))+ rule_act poly_name+ rule_bndrs args+ (mkVarApps (Var spec_id) bndrs)++ ; spec_rhs <- dsHsWrapper spec_co poly_rhs++ ; when (isInlinePragma id_inl && wopt Opt_WarnPointlessPragmas dflags)+ (warnDs (specOnInline poly_name))++ ; return (Just (unitOL (spec_id, spec_rhs), rule))+ -- NB: do *not* use makeCorePair on (spec_id,spec_rhs), because+ -- makeCorePair overwrites the unfolding, which we have+ -- just created using specUnfolding+ } } }+ where+ is_local_id = isJust mb_poly_rhs+ poly_rhs | Just rhs <- mb_poly_rhs+ = rhs -- Local Id; this is its rhs+ | Just unfolding <- maybeUnfoldingTemplate (realIdUnfolding poly_id)+ = unfolding -- Imported Id; this is its unfolding+ -- Use realIdUnfolding so we get the unfolding+ -- even when it is a loop breaker.+ -- We want to specialise recursive functions!+ | otherwise = pprPanic "dsImpSpecs" (ppr poly_id)+ -- The type checker has checked that it *has* an unfolding++ id_inl = idInlinePragma poly_id++ -- See Note [Activation pragmas for SPECIALISE]+ inl_prag | not (isDefaultInlinePragma spec_inl) = spec_inl+ | not is_local_id -- See Note [Specialising imported functions]+ -- in OccurAnal+ , isStrongLoopBreaker (idOccInfo poly_id) = neverInlinePragma+ | otherwise = id_inl+ -- Get the INLINE pragma from SPECIALISE declaration, or,+ -- failing that, from the original Id++ spec_prag_act = inlinePragmaActivation spec_inl++ -- See Note [Activation pragmas for SPECIALISE]+ -- no_act_spec is True if the user didn't write an explicit+ -- phase specification in the SPECIALISE pragma+ no_act_spec = case inlinePragmaSpec spec_inl of+ NoInline -> isNeverActive spec_prag_act+ _ -> isAlwaysActive spec_prag_act+ rule_act | no_act_spec = inlinePragmaActivation id_inl -- Inherit+ | otherwise = spec_prag_act -- Specified by user+++specOnInline :: Name -> MsgDoc+specOnInline f = ptext (sLit "SPECIALISE pragma on INLINE function probably won't fire:")+ <+> quotes (ppr f)++{-+Note [Activation pragmas for SPECIALISE]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+From a user SPECIALISE pragma for f, we generate+ a) A top-level binding spec_fn = rhs+ b) A RULE f dOrd = spec_fn++We need two pragma-like things:++* spec_fn's inline pragma: inherited from f's inline pragma (ignoring+ activation on SPEC), unless overriden by SPEC INLINE++* Activation of RULE: from SPECIALISE pragma (if activation given)+ otherwise from f's inline pragma++This is not obvious (see Trac #5237)!++Examples Rule activation Inline prag on spec'd fn+---------------------------------------------------------------------+SPEC [n] f :: ty [n] Always, or NOINLINE [n]+ copy f's prag++NOINLINE f+SPEC [n] f :: ty [n] NOINLINE+ copy f's prag++NOINLINE [k] f+SPEC [n] f :: ty [n] NOINLINE [k]+ copy f's prag++INLINE [k] f+SPEC [n] f :: ty [n] INLINE [k]+ copy f's prag++SPEC INLINE [n] f :: ty [n] INLINE [n]+ (ignore INLINE prag on f,+ same activation for rule and spec'd fn)++NOINLINE [k] f+SPEC f :: ty [n] INLINE [k]+++************************************************************************+* *+\subsection{Adding inline pragmas}+* *+************************************************************************+-}++decomposeRuleLhs :: [Var] -> CoreExpr -> Either SDoc ([Var], Id, [CoreExpr])+-- (decomposeRuleLhs bndrs lhs) takes apart the LHS of a RULE,+-- The 'bndrs' are the quantified binders of the rules, but decomposeRuleLhs+-- may add some extra dictionary binders (see Note [Free dictionaries])+--+-- Returns Nothing if the LHS isn't of the expected shape+-- Note [Decomposing the left-hand side of a RULE]+decomposeRuleLhs orig_bndrs orig_lhs+ | not (null unbound) -- Check for things unbound on LHS+ -- See Note [Unused spec binders]+ = Left (vcat (map dead_msg unbound))++ | Var fn_var <- fun+ , not (fn_var `elemVarSet` orig_bndr_set)+ = -- pprTrace "decmposeRuleLhs" (vcat [ ptext (sLit "orig_bndrs:") <+> ppr orig_bndrs+ -- , ptext (sLit "orig_lhs:") <+> ppr orig_lhs+ -- , ptext (sLit "lhs1:") <+> ppr lhs1+ -- , ptext (sLit "bndrs1:") <+> ppr bndrs1+ -- , ptext (sLit "fn_var:") <+> ppr fn_var+ -- , ptext (sLit "args:") <+> ppr args]) $+ Right (bndrs1, fn_var, args)++ | Case scrut bndr ty [(DEFAULT, _, body)] <- fun+ , isDeadBinder bndr -- Note [Matching seqId]+ , let args' = [Type (idType bndr), Type ty, scrut, body]+ = Right (bndrs1, seqId, args' ++ args)++ | otherwise+ = Left bad_shape_msg+ where+ lhs1 = drop_dicts orig_lhs+ lhs2 = simpleOptExpr lhs1 -- See Note [Simplify rule LHS]+ (fun,args) = collectArgs lhs2+ lhs_fvs = exprFreeVars lhs2+ unbound = filterOut (`elemVarSet` lhs_fvs) orig_bndrs+ bndrs1 = orig_bndrs ++ extra_dict_bndrs++ orig_bndr_set = mkVarSet orig_bndrs++ -- Add extra dict binders: Note [Free dictionaries]+ extra_dict_bndrs = [ mkLocalId (localiseName (idName d)) (idType d)+ | d <- varSetElems (lhs_fvs `delVarSetList` orig_bndrs)+ , isDictId d ]++ bad_shape_msg = hang (ptext (sLit "RULE left-hand side too complicated to desugar"))+ 2 (vcat [ text "Optimised lhs:" <+> ppr lhs2+ , text "Orig lhs:" <+> ppr orig_lhs])+ dead_msg bndr = hang (sep [ ptext (sLit "Forall'd") <+> pp_bndr bndr+ , ptext (sLit "is not bound in RULE lhs")])+ 2 (vcat [ text "Orig bndrs:" <+> ppr orig_bndrs+ , text "Orig lhs:" <+> ppr orig_lhs+ , text "optimised lhs:" <+> ppr lhs2 ])+ pp_bndr bndr+ | isTyVar bndr = ptext (sLit "type variable") <+> quotes (ppr bndr)+ | Just pred <- evVarPred_maybe bndr = ptext (sLit "constraint") <+> quotes (ppr pred)+ | otherwise = ptext (sLit "variable") <+> quotes (ppr bndr)++ drop_dicts :: CoreExpr -> CoreExpr+ drop_dicts e+ = wrap_lets needed bnds body+ where+ needed = orig_bndr_set `minusVarSet` exprFreeVars body+ (bnds, body) = split_lets (occurAnalyseExpr e)+ -- The occurAnalyseExpr drops dead bindings which is+ -- crucial to ensure that every binding is used later;+ -- which in turn makes wrap_lets work right++ split_lets :: CoreExpr -> ([(DictId,CoreExpr)], CoreExpr)+ split_lets e+ | Let (NonRec d r) body <- e+ , isDictId d+ , (bs, body') <- split_lets body+ = ((d,r):bs, body')+ | otherwise+ = ([], e)++ wrap_lets :: VarSet -> [(DictId,CoreExpr)] -> CoreExpr -> CoreExpr+ wrap_lets _ [] body = body+ wrap_lets needed ((d, r) : bs) body+ | rhs_fvs `intersectsVarSet` needed = Let (NonRec d r) (wrap_lets needed' bs body)+ | otherwise = wrap_lets needed bs body+ where+ rhs_fvs = exprFreeVars r+ needed' = (needed `minusVarSet` rhs_fvs) `extendVarSet` d++{-+Note [Decomposing the left-hand side of a RULE]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There are several things going on here.+* drop_dicts: see Note [Drop dictionary bindings on rule LHS]+* simpleOptExpr: see Note [Simplify rule LHS]+* extra_dict_bndrs: see Note [Free dictionaries]++Note [Drop dictionary bindings on rule LHS]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+drop_dicts drops dictionary bindings on the LHS where possible.+ E.g. let d:Eq [Int] = $fEqList $fEqInt in f d+ --> f d+ Reasoning here is that there is only one d:Eq [Int], and so we can+ quantify over it. That makes 'd' free in the LHS, but that is later+ picked up by extra_dict_bndrs (Note [Dead spec binders]).++ NB 1: We can only drop the binding if the RHS doesn't bind+ one of the orig_bndrs, which we assume occur on RHS.+ Example+ f :: (Eq a) => b -> a -> a+ {-# SPECIALISE f :: Eq a => b -> [a] -> [a] #-}+ Here we want to end up with+ RULE forall d:Eq a. f ($dfEqList d) = f_spec d+ Of course, the ($dfEqlist d) in the pattern makes it less likely+ to match, but ther is no other way to get d:Eq a++ NB 2: We do drop_dicts *before* simplOptEpxr, so that we expect all+ the evidence bindings to be wrapped around the outside of the+ LHS. (After simplOptExpr they'll usually have been inlined.)+ dsHsWrapper does dependency analysis, so that civilised ones+ will be simple NonRec bindings. We don't handle recursive+ dictionaries!++ NB3: In the common case of a non-overloaded, but perhaps-polymorphic+ specialisation, we don't need to bind *any* dictionaries for use+ in the RHS. For example (Trac #8331)+ {-# SPECIALIZE INLINE useAbstractMonad :: ReaderST s Int #-}+ useAbstractMonad :: MonadAbstractIOST m => m Int+ Here, deriving (MonadAbstractIOST (ReaderST s)) is a lot of code+ but the RHS uses no dictionaries, so we want to end up with+ RULE forall s (d :: MonadBstractIOST (ReaderT s)).+ useAbstractMonad (ReaderT s) d = $suseAbstractMonad s++ Trac #8848 is a good example of where there are some intersting+ dictionary bindings to discard.++The drop_dicts algorithm is based on these observations:++ * Given (let d = rhs in e) where d is a DictId,+ matching 'e' will bind e's free variables.++ * So we want to keep the binding if one of the needed variables (for+ which we need a binding) is in fv(rhs) but not already in fv(e).++ * The "needed variables" are simply the orig_bndrs. Consider+ f :: (Eq a, Show b) => a -> b -> String+ ... SPECIALISE f :: (Show b) => Int -> b -> String ...+ Then orig_bndrs includes the *quantified* dictionaries of the type+ namely (dsb::Show b), but not the one for Eq Int++So we work inside out, applying the above criterion at each step.+++Note [Simplify rule LHS]+~~~~~~~~~~~~~~~~~~~~~~~~+simplOptExpr occurrence-analyses and simplifies the LHS:++ (a) Inline any remaining dictionary bindings (which hopefully+ occur just once)++ (b) Substitute trivial lets so that they don't get in the way+ Note that we substitute the function too; we might+ have this as a LHS: let f71 = M.f Int in f71++ (c) Do eta reduction. To see why, consider the fold/build rule,+ which without simplification looked like:+ fold k z (build (/\a. g a)) ==> ...+ This doesn't match unless you do eta reduction on the build argument.+ Similarly for a LHS like+ augment g (build h)+ we do not want to get+ augment (\a. g a) (build h)+ otherwise we don't match when given an argument like+ augment (\a. h a a) (build h)++Note [Matching seqId]+~~~~~~~~~~~~~~~~~~~+The desugarer turns (seq e r) into (case e of _ -> r), via a special-case hack+and this code turns it back into an application of seq!+See Note [Rules for seq] in MkId for the details.++Note [Unused spec binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+ f :: a -> a+ ... SPECIALISE f :: Eq a => a -> a ...+It's true that this *is* a more specialised type, but the rule+we get is something like this:+ f_spec d = f+ RULE: f = f_spec d+Note that the rule is bogus, because it mentions a 'd' that is+not bound on the LHS! But it's a silly specialisation anyway, because+the constraint is unused. We could bind 'd' to (error "unused")+but it seems better to reject the program because it's almost certainly+a mistake. That's what the isDeadBinder call detects.++Note [Free dictionaries]+~~~~~~~~~~~~~~~~~~~~~~~~+When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict,+which is presumably in scope at the function definition site, we can quantify+over it too. *Any* dict with that type will do.++So for example when you have+ f :: Eq a => a -> a+ f = <rhs>+ ... SPECIALISE f :: Int -> Int ...++Then we get the SpecPrag+ SpecPrag (f Int dInt)++And from that we want the rule++ RULE forall dInt. f Int dInt = f_spec+ f_spec = let f = <rhs> in f Int dInt++But be careful! That dInt might be GHC.Base.$fOrdInt, which is an External+Name, and you can't bind them in a lambda or forall without getting things+confused. Likewise it might have an InlineRule or something, which would be+utterly bogus. So we really make a fresh Id, with the same unique and type+as the old one, but with an Internal name and no IdInfo.+++************************************************************************+* *+ Desugaring evidence+* *+************************************************************************++-}++dsHsWrapper :: HsWrapper -> CoreExpr -> DsM CoreExpr+dsHsWrapper WpHole e = return e+dsHsWrapper (WpTyApp ty) e = return $ App e (Type ty)+dsHsWrapper (WpLet ev_binds) e = do bs <- dsTcEvBinds ev_binds+ return (mkCoreLets bs e)+dsHsWrapper (WpCompose c1 c2) e = do { e1 <- dsHsWrapper c2 e+ ; dsHsWrapper c1 e1 }+dsHsWrapper (WpFun c1 c2 t1 _) e = do { x <- newSysLocalDs t1+ ; e1 <- dsHsWrapper c1 (Var x)+ ; e2 <- dsHsWrapper c2 (e `mkCoreAppDs` e1)+ ; return (Lam x e2) }+dsHsWrapper (WpCast co) e = -- ASSERT(tcCoercionRole co == Representational)+ dsTcCoercion co (mkCast e)+dsHsWrapper (WpEvLam ev) e = return $ Lam ev e+dsHsWrapper (WpTyLam tv) e = return $ Lam tv e+dsHsWrapper (WpEvApp tm) e = liftM (App e) (dsEvTerm tm)++--------------------------------------+dsTcEvBinds :: TcEvBinds -> DsM [CoreBind]+dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds" -- Zonker has got rid of this+dsTcEvBinds (EvBinds bs) = dsEvBinds bs++dsEvBinds :: Bag EvBind -> DsM [CoreBind]+dsEvBinds bs = mapM ds_scc (sccEvBinds bs)+ where+ ds_scc (AcyclicSCC (EvBind v r)) = liftM (NonRec v) (dsEvTerm r)+ ds_scc (CyclicSCC bs) = liftM Rec (mapM ds_pair bs)++ ds_pair (EvBind v r) = liftM ((,) v) (dsEvTerm r)++sccEvBinds :: Bag EvBind -> [SCC EvBind]+sccEvBinds bs = stronglyConnCompFromEdgedVertices edges+ where+ edges :: [(EvBind, EvVar, [EvVar])]+ edges = foldrBag ((:) . mk_node) [] bs++ mk_node :: EvBind -> (EvBind, EvVar, [EvVar])+ mk_node b@(EvBind var term) = (b, var, varSetElems (evVarsOfTerm term))+++---------------------------------------+dsEvTerm :: EvTerm -> DsM CoreExpr+dsEvTerm (EvId v) = return (Var v)++dsEvTerm (EvCast tm co)+ = do { tm' <- dsEvTerm tm+ ; dsTcCoercion co $ mkCast tm' }+ -- 'v' is always a lifted evidence variable so it is+ -- unnecessary to call varToCoreExpr v here.++dsEvTerm (EvDFunApp df tys tms) = do { tms' <- mapM dsEvTerm tms+ ; return (Var df `mkTyApps` tys `mkApps` tms') }++dsEvTerm (EvCoercion (TcCoVarCo v)) = return (Var v) -- See Note [Simple coercions]+dsEvTerm (EvCoercion co) = dsTcCoercion co mkEqBox++dsEvTerm (EvTupleSel v n)+ = do { tm' <- dsEvTerm v+ ; let scrut_ty = exprType tm'+ (tc, tys) = splitTyConApp scrut_ty+ Just [dc] = tyConDataCons_maybe tc+ xs = mkTemplateLocals tys+ the_x = getNth xs n+ ; -- ASSERT( isTupleTyCon tc )+ return $+ Case tm' (mkWildValBinder scrut_ty) (idType the_x) [(DataAlt dc, xs, Var the_x)] }++dsEvTerm (EvTupleMk tms)+ = do { tms' <- mapM dsEvTerm tms+ ; let tys = map exprType tms'+ ; return $ Var (dataConWorkId dc) `mkTyApps` tys `mkApps` tms' }+ where+ dc = tupleCon ConstraintTuple (length tms)++dsEvTerm (EvSuperClass d n)+ = do { d' <- dsEvTerm d+ ; let (cls, tys) = getClassPredTys (exprType d')+ sc_sel_id = classSCSelId cls n -- Zero-indexed+ ; return $ Var sc_sel_id `mkTyApps` tys `App` d' }+ where++dsEvTerm (EvDelayedError ty msg) = return $ Var errorId `mkTyApps` [ty] `mkApps` [litMsg]+ where+ errorId = rUNTIME_ERROR_ID+ litMsg = Lit (MachStr (fastStringToByteString msg))++dsEvTerm (EvLit l) =+ case l of+ EvNum n -> mkIntegerExpr n+ EvStr s -> mkStringExprFS s++dsEvTerm (EvCallStack cs) = dsEvCallStack cs++dsEvTerm (EvTypeable ev) = dsEvTypeable ev++dsEvTypeable :: EvTypeable -> DsM CoreExpr+dsEvTypeable ev =+ do tyCl <- dsLookupTyCon typeableClassName+ typeRepTc <- dsLookupTyCon typeRepTyConName+ let tyRepType = mkTyConApp typeRepTc []++ (ty, rep) <-+ case ev of++ EvTypeableTyCon tc ks ->+ do ctr <- dsLookupGlobalId mkPolyTyConAppName+ mkTyCon <- dsLookupGlobalId mkTyConName+ dflags <- getDynFlags+ let mkRep cRep kReps tReps =+ mkApps (Var ctr) [ cRep, mkListExpr tyRepType kReps+ , mkListExpr tyRepType tReps ]++ let kindRep k =+ case splitTyConApp_maybe k of+ Nothing -> panic "dsEvTypeable: not a kind constructor"+ Just (kc,ks) ->+ do kcRep <- tyConRep dflags mkTyCon kc+ reps <- mapM kindRep ks+ return (mkRep kcRep [] reps)++ tcRep <- tyConRep dflags mkTyCon tc++ kReps <- mapM kindRep ks++ return ( mkTyConApp tc ks+ , mkRep tcRep kReps []+ )++ EvTypeableTyApp t1 t2 ->+ do e1 <- getRep tyCl t1+ e2 <- getRep tyCl t2+ ctr <- dsLookupGlobalId mkAppTyName++ return ( mkAppTy (snd t1) (snd t2)+ , mkApps (Var ctr) [ e1, e2 ]+ )++ EvTypeableTyLit ty ->+ do str <- case (isNumLitTy ty, isStrLitTy ty) of+ (Just n, _) -> return (show n)+ (_, Just n) -> return (show n)+ _ -> panic "dsEvTypeable: malformed TyLit evidence"+ ctr <- dsLookupGlobalId typeLitTypeRepName+ tag <- mkStringExpr str+ return (ty, mkApps (Var ctr) [ tag ])++ -- TyRep -> Typeable t+ -- see also: Note [Memoising typeOf]+ repName <- newSysLocalDs tyRepType+ let proxyT = mkProxyPrimTy (typeKind ty) ty+ method = bindNonRec repName rep+ $ mkLams [mkWildValBinder proxyT] (Var repName)++ -- package up the method as `Typeable` dictionary+ return $ mkCast method $ mkSymCo $ getTypeableCo tyCl ty++ where+ -- co: method -> Typeable k t+ getTypeableCo tc t =+ case instNewTyCon_maybe tc [typeKind t, t] of+ Just (_,co) -> co+ _ -> panic "Class `Typeable` is not a `newtype`."++ -- Typeable t -> TyRep+ getRep tc (ev,t) =+ do typeableExpr <- dsEvTerm ev+ let co = getTypeableCo tc t+ method = mkCast typeableExpr co+ proxy = mkTyApps (Var proxyHashId) [typeKind t, t]+ return (mkApps method [proxy])++ -- This part could be cached+ tyConRep dflags mkTyCon tc =+ do pkgStr <- mkStringExprFS pkg_fs+ modStr <- mkStringExprFS modl_fs+ nameStr <- mkStringExprFS name_fs+ return (mkApps (Var mkTyCon) [ int64 high, int64 low+ , pkgStr, modStr, nameStr+ ])+ where+ tycon_name = tyConName tc+ modl = nameModule tycon_name+ pkg = modulePackageKey modl++ modl_fs = moduleNameFS (moduleName modl)+ pkg_fs = packageKeyFS pkg+ name_fs = occNameFS (nameOccName tycon_name)+ hash_name_fs+ | isPromotedTyCon tc = appendFS (mkFastString "$k") name_fs+ | isPromotedDataCon tc = appendFS (mkFastString "$c") name_fs+ | otherwise = name_fs++ hashThis = unwords $ map unpackFS [pkg_fs, modl_fs, hash_name_fs]+ Fingerprint high low = fingerprintString hashThis++ int64+ | wORD_SIZE dflags == 4 = mkWord64LitWord64+ | otherwise = mkWordLit dflags . fromIntegral++++{- Note [Memoising typeOf]+~~~~~~~~~~~~~~~~~~~~~~~~~~+See #3245, #9203++IMPORTANT: we don't want to recalculate the TypeRep once per call with+the proxy argument. This is what went wrong in #3245 and #9203. So we+help GHC by manually keeping the 'rep' *outside* the lambda.+-}++++dsEvCallStack :: EvCallStack -> DsM CoreExpr+-- See Note [Overview of implicit CallStacks] in TcEvidence.hs+dsEvCallStack cs = do+ df <- getDynFlags+ m <- getModule+ srcLocDataCon <- dsLookupDataCon srcLocDataConName+ let srcLocTyCon = dataConTyCon srcLocDataCon+ let srcLocTy = mkTyConTy srcLocTyCon+ let mkSrcLoc l =+ liftM (mkCoreConApps srcLocDataCon)+ (sequence [ mkStringExprFS (packageKeyFS $ modulePackageKey m)+ , mkStringExprFS (moduleNameFS $ moduleName m)+ , mkStringExprFS (srcSpanFile l)+ , return $ mkIntExprInt df (srcSpanStartLine l)+ , return $ mkIntExprInt df (srcSpanStartCol l)+ , return $ mkIntExprInt df (srcSpanEndLine l)+ , return $ mkIntExprInt df (srcSpanEndCol l)+ ])++ let callSiteTy = mkBoxedTupleTy [stringTy, srcLocTy]++ matchId <- newSysLocalDs $ mkListTy callSiteTy++ callStackDataCon <- dsLookupDataCon callStackDataConName+ let callStackTyCon = dataConTyCon callStackDataCon+ let callStackTy = mkTyConTy callStackTyCon+ let emptyCS = mkCoreConApps callStackDataCon [mkNilExpr callSiteTy]+ let pushCS name loc rest =+ mkWildCase rest callStackTy callStackTy+ [( DataAlt callStackDataCon+ , [matchId]+ , mkCoreConApps callStackDataCon+ [mkConsExpr callSiteTy+ (mkCoreTup [name, loc])+ (Var matchId)]+ )]+ let mkPush name loc tm = do+ nameExpr <- mkStringExprFS name+ locExpr <- mkSrcLoc loc+ case tm of+ EvCallStack EvCsEmpty -> return (pushCS nameExpr locExpr emptyCS)+ _ -> do tmExpr <- dsEvTerm tm+ -- at this point tmExpr :: IP sym CallStack+ -- but we need the actual CallStack to pass to pushCS,+ -- so we use unwrapIP to strip the dictionary wrapper+ -- See Note [Overview of implicit CallStacks]+ let ip_co = unwrapIP (exprType tmExpr)+ return (pushCS nameExpr locExpr (mkCastDs tmExpr ip_co))+ case cs of+ EvCsTop name loc tm -> mkPush name loc tm+ EvCsPushCall name loc tm -> mkPush (occNameFS $ getOccName name) loc tm+ EvCsEmpty -> panic "Cannot have an empty CallStack"+++---------------------------------------+dsTcCoercion :: TcCoercion -> (Coercion -> CoreExpr) -> DsM CoreExpr+-- This is the crucial function that moves+-- from TcCoercions to Coercions; see Note [TcCoercions] in Coercion+-- e.g. dsTcCoercion (trans g1 g2) k+-- = case g1 of EqBox g1# ->+-- case g2 of EqBox g2# ->+-- k (trans g1# g2#)+-- thing_inside will get a coercion at the role requested+dsTcCoercion co thing_inside+ = do { us <- newUniqueSupply+ ; let eqvs_covs :: [(EqVar,CoVar)]+ eqvs_covs = zipWith mk_co_var (varSetElems (coVarsOfTcCo co))+ (uniqsFromSupply us)++ subst = mkCvSubst emptyInScopeSet [(eqv, mkCoVarCo cov) | (eqv, cov) <- eqvs_covs]+ result_expr = thing_inside (ds_tc_coercion subst co)+ result_ty = exprType result_expr++ ; return (foldr (wrap_in_case result_ty) result_expr eqvs_covs) }+ where+ mk_co_var :: Id -> Unique -> (Id, Id)+ mk_co_var eqv uniq = (eqv, mkUserLocal occ uniq ty loc)+ where+ eq_nm = idName eqv+ occ = nameOccName eq_nm+ loc = nameSrcSpan eq_nm+ ty = mkCoercionType (getEqPredRole (evVarPred eqv)) ty1 ty2+ (ty1, ty2) = getEqPredTys (evVarPred eqv)++ wrap_in_case result_ty (eqv, cov) body+ = case getEqPredRole (evVarPred eqv) of+ Nominal -> Case (Var eqv) eqv result_ty [(DataAlt eqBoxDataCon, [cov], body)]+ Representational -> Case (Var eqv) eqv result_ty [(DataAlt coercibleDataCon, [cov], body)]+ Phantom -> panic "wrap_in_case/phantom"++ds_tc_coercion :: CvSubst -> TcCoercion -> Coercion+-- If the incoming TcCoercion if of type (a ~ b) (resp. Coercible a b)+-- the result is of type (a ~# b) (reps. a ~# b)+-- The VarEnv maps EqVars of type (a ~ b) to Coercions of type (a ~# b) (resp. and so on)+-- No need for InScope set etc because the+ds_tc_coercion subst tc_co+ = go tc_co+ where+ go (TcRefl r ty) = Refl r (Coercion.substTy subst ty)+ go (TcTyConAppCo r tc cos) = mkTyConAppCo r tc (map go cos)+ go (TcAppCo co1 co2) = mkAppCo (go co1) (go co2)+ go (TcForAllCo tv co) = mkForAllCo tv' (ds_tc_coercion subst' co)+ where+ (subst', tv') = Coercion.substTyVarBndr subst tv+ go (TcAxiomInstCo ax ind cos)+ = AxiomInstCo ax ind (map go cos)+ go (TcPhantomCo ty1 ty2) = UnivCo (fsLit "ds_tc_coercion") Phantom ty1 ty2+ go (TcSymCo co) = mkSymCo (go co)+ go (TcTransCo co1 co2) = mkTransCo (go co1) (go co2)+ go (TcNthCo n co) = mkNthCo n (go co)+ go (TcLRCo lr co) = mkLRCo lr (go co)+ go (TcSubCo co) = mkSubCo (go co)+ go (TcLetCo bs co) = ds_tc_coercion (ds_co_binds bs) co+ go (TcCastCo co1 co2) = mkCoCast (go co1) (go co2)+ go (TcCoVarCo v) = ds_ev_id subst v+ go (TcAxiomRuleCo co ts cs) = AxiomRuleCo co (map (Coercion.substTy subst) ts) (map go cs)+ go (TcCoercion co) = co++ ds_co_binds :: TcEvBinds -> CvSubst+ ds_co_binds (EvBinds bs) = foldl ds_scc subst (sccEvBinds bs)+ ds_co_binds eb@(TcEvBinds {}) = pprPanic "ds_co_binds" (ppr eb)++ ds_scc :: CvSubst -> SCC EvBind -> CvSubst+ ds_scc subst (AcyclicSCC (EvBind v ev_term))+ = extendCvSubstAndInScope subst v (ds_co_term subst ev_term)+ ds_scc _ (CyclicSCC other) = pprPanic "ds_scc:cyclic" (ppr other $$ ppr tc_co)++ ds_co_term :: CvSubst -> EvTerm -> Coercion+ ds_co_term subst (EvCoercion tc_co) = ds_tc_coercion subst tc_co+ ds_co_term subst (EvId v) = ds_ev_id subst v+ ds_co_term subst (EvCast tm co) = mkCoCast (ds_co_term subst tm) (ds_tc_coercion subst co)+ ds_co_term _ other = pprPanic "ds_co_term" (ppr other $$ ppr tc_co)++ ds_ev_id :: CvSubst -> EqVar -> Coercion+ ds_ev_id subst v+ | Just co <- Coercion.lookupCoVar subst v = co+ | otherwise = pprPanic "ds_tc_coercion" (ppr v $$ ppr tc_co)++{-+Note [Simple coercions]+~~~~~~~~~~~~~~~~~~~~~~~+We have a special case for coercions that are simple variables.+Suppose cv :: a ~ b is in scope+Lacking the special case, if we see+ f a b cv+we'd desguar to+ f a b (case cv of EqBox (cv# :: a ~# b) -> EqBox cv#)+which is a bit stupid. The special case does the obvious thing.++This turns out to be important when desugaring the LHS of a RULE+(see Trac #7837). Suppose we have+ normalise :: (a ~ Scalar a) => a -> a+ normalise_Double :: Double -> Double+ {-# RULES "normalise" normalise = normalise_Double #-}++Then the RULE we want looks like+ forall a, (cv:a~Scalar a).+ normalise a cv = normalise_Double+But without the special case we generate the redundant box/unbox,+which simpleOpt (currently) doesn't remove. So the rule never matches.++Maybe simpleOpt should be smarter. But it seems like a good plan+to simply never generate the redundant box/unbox in the first place.+-}
+ src/Language/Haskell/Liquid/Desugar710/DsCCall.hs view
@@ -0,0 +1,382 @@+{-+(c) The University of Glasgow 2006+(c) The AQUA Project, Glasgow University, 1994-1998+++Desugaring foreign calls+-}++{-# LANGUAGE CPP #-}+module Language.Haskell.Liquid.Desugar710.DsCCall+ ( dsCCall+ , mkFCall+ , unboxArg+ , boxResult+ , resultWrapper+ ) where++-- #include "HsVersions.h"+++import CoreSyn++import DsMonad++import CoreUtils+import MkCore+import Var+import MkId+import ForeignCall+import DataCon++import TcType+import Type+import Coercion+import PrimOp+import TysPrim+import TyCon+import TysWiredIn+import BasicTypes+import Literal+import PrelNames+import VarSet+import DynFlags+import Outputable+import Util++import Data.Maybe++{-+Desugaring of @ccall@s consists of adding some state manipulation,+unboxing any boxed primitive arguments and boxing the result if+desired.++The state stuff just consists of adding in+@PrimIO (\ s -> case s of { S# s# -> ... })@ in an appropriate place.++The unboxing is straightforward, as all information needed to unbox is+available from the type. For each boxed-primitive argument, we+transform:+\begin{verbatim}+ _ccall_ foo [ r, t1, ... tm ] e1 ... em+ |+ |+ V+ case e1 of { T1# x1# ->+ ...+ case em of { Tm# xm# -> xm#+ ccall# foo [ r, t1#, ... tm# ] x1# ... xm#+ } ... }+\end{verbatim}++The reboxing of a @_ccall_@ result is a bit tricker: the types don't+contain information about the state-pairing functions so we have to+keep a list of \tr{(type, s-p-function)} pairs. We transform as+follows:+\begin{verbatim}+ ccall# foo [ r, t1#, ... tm# ] e1# ... em#+ |+ |+ V+ \ s# -> case (ccall# foo [ r, t1#, ... tm# ] s# e1# ... em#) of+ (StateAnd<r># result# state#) -> (R# result#, realWorld#)+\end{verbatim}+-}++dsCCall :: CLabelString -- C routine to invoke+ -> [CoreExpr] -- Arguments (desugared)+ -> Safety -- Safety of the call+ -> Type -- Type of the result: IO t+ -> DsM CoreExpr -- Result, of type ???++dsCCall lbl args may_gc result_ty+ = do (unboxed_args, arg_wrappers) <- mapAndUnzipM unboxArg args+ (ccall_result_ty, res_wrapper) <- boxResult result_ty+ uniq <- newUnique+ dflags <- getDynFlags+ let+ target = StaticTarget lbl Nothing True+ the_fcall = CCall (CCallSpec target CCallConv may_gc)+ the_prim_app = mkFCall dflags uniq the_fcall unboxed_args ccall_result_ty+ return (foldr ($) (res_wrapper the_prim_app) arg_wrappers)++mkFCall :: DynFlags -> Unique -> ForeignCall+ -> [CoreExpr] -- Args+ -> Type -- Result type+ -> CoreExpr+-- Construct the ccall. The only tricky bit is that the ccall Id should have+-- no free vars, so if any of the arg tys do we must give it a polymorphic type.+-- [I forget *why* it should have no free vars!]+-- For example:+-- mkCCall ... [s::StablePtr (a->b), x::Addr, c::Char]+--+-- Here we build a ccall thus+-- (ccallid::(forall a b. StablePtr (a -> b) -> Addr -> Char -> IO Addr))+-- a b s x c+mkFCall dflags uniq the_fcall val_args res_ty+ = mkApps (mkVarApps (Var the_fcall_id) tyvars) val_args+ where+ arg_tys = map exprType val_args+ body_ty = (mkFunTys arg_tys res_ty)+ tyvars = varSetElems (tyVarsOfType body_ty)+ ty = mkForAllTys tyvars body_ty+ the_fcall_id = mkFCallId dflags uniq the_fcall ty++unboxArg :: CoreExpr -- The supplied argument+ -> DsM (CoreExpr, -- To pass as the actual argument+ CoreExpr -> CoreExpr -- Wrapper to unbox the arg+ )+-- Example: if the arg is e::Int, unboxArg will return+-- (x#::Int#, \W. case x of I# x# -> W)+-- where W is a CoreExpr that probably mentions x#++unboxArg arg+ -- Primtive types: nothing to unbox+ | isPrimitiveType arg_ty+ = return (arg, \body -> body)++ -- Recursive newtypes+ | Just(co, _rep_ty) <- topNormaliseNewType_maybe arg_ty+ = unboxArg (mkCast arg co)++ -- Booleans+ | Just tc <- tyConAppTyCon_maybe arg_ty,+ tc `hasKey` boolTyConKey+ = do dflags <- getDynFlags+ prim_arg <- newSysLocalDs intPrimTy+ return (Var prim_arg,+ \ body -> Case (mkWildCase arg arg_ty intPrimTy+ [(DataAlt falseDataCon,[],mkIntLit dflags 0),+ (DataAlt trueDataCon, [],mkIntLit dflags 1)])+ -- In increasing tag order!+ prim_arg+ (exprType body)+ [(DEFAULT,[],body)])++ -- Data types with a single constructor, which has a single, primitive-typed arg+ -- This deals with Int, Float etc; also Ptr, ForeignPtr+ | is_product_type && data_con_arity == 1+ = -- ASSERT2(isUnLiftedType data_con_arg_ty1, pprType arg_ty)+ -- Typechecker ensures this+ do case_bndr <- newSysLocalDs arg_ty+ prim_arg <- newSysLocalDs data_con_arg_ty1+ return (Var prim_arg,+ \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,[prim_arg],body)]+ )++ -- Byte-arrays, both mutable and otherwise; hack warning+ -- We're looking for values of type ByteArray, MutableByteArray+ -- data ByteArray ix = ByteArray ix ix ByteArray#+ -- data MutableByteArray s ix = MutableByteArray ix ix (MutableByteArray# s)+ | is_product_type &&+ data_con_arity == 3 &&+ isJust maybe_arg3_tycon &&+ (arg3_tycon == byteArrayPrimTyCon ||+ arg3_tycon == mutableByteArrayPrimTyCon)+ = do case_bndr <- newSysLocalDs arg_ty+ vars@[_l_var, _r_var, arr_cts_var] <- newSysLocalsDs data_con_arg_tys+ return (Var arr_cts_var,+ \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,vars,body)]+ )++ | otherwise+ = do l <- getSrcSpanDs+ pprPanic "unboxArg: " (ppr l <+> ppr arg_ty)+ where+ arg_ty = exprType arg+ maybe_product_type = splitDataProductType_maybe arg_ty+ is_product_type = isJust maybe_product_type+ Just (_, _, data_con, data_con_arg_tys) = maybe_product_type+ data_con_arity = dataConSourceArity data_con+ (data_con_arg_ty1 : _) = data_con_arg_tys++ (_ : _ : data_con_arg_ty3 : _) = data_con_arg_tys+ maybe_arg3_tycon = tyConAppTyCon_maybe data_con_arg_ty3+ Just arg3_tycon = maybe_arg3_tycon++boxResult :: Type+ -> DsM (Type, CoreExpr -> CoreExpr)++-- Takes the result of the user-level ccall:+-- either (IO t),+-- or maybe just t for an side-effect-free call+-- Returns a wrapper for the primitive ccall itself, along with the+-- type of the result of the primitive ccall. This result type+-- will be of the form+-- State# RealWorld -> (# State# RealWorld, t' #)+-- where t' is the unwrapped form of t. If t is simply (), then+-- the result type will be+-- State# RealWorld -> (# State# RealWorld #)++boxResult result_ty+ | Just (io_tycon, io_res_ty) <- tcSplitIOType_maybe result_ty+ -- isIOType_maybe handles the case where the type is a+ -- simple wrapping of IO. E.g.+ -- newtype Wrap a = W (IO a)+ -- No coercion necessary because its a non-recursive newtype+ -- (If we wanted to handle a *recursive* newtype too, we'd need+ -- another case, and a coercion.)+ -- The result is IO t, so wrap the result in an IO constructor+ = do { res <- resultWrapper io_res_ty+ ; let extra_result_tys+ = case res of+ (Just ty,_)+ | isUnboxedTupleType ty+ -> let Just ls = tyConAppArgs_maybe ty in tail ls+ _ -> []++ return_result state anss+ = mkCoreConApps (tupleCon UnboxedTuple (2 + length extra_result_tys))+ (map Type (realWorldStatePrimTy : io_res_ty : extra_result_tys)+ ++ (state : anss))++ ; (ccall_res_ty, the_alt) <- mk_alt return_result res++ ; state_id <- newSysLocalDs realWorldStatePrimTy+ ; let io_data_con = head (tyConDataCons io_tycon)+ toIOCon = dataConWrapId io_data_con++ wrap the_call =+ mkApps (Var toIOCon)+ [ Type io_res_ty,+ Lam state_id $+ mkWildCase (App the_call (Var state_id))+ ccall_res_ty+ (coreAltType the_alt)+ [the_alt]+ ]++ ; return (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap) }++boxResult result_ty+ = do -- It isn't IO, so do unsafePerformIO+ -- It's not conveniently available, so we inline it+ res <- resultWrapper result_ty+ (ccall_res_ty, the_alt) <- mk_alt return_result res+ let+ wrap = \ the_call -> mkWildCase (App the_call (Var realWorldPrimId))+ ccall_res_ty+ (coreAltType the_alt)+ [the_alt]+ return (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)+ where+ return_result _ [ans] = ans+ return_result _ _ = panic "return_result: expected single result"+++mk_alt :: (Expr Var -> [Expr Var] -> Expr Var)+ -> (Maybe Type, Expr Var -> Expr Var)+ -> DsM (Type, (AltCon, [Id], Expr Var))+mk_alt return_result (Nothing, wrap_result)+ = do -- The ccall returns ()+ state_id <- newSysLocalDs realWorldStatePrimTy+ let+ the_rhs = return_result (Var state_id)+ [wrap_result (panic "boxResult")]++ ccall_res_ty = mkTyConApp unboxedSingletonTyCon [realWorldStatePrimTy]+ the_alt = (DataAlt unboxedSingletonDataCon, [state_id], the_rhs)++ return (ccall_res_ty, the_alt)++mk_alt return_result (Just prim_res_ty, wrap_result)+ -- The ccall returns a non-() value+ | isUnboxedTupleType prim_res_ty= do+ let+ Just ls = tyConAppArgs_maybe prim_res_ty+ arity = 1 + length ls+ args_ids@(result_id:as) <- mapM newSysLocalDs ls+ state_id <- newSysLocalDs realWorldStatePrimTy+ let+ the_rhs = return_result (Var state_id)+ (wrap_result (Var result_id) : map Var as)+ ccall_res_ty = mkTyConApp (tupleTyCon UnboxedTuple arity)+ (realWorldStatePrimTy : ls)+ the_alt = ( DataAlt (tupleCon UnboxedTuple arity)+ , (state_id : args_ids)+ , the_rhs+ )+ return (ccall_res_ty, the_alt)++ | otherwise = do+ result_id <- newSysLocalDs prim_res_ty+ state_id <- newSysLocalDs realWorldStatePrimTy+ let+ the_rhs = return_result (Var state_id)+ [wrap_result (Var result_id)]+ ccall_res_ty = mkTyConApp unboxedPairTyCon [realWorldStatePrimTy, prim_res_ty]+ the_alt = (DataAlt unboxedPairDataCon, [state_id, result_id], the_rhs)+ return (ccall_res_ty, the_alt)+++resultWrapper :: Type+ -> DsM (Maybe Type, -- Type of the expected result, if any+ CoreExpr -> CoreExpr) -- Wrapper for the result+-- resultWrapper deals with the result *value*+-- E.g. foreign import foo :: Int -> IO T+-- Then resultWrapper deals with marshalling the 'T' part+resultWrapper result_ty+ -- Base case 1: primitive types+ | isPrimitiveType result_ty+ = return (Just result_ty, \e -> e)++ -- Base case 2: the unit type ()+ | Just (tc,_) <- maybe_tc_app, tc `hasKey` unitTyConKey+ = return (Nothing, \_ -> Var unitDataConId)++ -- Base case 3: the boolean type+ | Just (tc,_) <- maybe_tc_app, tc `hasKey` boolTyConKey+ = do+ dflags <- getDynFlags+ return+ (Just intPrimTy, \e -> mkWildCase e intPrimTy+ boolTy+ [(DEFAULT ,[],Var trueDataConId ),+ (LitAlt (mkMachInt dflags 0),[],Var falseDataConId)])++ -- Newtypes+ | Just (co, rep_ty) <- topNormaliseNewType_maybe result_ty+ = do (maybe_ty, wrapper) <- resultWrapper rep_ty+ return (maybe_ty, \e -> mkCast (wrapper e) (mkSymCo co))++ -- The type might contain foralls (eg. for dummy type arguments,+ -- referring to 'Ptr a' is legal).+ | Just (tyvar, rest) <- splitForAllTy_maybe result_ty+ = do (maybe_ty, wrapper) <- resultWrapper rest+ return (maybe_ty, \e -> Lam tyvar (wrapper e))++ -- Data types with a single constructor, which has a single arg+ -- This includes types like Ptr and ForeignPtr+ | Just (tycon, tycon_arg_tys, data_con, data_con_arg_tys) <- splitDataProductType_maybe result_ty,+ dataConSourceArity data_con == 1+ = do dflags <- getDynFlags+ let+ (unwrapped_res_ty : _) = data_con_arg_tys+ narrow_wrapper = maybeNarrow dflags tycon+ (maybe_ty, wrapper) <- resultWrapper unwrapped_res_ty+ return+ (maybe_ty, \e -> mkApps (Var (dataConWrapId data_con))+ (map Type tycon_arg_tys ++ [wrapper (narrow_wrapper e)]))++ | otherwise+ = pprPanic "resultWrapper" (ppr result_ty)+ where+ maybe_tc_app = splitTyConApp_maybe result_ty++-- When the result of a foreign call is smaller than the word size, we+-- need to sign- or zero-extend the result up to the word size. The C+-- standard appears to say that this is the responsibility of the+-- caller, not the callee.++maybeNarrow :: DynFlags -> TyCon -> (CoreExpr -> CoreExpr)+maybeNarrow dflags tycon+ | tycon `hasKey` int8TyConKey = \e -> App (Var (mkPrimOpId Narrow8IntOp)) e+ | tycon `hasKey` int16TyConKey = \e -> App (Var (mkPrimOpId Narrow16IntOp)) e+ | tycon `hasKey` int32TyConKey+ && wORD_SIZE dflags > 4 = \e -> App (Var (mkPrimOpId Narrow32IntOp)) e++ | tycon `hasKey` word8TyConKey = \e -> App (Var (mkPrimOpId Narrow8WordOp)) e+ | tycon `hasKey` word16TyConKey = \e -> App (Var (mkPrimOpId Narrow16WordOp)) e+ | tycon `hasKey` word32TyConKey+ && wORD_SIZE dflags > 4 = \e -> App (Var (mkPrimOpId Narrow32WordOp)) e+ | otherwise = id
+ src/Language/Haskell/Liquid/Desugar710/DsExpr.hs view
@@ -0,0 +1,982 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++Desugaring exporessions.+-}++{-# LANGUAGE CPP #-}++module Language.Haskell.Liquid.Desugar710.DsExpr ( dsExpr, dsLExpr, dsLocalBinds, dsValBinds, dsLit ) where++-- #include "HsVersions.h"++import Language.Haskell.Liquid.Desugar710.Match+import Language.Haskell.Liquid.Desugar710.MatchLit+import Language.Haskell.Liquid.Desugar710.DsBinds+import Language.Haskell.Liquid.Desugar710.DsGRHSs+import Language.Haskell.Liquid.Desugar710.DsListComp+import Language.Haskell.Liquid.Desugar710.DsUtils+import Language.Haskell.Liquid.Desugar710.DsArrows+import DsMonad+import Name+import NameEnv+import FamInstEnv( topNormaliseType )+++import HsSyn++import Platform+-- NB: The desugarer, which straddles the source and Core worlds, sometimes+-- needs to see source types+import TcType+import Coercion ( Role(..) )+import TcEvidence+import TcRnMonad+import Type+import CoreSyn+import CoreUtils+import CoreFVs+import MkCore++import DynFlags+import CostCentre+import Id+import Module+import VarSet+import VarEnv+import ConLike+import DataCon+import TysWiredIn+import PrelNames+import BasicTypes+import Maybes+import SrcLoc+import Util+import Bag+import Outputable+import FastString++import IdInfo+import Data.IORef ( atomicModifyIORef, modifyIORef )++import Control.Monad+import GHC.Fingerprint++srcSpanTick :: Module -> SrcSpan -> Tickish a+srcSpanTick m loc+ = ProfNote (AllCafsCC m loc) False True++{-+************************************************************************+* *+ dsLocalBinds, dsValBinds+* *+************************************************************************+-}++dsLocalBinds :: HsLocalBinds Id -> CoreExpr -> DsM CoreExpr+dsLocalBinds EmptyLocalBinds body = return body+dsLocalBinds (HsValBinds binds) body = dsValBinds binds body+dsLocalBinds (HsIPBinds binds) body = dsIPBinds binds body++-------------------------+dsValBinds :: HsValBinds Id -> CoreExpr -> DsM CoreExpr+dsValBinds (ValBindsOut binds _) body = foldrM ds_val_bind body binds+dsValBinds (ValBindsIn _ _) _ = panic "dsValBinds ValBindsIn"++-------------------------+dsIPBinds :: HsIPBinds Id -> CoreExpr -> DsM CoreExpr+dsIPBinds (IPBinds ip_binds ev_binds) body+ = do { ds_binds <- dsTcEvBinds ev_binds+ ; let inner = mkCoreLets ds_binds body+ -- The dict bindings may not be in+ -- dependency order; hence Rec+ ; foldrM ds_ip_bind inner ip_binds }+ where+ ds_ip_bind (L _ (IPBind ~(Right n) e)) body+ = do e' <- dsLExpr e+ return (Let (NonRec n e') body)++-------------------------+ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr+-- Special case for bindings which bind unlifted variables+-- We need to do a case right away, rather than building+-- a tuple and doing selections.+-- Silently ignore INLINE and SPECIALISE pragmas...+ds_val_bind (NonRecursive, hsbinds) body+ | [L loc bind] <- bagToList hsbinds,+ -- Non-recursive, non-overloaded bindings only come in ones+ -- ToDo: in some bizarre case it's conceivable that there+ -- could be dict binds in the 'binds'. (See the notes+ -- below. Then pattern-match would fail. Urk.)+ strictMatchOnly bind+ = putSrcSpanDs loc (dsStrictBind bind body)++-- Ordinary case for bindings; none should be unlifted+ds_val_bind (_is_rec, binds) body+ = do { prs <- dsLHsBinds binds+ ; -- ASSERT2( not (any (isUnLiftedType . idType . fst) prs), ppr _is_rec $$ ppr binds )+ case prs of+ [] -> return body+ _ -> return (Let (Rec prs) body) }+ -- Use a Rec regardless of is_rec.+ -- Why? Because it allows the binds to be all+ -- mixed up, which is what happens in one rare case+ -- Namely, for an AbsBind with no tyvars and no dicts,+ -- but which does have dictionary bindings.+ -- See notes with TcSimplify.inferLoop [NO TYVARS]+ -- It turned out that wrapping a Rec here was the easiest solution+ --+ -- NB The previous case dealt with unlifted bindings, so we+ -- only have to deal with lifted ones now; so Rec is ok++------------------+dsStrictBind :: HsBind Id -> CoreExpr -> DsM CoreExpr+dsStrictBind (AbsBinds { abs_tvs = [], abs_ev_vars = []+ , abs_exports = exports+ , abs_ev_binds = ev_binds+ , abs_binds = lbinds }) body+ = do { let body1 = foldr bind_export body exports+ bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b+ ; body2 <- foldlBagM (\body lbind -> dsStrictBind (unLoc lbind) body)+ body1 lbinds+ ; ds_binds <- dsTcEvBinds ev_binds+ ; return (mkCoreLets ds_binds body2) }++dsStrictBind (FunBind { fun_id = L _ fun, fun_matches = matches --, fun_co_fn = co_fn+ , fun_tick = tick, fun_infix = inf }) body+ -- Can't be a bang pattern (that looks like a PatBind)+ -- so must be simply unboxed+ = do { (_args, rhs) <- matchWrapper (FunRhs (idName fun ) inf) matches+ -- ; MASSERT( null args ) -- Functions aren't lifted+ -- ; MASSERT( isIdHsWrapper co_fn )+ ; let rhs' = mkOptTickBox tick rhs+ ; return (bindNonRec fun rhs' body) }++dsStrictBind (PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) body+ = -- let C x# y# = rhs in body+ -- ==> case rhs of C x# y# -> body+ do { rhs <- dsGuarded grhss ty+ ; let upat = unLoc pat+ eqn = EqnInfo { eqn_pats = [upat],+ eqn_rhs = cantFailMatchResult body }+ ; var <- selectMatchVar upat+ ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)+ ; return (bindNonRec var rhs result) }++dsStrictBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body)++----------------------+strictMatchOnly :: HsBind Id -> Bool+strictMatchOnly (AbsBinds { abs_binds = lbinds })+ = anyBag (strictMatchOnly . unLoc) lbinds+strictMatchOnly (PatBind { pat_lhs = lpat, pat_rhs_ty = rhs_ty })+ = isUnLiftedType rhs_ty+ || isStrictLPat lpat+ || any (isUnLiftedType . idType) (collectPatBinders lpat)+strictMatchOnly (FunBind { fun_id = L _ id })+ = isUnLiftedType (idType id)+strictMatchOnly _ = False -- I hope! Checked immediately by caller in fact++{-+************************************************************************+* *+\subsection[DsExpr-vars-and-cons]{Variables, constructors, literals}+* *+************************************************************************+-}++dsLExpr :: LHsExpr Id -> DsM CoreExpr++dsLExpr (L loc e) + = do ce <- putSrcSpanDs loc $ dsExpr e+ m <- getModule+ return $ Tick (srcSpanTick m loc) ce++dsExpr :: HsExpr Id -> DsM CoreExpr+dsExpr (HsPar e) = dsLExpr e+dsExpr (ExprWithTySigOut e _) = dsLExpr e+dsExpr (HsVar var) = return (varToCoreExpr var) -- See Note [Desugaring vars]+dsExpr (HsIPVar _) = panic "dsExpr: HsIPVar"+dsExpr (HsLit lit) = dsLit lit+dsExpr (HsOverLit lit) = dsOverLit lit++dsExpr (HsWrap co_fn e)+ = do { e' <- dsExpr e+ ; wrapped_e <- dsHsWrapper co_fn e'+ ; dflags <- getDynFlags+ ; warnAboutIdentities dflags e' (exprType wrapped_e)+ ; return wrapped_e }++dsExpr (NegApp expr neg_expr)+ = App <$> dsExpr neg_expr <*> dsLExpr expr++dsExpr (HsLam a_Match)+ = uncurry mkLams <$> matchWrapper LambdaExpr a_Match++dsExpr (HsLamCase arg matches)+ = do { arg_var <- newSysLocalDs arg+ ; ([discrim_var], matching_code) <- matchWrapper CaseAlt matches+ ; return $ Lam arg_var $ bindNonRec discrim_var (Var arg_var) matching_code }++dsExpr (HsApp fun arg)+ = mkCoreAppDs <$> dsLExpr fun <*> dsLExpr arg++dsExpr (HsUnboundVar _) = panic "dsExpr: HsUnboundVar"++{-+Note [Desugaring vars]+~~~~~~~~~~~~~~~~~~~~~~+In one situation we can get a *coercion* variable in a HsVar, namely+the support method for an equality superclass:+ class (a~b) => C a b where ...+ instance (blah) => C (T a) (T b) where ..+Then we get+ $dfCT :: forall ab. blah => C (T a) (T b)+ $dfCT ab blah = MkC ($c$p1C a blah) ($cop a blah)++ $c$p1C :: forall ab. blah => (T a ~ T b)+ $c$p1C ab blah = let ...; g :: T a ~ T b = ... } in g++That 'g' in the 'in' part is an evidence variable, and when+converting to core it must become a CO.++Operator sections. At first it looks as if we can convert+\begin{verbatim}+ (expr op)+\end{verbatim}+to+\begin{verbatim}+ \x -> op expr x+\end{verbatim}++But no! expr might be a redex, and we can lose laziness badly this+way. Consider+\begin{verbatim}+ map (expr op) xs+\end{verbatim}+for example. So we convert instead to+\begin{verbatim}+ let y = expr in \x -> op y x+\end{verbatim}+If \tr{expr} is actually just a variable, say, then the simplifier+will sort it out.+-}++dsExpr (OpApp e1 op _ e2)+ = -- for the type of y, we need the type of op's 2nd argument+ mkCoreAppsDs <$> dsLExpr op <*> mapM dsLExpr [e1, e2]++dsExpr (SectionL expr op) -- Desugar (e !) to ((!) e)+ = mkCoreAppDs <$> dsLExpr op <*> dsLExpr expr++-- dsLExpr (SectionR op expr) -- \ x -> op x expr+dsExpr (SectionR op expr) = do+ core_op <- dsLExpr op+ -- for the type of x, we need the type of op's 2nd argument+ let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)+ -- See comment with SectionL+ y_core <- dsLExpr expr+ x_id <- newSysLocalDs x_ty+ y_id <- newSysLocalDs y_ty+ return (bindNonRec y_id y_core $+ Lam x_id (mkCoreAppsDs core_op [Var x_id, Var y_id]))++dsExpr (ExplicitTuple tup_args boxity)+ = do { let go (lam_vars, args) (L _ (Missing ty))+ -- For every missing expression, we need+ -- another lambda in the desugaring.+ = do { lam_var <- newSysLocalDs ty+ ; return (lam_var : lam_vars, Var lam_var : args) }+ go (lam_vars, args) (L _ (Present expr))+ -- Expressions that are present don't generate+ -- lambdas, just arguments.+ = do { core_expr <- dsLExpr expr+ ; return (lam_vars, core_expr : args) }++ ; (lam_vars, args) <- foldM go ([], []) (reverse tup_args)+ -- The reverse is because foldM goes left-to-right++ ; return $ mkCoreLams lam_vars $ + mkConApp (tupleCon (boxityNormalTupleSort boxity) (length tup_args))+ (map (Type . exprType) args ++ args) }++dsExpr (HsSCC _ cc expr@(L loc _)) = do+ dflags <- getDynFlags+ if gopt Opt_SccProfilingOn dflags+ then do+ mod_name <- getModule+ count <- goptM Opt_ProfCountEntries+ uniq <- newUnique+ Tick (ProfNote (mkUserCC cc mod_name loc uniq) count True)+ <$> dsLExpr expr+ else dsLExpr expr++dsExpr (HsCoreAnn _ _ expr)+ = dsLExpr expr++dsExpr (HsCase discrim matches)+ = do { core_discrim <- dsLExpr discrim+ ; ([discrim_var], matching_code) <- matchWrapper CaseAlt matches+ ; return (bindNonRec discrim_var core_discrim matching_code) }++-- Pepe: The binds are in scope in the body but NOT in the binding group+-- This is to avoid silliness in breakpoints+dsExpr (HsLet binds body) = do+ body' <- dsLExpr body+ dsLocalBinds binds body'++-- We need the `ListComp' form to use `deListComp' (rather than the "do" form)+-- because the interpretation of `stmts' depends on what sort of thing it is.+--+dsExpr (HsDo ListComp stmts res_ty) = dsListComp stmts res_ty+dsExpr (HsDo PArrComp stmts _) = dsPArrComp (map unLoc stmts)+dsExpr (HsDo DoExpr stmts _) = dsDo stmts+dsExpr (HsDo GhciStmtCtxt stmts _) = dsDo stmts+dsExpr (HsDo MDoExpr stmts _) = dsDo stmts+dsExpr (HsDo MonadComp stmts _) = dsMonadComp stmts++dsExpr (HsIf mb_fun guard_expr then_expr else_expr)+ = do { pred <- dsLExpr guard_expr+ ; b1 <- dsLExpr then_expr+ ; b2 <- dsLExpr else_expr+ ; case mb_fun of+ Just fun -> do { core_fun <- dsExpr fun+ ; return (mkCoreApps core_fun [pred,b1,b2]) }+ Nothing -> return $ mkIfThenElse pred b1 b2 }++dsExpr (HsMultiIf res_ty alts)+ | null alts+ = mkErrorExpr++ | otherwise+ = do { match_result <- liftM (foldr1 combineMatchResults)+ (mapM (dsGRHS IfAlt res_ty) alts)+ ; error_expr <- mkErrorExpr+ ; extractMatchResult match_result error_expr }+ where+ mkErrorExpr = mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID res_ty+ (ptext (sLit "multi-way if"))++{-+\noindent+\underline{\bf Various data construction things}+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-}++dsExpr (ExplicitList elt_ty wit xs)+ = dsExplicitList elt_ty wit xs++-- We desugar [:x1, ..., xn:] as+-- singletonP x1 +:+ ... +:+ singletonP xn+--+dsExpr (ExplicitPArr ty []) = do+ emptyP <- dsDPHBuiltin emptyPVar+ return (Var emptyP `App` Type ty)+dsExpr (ExplicitPArr ty xs) = do+ singletonP <- dsDPHBuiltin singletonPVar+ appP <- dsDPHBuiltin appPVar+ xs' <- mapM dsLExpr xs+ return . foldr1 (binary appP) $ map (unary singletonP) xs'+ where+ unary fn x = mkApps (Var fn) [Type ty, x]+ binary fn x y = mkApps (Var fn) [Type ty, x, y]++dsExpr (ArithSeq expr witness seq)+ = case witness of+ Nothing -> dsArithSeq expr seq+ Just fl -> do {+ ; fl' <- dsExpr fl+ ; newArithSeq <- dsArithSeq expr seq+ ; return (App fl' newArithSeq)}++dsExpr (PArrSeq expr (FromTo from to))+ = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to]++dsExpr (PArrSeq expr (FromThenTo from thn to))+ = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn, to]++dsExpr (PArrSeq _ _)+ = panic "DsExpr.dsExpr: Infinite parallel array!"+ -- the parser shouldn't have generated it and the renamer and typechecker+ -- shouldn't have let it through++{-+\noindent+\underline{\bf Static Pointers}+ ~~~~~~~~~~~~~~~+\begin{verbatim}+ g = ... static f ...+==>+ sptEntry:N = StaticPtr+ (fingerprintString "pkgKey:module.sptEntry:N")+ (StaticPtrInfo "current pkg key" "current module" "sptEntry:0")+ f+ g = ... sptEntry:N+\end{verbatim}+-}++dsExpr (HsStatic expr@(L loc _)) = do+ expr_ds <- dsLExpr expr+ let ty = exprType expr_ds+ n' <- mkSptEntryName loc+ static_binds_var <- dsGetStaticBindsVar++ staticPtrTyCon <- dsLookupTyCon staticPtrTyConName+ staticPtrInfoDataCon <- dsLookupDataCon staticPtrInfoDataConName+ staticPtrDataCon <- dsLookupDataCon staticPtrDataConName+ fingerprintDataCon <- dsLookupDataCon fingerprintDataConName++ dflags <- getDynFlags+ let (line, col) = case loc of+ RealSrcSpan r -> ( srcLocLine $ realSrcSpanStart r+ , srcLocCol $ realSrcSpanStart r+ )+ _ -> (0, 0)+ srcLoc = mkCoreConApps (tupleCon BoxedTuple 2)+ [ Type intTy , Type intTy+ , mkIntExprInt dflags line, mkIntExprInt dflags col+ ]+ info <- mkConApp staticPtrInfoDataCon <$>+ (++[srcLoc]) <$>+ mapM mkStringExprFS+ [ packageKeyFS $ modulePackageKey $ nameModule n'+ , moduleNameFS $ moduleName $ nameModule n'+ , occNameFS $ nameOccName n'+ ]+ let tvars = varSetElems $ tyVarsOfType ty+ speTy = mkForAllTys tvars $ mkTyConApp staticPtrTyCon [ty]+ speId = mkExportedLocalId VanillaId n' speTy+ fp@(Fingerprint w0 w1) = fingerprintName $ idName speId+ fp_core = mkConApp fingerprintDataCon+ [ mkWord64LitWordRep dflags w0+ , mkWord64LitWordRep dflags w1+ ]+ sp = mkConApp staticPtrDataCon [Type ty, fp_core, info, expr_ds]+ liftIO $ modifyIORef static_binds_var ((fp, (speId, mkLams tvars sp)) :)+ putSrcSpanDs loc $ return $ mkTyApps (Var speId) (map mkTyVarTy tvars)++ where++ -- | Choose either 'Word64#' or 'Word#' to represent the arguments of the+ -- 'Fingerprint' data constructor.+ mkWord64LitWordRep dflags+ | platformWordSize (targetPlatform dflags) < 8 = mkWord64LitWord64+ | otherwise = mkWordLit dflags . toInteger++ fingerprintName :: Name -> Fingerprint+ fingerprintName n = fingerprintString $ unpackFS $ concatFS+ [ packageKeyFS $ modulePackageKey $ nameModule n+ , fsLit ":"+ , moduleNameFS (moduleName $ nameModule n)+ , fsLit "."+ , occNameFS $ occName n+ ]++{-+\noindent+\underline{\bf Record construction and update}+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For record construction we do this (assuming T has three arguments)+\begin{verbatim}+ T { op2 = e }+==>+ let err = /\a -> recConErr a+ T (recConErr t1 "M.lhs/230/op1")+ e+ (recConErr t1 "M.lhs/230/op3")+\end{verbatim}+@recConErr@ then converts its arugment string into a proper message+before printing it as+\begin{verbatim}+ M.lhs, line 230: missing field op1 was evaluated+\end{verbatim}++We also handle @C{}@ as valid construction syntax for an unlabelled+constructor @C@, setting all of @C@'s fields to bottom.+-}++dsExpr (RecordCon (L _ data_con_id) con_expr rbinds) = do+ con_expr' <- dsExpr con_expr+ let+ (arg_tys, _) = tcSplitFunTys (exprType con_expr')+ -- A newtype in the corner should be opaque;+ -- hence TcType.tcSplitFunTys++ mk_arg (arg_ty, lbl) -- Selector id has the field label as its name+ = case findField (rec_flds rbinds) lbl of+ (rhs:_) -> -- ASSERT( null rhss )+ dsLExpr rhs+ [] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr lbl)+ unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty Outputable.empty++ labels = dataConFieldLabels (idDataCon data_con_id)+ -- The data_con_id is guaranteed to be the wrapper id of the constructor++ con_args <- if null labels+ then mapM unlabelled_bottom arg_tys+ else mapM mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels)++ return (mkApps con_expr' con_args)++{-+Record update is a little harder. Suppose we have the decl:+\begin{verbatim}+ data T = T1 {op1, op2, op3 :: Int}+ | T2 {op4, op2 :: Int}+ | T3+\end{verbatim}+Then we translate as follows:+\begin{verbatim}+ r { op2 = e }+===>+ let op2 = e in+ case r of+ T1 op1 _ op3 -> T1 op1 op2 op3+ T2 op4 _ -> T2 op4 op2+ other -> recUpdError "M.lhs/230"+\end{verbatim}+It's important that we use the constructor Ids for @T1@, @T2@ etc on the+RHSs, and do not generate a Core constructor application directly, because the constructor+might do some argument-evaluation first; and may have to throw away some+dictionaries.++Note [Update for GADTs]+~~~~~~~~~~~~~~~~~~~~~~~+Consider+ data T a b where+ T1 { f1 :: a } :: T a Int++Then the wrapper function for T1 has type+ $WT1 :: a -> T a Int+But if x::T a b, then+ x { f1 = v } :: T a b (not T a Int!)+So we need to cast (T a Int) to (T a b). Sigh.+-}++dsExpr (RecordUpd record_expr (HsRecFields { rec_flds = fields })+ cons_to_upd in_inst_tys out_inst_tys)+ | null fields+ = dsLExpr record_expr+ | otherwise+ = -- ASSERT2( notNull cons_to_upd, ppr expr )++ do { record_expr' <- dsLExpr record_expr+ ; field_binds' <- mapM ds_field fields+ ; let upd_fld_env :: NameEnv Id -- Maps field name to the LocalId of the field binding+ upd_fld_env = mkNameEnv [(f,l) | (f,l,_) <- field_binds']++ -- It's important to generate the match with matchWrapper,+ -- and the right hand sides with applications of the wrapper Id+ -- so that everything works when we are doing fancy unboxing on the+ -- constructor aguments.+ ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd+ ; ([discrim_var], matching_code)+ <- matchWrapper RecUpd (MG { mg_alts = alts, mg_arg_tys = [in_ty]+ , mg_res_ty = out_ty, mg_origin = FromSource })+ -- FromSource is not strictly right, but we+ -- want incomplete pattern-match warnings++ ; return (add_field_binds field_binds' $+ bindNonRec discrim_var record_expr' matching_code) }+ where+ ds_field :: LHsRecField Id (LHsExpr Id) -> DsM (Name, Id, CoreExpr)+ -- Clone the Id in the HsRecField, because its Name is that+ -- of the record selector, and we must not make that a lcoal binder+ -- else we shadow other uses of the record selector+ -- Hence 'lcl_id'. Cf Trac #2735+ ds_field (L _ rec_field) = do { rhs <- dsLExpr (hsRecFieldArg rec_field)+ ; let fld_id = unLoc (hsRecFieldId rec_field)+ ; lcl_id <- newSysLocalDs (idType fld_id)+ ; return (idName fld_id, lcl_id, rhs) }++ add_field_binds [] expr = expr+ add_field_binds ((_,b,r):bs) expr = bindNonRec b r (add_field_binds bs expr)++ -- Awkwardly, for families, the match goes+ -- from instance type to family type+ tycon = dataConTyCon (head cons_to_upd)+ in_ty = mkTyConApp tycon in_inst_tys+ out_ty = mkFamilyTyConApp tycon out_inst_tys++ mk_alt upd_fld_env con+ = do { let (univ_tvs, ex_tvs, eq_spec,+ theta, arg_tys, _) = dataConFullSig con+ subst = mkTopTvSubst (univ_tvs `zip` in_inst_tys)++ -- I'm not bothering to clone the ex_tvs+ ; eqs_vars <- mapM newPredVarDs (substTheta subst (eqSpecPreds eq_spec))+ ; theta_vars <- mapM newPredVarDs (substTheta subst theta)+ ; arg_ids <- newSysLocalsDs (substTys subst arg_tys)+ ; let val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg+ (dataConFieldLabels con) arg_ids+ mk_val_arg field_name pat_arg_id+ = nlHsVar (lookupNameEnv upd_fld_env field_name `orElse` pat_arg_id)+ inst_con = noLoc $ HsWrap wrap (HsVar (dataConWrapId con))+ -- Reconstruct with the WrapId so that unpacking happens+ wrap = mkWpEvVarApps theta_vars <.>+ mkWpTyApps (mkTyVarTys ex_tvs) <.>+ mkWpTyApps [ty | (tv, ty) <- univ_tvs `zip` out_inst_tys+ , not (tv `elemVarEnv` wrap_subst) ]+ rhs = foldl (\a b -> nlHsApp a b) inst_con val_args++ -- Tediously wrap the application in a cast+ -- Note [Update for GADTs]+ wrap_co = mkTcTyConAppCo Nominal tycon+ [ lookup tv ty | (tv,ty) <- univ_tvs `zip` out_inst_tys ]+ lookup univ_tv ty = case lookupVarEnv wrap_subst univ_tv of+ Just co' -> co'+ Nothing -> mkTcReflCo Nominal ty+ wrap_subst = mkVarEnv [ (tv, mkTcSymCo (mkTcCoVarCo eq_var))+ | ((tv,_),eq_var) <- eq_spec `zip` eqs_vars ]++ pat = noLoc $ ConPatOut { pat_con = noLoc (RealDataCon con)+ , pat_tvs = ex_tvs+ , pat_dicts = eqs_vars ++ theta_vars+ , pat_binds = emptyTcEvBinds+ , pat_args = PrefixCon $ map nlVarPat arg_ids+ , pat_arg_tys = in_inst_tys+ , pat_wrap = idHsWrapper }+ ; let wrapped_rhs | null eq_spec = rhs+ | otherwise = mkLHsWrap (mkWpCast (mkTcSubCo wrap_co)) rhs+ ; return (mkSimpleMatch [pat] wrapped_rhs) }++-- Here is where we desugar the Template Haskell brackets and escapes++-- Template Haskell stuff++dsExpr (HsRnBracketOut _ _) = panic "dsExpr HsRnBracketOut"+-- #ifdef GHCI+-- dsExpr (HsTcBracketOut x ps) = dsBracket x ps+-- #else+dsExpr (HsTcBracketOut _ _) = panic "dsExpr HsBracketOut"+-- #endif+dsExpr (HsSpliceE _ s) = pprPanic "dsExpr:splice" (ppr s)++-- Arrow notation extension+dsExpr (HsProc pat cmd) = dsProcExpr pat cmd++-- Hpc Support++dsExpr (HsTick tickish e) = do+ e' <- dsLExpr e+ return (Tick tickish e')++-- There is a problem here. The then and else branches+-- have no free variables, so they are open to lifting.+-- We need someway of stopping this.+-- This will make no difference to binary coverage+-- (did you go here: YES or NO), but will effect accurate+-- tick counting.++dsExpr (HsBinTick ixT ixF e) = do+ e2 <- dsLExpr e+ do { -- ASSERT(exprType e2 `eqType` boolTy)+ mkBinaryTickBox ixT ixF e2+ }++dsExpr (HsTickPragma _ _ expr) = do+ dflags <- getDynFlags+ if gopt Opt_Hpc dflags+ then panic "dsExpr:HsTickPragma"+ else dsLExpr expr++-- HsSyn constructs that just shouldn't be here:+dsExpr (ExprWithTySig {}) = panic "dsExpr:ExprWithTySig"+dsExpr (HsBracket {}) = panic "dsExpr:HsBracket"+dsExpr (HsQuasiQuoteE {}) = panic "dsExpr:HsQuasiQuoteE"+dsExpr (HsArrApp {}) = panic "dsExpr:HsArrApp"+dsExpr (HsArrForm {}) = panic "dsExpr:HsArrForm"+dsExpr (EWildPat {}) = panic "dsExpr:EWildPat"+dsExpr (EAsPat {}) = panic "dsExpr:EAsPat"+dsExpr (EViewPat {}) = panic "dsExpr:EViewPat"+dsExpr (ELazyPat {}) = panic "dsExpr:ELazyPat"+dsExpr (HsType {}) = panic "dsExpr:HsType"+dsExpr (HsDo {}) = panic "dsExpr:HsDo"++++findField :: [LHsRecField Id arg] -> Name -> [arg]+findField rbinds lbl+ = [rhs | L _ (HsRecField { hsRecFieldId = id, hsRecFieldArg = rhs }) <- rbinds+ , lbl == idName (unLoc id) ]++{-+%--------------------------------------------------------------------++Note [Desugaring explicit lists]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Explicit lists are desugared in a cleverer way to prevent some+fruitless allocations. Essentially, whenever we see a list literal+[x_1, ..., x_n] we:++1. Find the tail of the list that can be allocated statically (say+ [x_k, ..., x_n]) by later stages and ensure we desugar that+ normally: this makes sure that we don't cause a code size increase+ by having the cons in that expression fused (see later) and hence+ being unable to statically allocate any more++2. For the prefix of the list which cannot be allocated statically,+ say [x_1, ..., x_(k-1)], we turn it into an expression involving+ build so that if we find any foldrs over it it will fuse away+ entirely!++ So in this example we will desugar to:+ build (\c n -> x_1 `c` x_2 `c` .... `c` foldr c n [x_k, ..., x_n]++ If fusion fails to occur then build will get inlined and (since we+ defined a RULE for foldr (:) []) we will get back exactly the+ normal desugaring for an explicit list.++This optimisation can be worth a lot: up to 25% of the total+allocation in some nofib programs. Specifically++ Program Size Allocs Runtime CompTime+ rewrite +0.0% -26.3% 0.02 -1.8%+ ansi -0.3% -13.8% 0.00 +0.0%+ lift +0.0% -8.7% 0.00 -2.3%++Of course, if rules aren't turned on then there is pretty much no+point doing this fancy stuff, and it may even be harmful.++=======> Note by SLPJ Dec 08.++I'm unconvinced that we should *ever* generate a build for an explicit+list. See the comments in GHC.Base about the foldr/cons rule, which+points out that (foldr k z [a,b,c]) may generate *much* less code than+(a `k` b `k` c `k` z).++Furthermore generating builds messes up the LHS of RULES.+Example: the foldr/single rule in GHC.Base+ foldr k z [x] = ...+We do not want to generate a build invocation on the LHS of this RULE!++We fix this by disabling rules in rule LHSs, and testing that+flag here; see Note [Desugaring RULE left hand sides] in Desugar++To test this I've added a (static) flag -fsimple-list-literals, which+makes all list literals be generated via the simple route.+-}++dsExplicitList :: PostTc Id Type -> Maybe (SyntaxExpr Id) -> [LHsExpr Id]+ -> DsM CoreExpr+-- See Note [Desugaring explicit lists]+dsExplicitList elt_ty Nothing xs+ = do { dflags <- getDynFlags+ ; xs' <- mapM dsLExpr xs+ ; let (dynamic_prefix, static_suffix) = spanTail is_static xs'+ ; if gopt Opt_SimpleListLiterals dflags -- -fsimple-list-literals+ || not (gopt Opt_EnableRewriteRules dflags) -- Rewrite rules off+ -- Don't generate a build if there are no rules to eliminate it!+ -- See Note [Desugaring RULE left hand sides] in Desugar+ || null dynamic_prefix -- Avoid build (\c n. foldr c n xs)!+ then return $ mkListExpr elt_ty xs'+ else mkBuildExpr elt_ty (mkSplitExplicitList dynamic_prefix static_suffix) }+ where+ is_static :: CoreExpr -> Bool+ is_static e = all is_static_var (varSetElems (exprFreeVars e))++ is_static_var :: Var -> Bool+ is_static_var v+ | isId v = isExternalName (idName v) -- Top-level things are given external names+ | otherwise = False -- Type variables++ mkSplitExplicitList prefix suffix (c, _) (n, n_ty)+ = do { let suffix' = mkListExpr elt_ty suffix+ ; folded_suffix <- mkFoldrExpr elt_ty n_ty (Var c) (Var n) suffix'+ ; return (foldr (App . App (Var c)) folded_suffix prefix) }++dsExplicitList elt_ty (Just fln) xs+ = do { fln' <- dsExpr fln+ ; list <- dsExplicitList elt_ty Nothing xs+ ; dflags <- getDynFlags+ ; return (App (App fln' (mkIntExprInt dflags (length xs))) list) }++spanTail :: (a -> Bool) -> [a] -> ([a], [a])+spanTail f xs = (reverse rejected, reverse satisfying)+ where (satisfying, rejected) = span f $ reverse xs++dsArithSeq :: PostTcExpr -> (ArithSeqInfo Id) -> DsM CoreExpr+dsArithSeq expr (From from)+ = App <$> dsExpr expr <*> dsLExpr from+dsArithSeq expr (FromTo from to)+ = do dflags <- getDynFlags+ warnAboutEmptyEnumerations dflags from Nothing to+ expr' <- dsExpr expr+ from' <- dsLExpr from+ to' <- dsLExpr to+ return $ mkApps expr' [from', to']+dsArithSeq expr (FromThen from thn)+ = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn]+dsArithSeq expr (FromThenTo from thn to)+ = do dflags <- getDynFlags+ warnAboutEmptyEnumerations dflags from (Just thn) to+ expr' <- dsExpr expr+ from' <- dsLExpr from+ thn' <- dsLExpr thn+ to' <- dsLExpr to+ return $ mkApps expr' [from', thn', to']++{-+Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're+handled in DsListComp). Basically does the translation given in the+Haskell 98 report:+-}++dsDo :: [ExprLStmt Id] -> DsM CoreExpr+dsDo stmts+ = goL stmts+ where+ goL [] = panic "dsDo"+ goL (L loc stmt:lstmts) = putSrcSpanDs loc (go loc stmt lstmts)++ go _ (LastStmt body _) _stmts+ = {- ASSERT( null stmts ) -} dsLExpr body+ -- The 'return' op isn't used for 'do' expressions++ go _ (BodyStmt rhs then_expr _ _) stmts+ = do { rhs2 <- dsLExpr rhs+ ; warnDiscardedDoBindings rhs (exprType rhs2)+ ; then_expr2 <- dsExpr then_expr+ ; rest <- goL stmts+ ; return (mkApps then_expr2 [rhs2, rest]) }++ go _ (LetStmt binds) stmts+ = do { rest <- goL stmts+ ; dsLocalBinds binds rest }++ go _ (BindStmt pat rhs bind_op fail_op) stmts+ = do { body <- goL stmts+ ; rhs' <- dsLExpr rhs+ ; bind_op' <- dsExpr bind_op+ ; var <- selectSimpleMatchVarL pat+ ; let bind_ty = exprType bind_op' -- rhs -> (pat -> res1) -> res2+ res1_ty = funResultTy (funArgTy (funResultTy bind_ty))+ ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat+ res1_ty (cantFailMatchResult body)+ ; match_code <- handle_failure pat match fail_op+ ; return (mkApps bind_op' [rhs', Lam var match_code]) }++ go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids+ , recS_rec_ids = rec_ids, recS_ret_fn = return_op+ , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op+ , recS_rec_rets = rec_rets, recS_ret_ty = body_ty }) stmts+ = goL (new_bind_stmt : stmts) -- rec_ids can be empty; eg rec { print 'x' }+ where+ new_bind_stmt = L loc $ BindStmt (mkBigLHsPatTup later_pats)+ mfix_app bind_op+ noSyntaxExpr -- Tuple cannot fail++ tup_ids = rec_ids ++ filterOut (`elem` rec_ids) later_ids+ tup_ty = mkBigCoreTupTy (map idType tup_ids) -- Deals with singleton case+ rec_tup_pats = map nlVarPat tup_ids+ later_pats = rec_tup_pats+ rets = map noLoc rec_rets+ mfix_app = nlHsApp (noLoc mfix_op) mfix_arg+ mfix_arg = noLoc $ HsLam (MG { mg_alts = [mkSimpleMatch [mfix_pat] body]+ , mg_arg_tys = [tup_ty], mg_res_ty = body_ty+ , mg_origin = Generated })+ mfix_pat = noLoc $ LazyPat $ mkBigLHsPatTup rec_tup_pats+ body = noLoc $ HsDo DoExpr (rec_stmts ++ [ret_stmt]) body_ty+ ret_app = nlHsApp (noLoc return_op) (mkBigLHsTup rets)+ ret_stmt = noLoc $ mkLastStmt ret_app+ -- This LastStmt will be desugared with dsDo,+ -- which ignores the return_op in the LastStmt,+ -- so we must apply the return_op explicitly++ go _ (ParStmt {}) _ = panic "dsDo ParStmt"+ go _ (TransStmt {}) _ = panic "dsDo TransStmt"++handle_failure :: LPat Id -> MatchResult -> SyntaxExpr Id -> DsM CoreExpr+ -- In a do expression, pattern-match failure just calls+ -- the monadic 'fail' rather than throwing an exception+handle_failure pat match fail_op+ | matchCanFail match+ = do { fail_op' <- dsExpr fail_op+ ; dflags <- getDynFlags+ ; fail_msg <- mkStringExpr (mk_fail_msg dflags pat)+ ; extractMatchResult match (App fail_op' fail_msg) }+ | otherwise+ = extractMatchResult match (error "It can't fail")++mk_fail_msg :: DynFlags -> Located e -> String+mk_fail_msg dflags pat = "Pattern match failure in do expression at " +++ showPpr dflags (getLoc pat)++{-+************************************************************************+* *+\subsection{Errors and contexts}+* *+************************************************************************+-}++-- Warn about certain types of values discarded in monadic bindings (#3263)+warnDiscardedDoBindings :: LHsExpr Id -> Type -> DsM ()+warnDiscardedDoBindings rhs rhs_ty+ | Just (m_ty, elt_ty) <- tcSplitAppTy_maybe rhs_ty+ = do { warn_unused <- woptM Opt_WarnUnusedDoBind+ ; warn_wrong <- woptM Opt_WarnWrongDoBind+ ; when (warn_unused || warn_wrong) $+ do { fam_inst_envs <- dsGetFamInstEnvs+ ; let norm_elt_ty = topNormaliseType fam_inst_envs elt_ty++ -- Warn about discarding non-() things in 'monadic' binding+ ; if warn_unused && not (isUnitTy norm_elt_ty)+ then warnDs (badMonadBind rhs elt_ty+ (ptext (sLit "-fno-warn-unused-do-bind")))+ else++ -- Warn about discarding m a things in 'monadic' binding of the same type,+ -- but only if we didn't already warn due to Opt_WarnUnusedDoBind+ when warn_wrong $+ do { case tcSplitAppTy_maybe norm_elt_ty of+ Just (elt_m_ty, _)+ | m_ty `eqType` topNormaliseType fam_inst_envs elt_m_ty+ -> warnDs (badMonadBind rhs elt_ty+ (ptext (sLit "-fno-warn-wrong-do-bind")))+ _ -> return () } } }++ | otherwise -- RHS does have type of form (m ty), which is weird+ = return () -- but at lesat this warning is irrelevant++badMonadBind :: LHsExpr Id -> Type -> SDoc -> SDoc+badMonadBind rhs elt_ty flag_doc+ = vcat [ hang (ptext (sLit "A do-notation statement discarded a result of type"))+ 2 (quotes (ppr elt_ty))+ , hang (ptext (sLit "Suppress this warning by saying"))+ 2 (quotes $ ptext (sLit "_ <-") <+> ppr rhs)+ , ptext (sLit "or by using the flag") <+> flag_doc ]++{-+************************************************************************+* *+\subsection{Static pointers}+* *+************************************************************************+-}++-- | Creates an name for an entry in the Static Pointer Table.+--+-- The name has the form @sptEntry:<N>@ where @<N>@ is generated from a+-- per-module counter.+--+mkSptEntryName :: SrcSpan -> DsM Name+mkSptEntryName loc = do+ uniq <- newUnique+ mod <- getModule+ occ <- mkWrapperName "sptEntry"+ return $ mkExternalName uniq mod occ loc+ where+ mkWrapperName what+ = do dflags <- getDynFlags+ thisMod <- getModule+ let -- Note [Generating fresh names for ccall wrapper]+ -- in compiler/typecheck/TcEnv.hs+ wrapperRef = nextWrapperNum dflags+ wrapperNum <- liftIO $ atomicModifyIORef wrapperRef $ \mod_env ->+ let num = lookupWithDefaultModuleEnv mod_env 0 thisMod+ in (extendModuleEnv mod_env thisMod (num+1), num)+ return $ mkVarOcc $ what ++ ":" ++ show wrapperNum
+ src/Language/Haskell/Liquid/Desugar710/DsExpr.hs-boot view
@@ -0,0 +1,9 @@+module Language.Haskell.Liquid.Desugar710.DsExpr where+import HsSyn ( HsExpr, LHsExpr, HsLocalBinds )+import Var ( Id )+import DsMonad ( DsM )+import CoreSyn ( CoreExpr )++dsExpr :: HsExpr Id -> DsM CoreExpr+dsLExpr :: LHsExpr Id -> DsM CoreExpr+dsLocalBinds :: HsLocalBinds Id -> CoreExpr -> DsM CoreExpr
+ src/Language/Haskell/Liquid/Desugar710/DsForeign.hs view
@@ -0,0 +1,809 @@+{-+(c) The University of Glasgow 2006+(c) The AQUA Project, Glasgow University, 1998+++Desugaring foreign declarations (see also DsCCall).+-}++{-# LANGUAGE CPP #-}++module Language.Haskell.Liquid.Desugar710.DsForeign ( dsForeigns+ , dsForeigns'+ , dsFImport, dsCImport, dsFCall, dsPrimCall+ , dsFExport, dsFExportDynamic, mkFExportCBits+ , toCType+ , foreignExportInitialiser+ ) where++-- #include "HsVersions.h"+import TcRnMonad -- temp++import TypeRep++import CoreSyn++import DsCCall+import DsMonad++import HsSyn+import DataCon+import CoreUnfold+import Id+import Literal+import Module+import Name+import Type+import TyCon+import Coercion+import TcEnv+import TcType++import CmmExpr+import CmmUtils+import HscTypes+import ForeignCall+import TysWiredIn+import TysPrim+import PrelNames+import BasicTypes+import SrcLoc+import Outputable+import FastString+import DynFlags+import Platform+import Config+import OrdList+import Pair+import Hooks++import Data.Maybe+import Data.List++{-+Desugaring of @foreign@ declarations is naturally split up into+parts, an @import@ and an @export@ part. A @foreign import@+declaration+\begin{verbatim}+ foreign import cc nm f :: prim_args -> IO prim_res+\end{verbatim}+is the same as+\begin{verbatim}+ f :: prim_args -> IO prim_res+ f a1 ... an = _ccall_ nm cc a1 ... an+\end{verbatim}+so we reuse the desugaring code in @DsCCall@ to deal with these.+-}++type Binding = (Id, CoreExpr) -- No rec/nonrec structure;+ -- the occurrence analyser will sort it all out++dsForeigns :: [LForeignDecl Id]+ -> DsM (ForeignStubs, OrdList Binding)+dsForeigns fos = getHooked dsForeignsHook dsForeigns' >>= ($ fos)++dsForeigns' :: [LForeignDecl Id]+ -> DsM (ForeignStubs, OrdList Binding)+dsForeigns' []+ = return (NoStubs, nilOL)+dsForeigns' fos = do+ fives <- mapM do_ldecl fos+ let+ (hs, cs, idss, bindss) = unzip4 fives+ fe_ids = concat idss+ fe_init_code = map foreignExportInitialiser fe_ids+ --+ return (ForeignStubs+ (vcat hs)+ (vcat cs $$ vcat fe_init_code),+ foldr (appOL . toOL) nilOL bindss)+ where+ do_ldecl (L loc decl) = putSrcSpanDs loc (do_decl decl)++ do_decl (ForeignImport id _ co spec) = do+ traceIf (text "fi start" <+> ppr id)+ (bs, h, c) <- dsFImport (unLoc id) co spec+ traceIf (text "fi end" <+> ppr id)+ return (h, c, [], bs)++ do_decl (ForeignExport (L _ id) _ co+ (CExport (L _ (CExportStatic ext_nm cconv)) _)) = do+ (h, c, _, _) <- dsFExport id co ext_nm cconv False+ return (h, c, [id], [])++{-+************************************************************************+* *+\subsection{Foreign import}+* *+************************************************************************++Desugaring foreign imports is just the matter of creating a binding+that on its RHS unboxes its arguments, performs the external call+(using the @CCallOp@ primop), before boxing the result up and returning it.++However, we create a worker/wrapper pair, thus:++ foreign import f :: Int -> IO Int+==>+ f x = IO ( \s -> case x of { I# x# ->+ case fw s x# of { (# s1, y# #) ->+ (# s1, I# y# #)}})++ fw s x# = ccall f s x#++The strictness/CPR analyser won't do this automatically because it doesn't look+inside returned tuples; but inlining this wrapper is a Really Good Idea+because it exposes the boxing to the call site.+-}++dsFImport :: Id+ -> Coercion+ -> ForeignImport+ -> DsM ([Binding], SDoc, SDoc)+dsFImport id co (CImport cconv safety mHeader spec _) = do+ (ids, h, c) <- dsCImport id co spec (unLoc cconv) (unLoc safety) mHeader+ return (ids, h, c)++dsCImport :: Id+ -> Coercion+ -> CImportSpec+ -> CCallConv+ -> Safety+ -> Maybe Header+ -> DsM ([Binding], SDoc, SDoc)+dsCImport id co (CLabel _) _ _ _ = do+ -- dflags <- getDynFlags+ -- let ty = pFst $ coercionKind co+ -- fod = case tyConAppTyCon_maybe (dropForAlls ty) of+ -- Just tycon+ -- | tyConUnique tycon == funPtrTyConKey ->+ -- IsFunction+ -- _ -> IsData+ -- (resTy, foRhs) <- resultWrapper ty+ -- ASSERT(fromJust resTy `eqType` addrPrimTy) -- typechecker ensures this+ let rhs = let x = x in x -- foRhs (Lit (MachLabel cid stdcall_info fod))+ let rhs' = Cast rhs co+ -- let stdcall_info = fun_type_arg_stdcall_info dflags cconv ty+ return ([(id, rhs')], empty, empty)++dsCImport id co (CFunction target) cconv@PrimCallConv safety _+ = dsPrimCall id co (CCall (CCallSpec target cconv safety))+dsCImport id co (CFunction target) cconv safety mHeader+ = dsFCall id co (CCall (CCallSpec target cconv safety)) mHeader+dsCImport id co CWrapper cconv _ _+ = dsFExportDynamic id co cconv++-- For stdcall labels, if the type was a FunPtr or newtype thereof,+-- then we need to calculate the size of the arguments in order to add+-- the @n suffix to the label.+-- fun_type_arg_stdcall_info :: DynFlags -> CCallConv -> Type -> Maybe Int+-- fun_type_arg_stdcall_info dflags StdCallConv ty+-- | Just (tc,[arg_ty]) <- splitTyConApp_maybe ty,+-- tyConUnique tc == funPtrTyConKey+-- = let+-- (_tvs,sans_foralls) = tcSplitForAllTys arg_ty+-- (fe_arg_tys, _orig_res_ty) = tcSplitFunTys sans_foralls+-- in Just $ sum (map (widthInBytes . typeWidth . typeCmmType dflags . getPrimTyOf) fe_arg_tys)+-- fun_type_arg_stdcall_info _ _other_conv _+-- = Nothing++{-+************************************************************************+* *+\subsection{Foreign calls}+* *+************************************************************************+-}++dsFCall :: Id -> Coercion -> ForeignCall -> Maybe Header+ -> DsM ([(Id, Expr TyVar)], SDoc, SDoc)+dsFCall fn_id co fcall mDeclHeader = do+ let+ ty = pFst $ coercionKind co+ (tvs, fun_ty) = tcSplitForAllTys ty+ (arg_tys, io_res_ty) = tcSplitFunTys fun_ty+ -- Must use tcSplit* functions because we want to+ -- see that (IO t) in the corner++ args <- newSysLocalsDs arg_tys+ (val_args, arg_wrappers) <- mapAndUnzipM unboxArg (map Var args)++ let+ work_arg_ids = [v | Var v <- val_args] -- All guaranteed to be vars++ (ccall_result_ty, res_wrapper) <- boxResult io_res_ty++ ccall_uniq <- newUnique+ work_uniq <- newUnique++ dflags <- getDynFlags+ (fcall', cDoc) <-+ case fcall of+ CCall (CCallSpec (StaticTarget cName mPackageKey isFun) CApiConv safety) ->+ do wrapperName <- mkWrapperName "ghc_wrapper" (unpackFS cName)+ let fcall' = CCall (CCallSpec (StaticTarget wrapperName mPackageKey True) CApiConv safety)+ c = includes+ $$ fun_proto <+> braces (cRet <> semi)+ includes = vcat [ text "#include <" <> ftext h <> text ">"+ | Header h <- nub headers ]+ fun_proto = cResType <+> pprCconv <+> ppr wrapperName <> parens argTypes+ cRet+ | isVoidRes = cCall+ | otherwise = text "return" <+> cCall+ cCall = if isFun+ then ppr cName <> parens argVals+ else if null arg_tys+ then ppr cName+ else panic "dsFCall: Unexpected arguments to FFI value import"+ raw_res_ty = case tcSplitIOType_maybe io_res_ty of+ Just (_ioTyCon, res_ty) -> res_ty+ Nothing -> io_res_ty+ isVoidRes = raw_res_ty `eqType` unitTy+ (mHeader, cResType)+ | isVoidRes = (Nothing, text "void")+ | otherwise = toCType raw_res_ty+ pprCconv = ccallConvAttribute CApiConv+ mHeadersArgTypeList+ = [ (header, cType <+> char 'a' <> int n)+ | (t, n) <- zip arg_tys [1..]+ , let (header, cType) = toCType t ]+ (mHeaders, argTypeList) = unzip mHeadersArgTypeList+ argTypes = if null argTypeList+ then text "void"+ else hsep $ punctuate comma argTypeList+ mHeaders' = mDeclHeader : mHeader : mHeaders+ headers = catMaybes mHeaders'+ argVals = hsep $ punctuate comma+ [ char 'a' <> int n+ | (_, n) <- zip arg_tys [1..] ]+ return (fcall', c)+ _ ->+ return (fcall, empty)+ let+ -- Build the worker+ worker_ty = mkForAllTys tvs (mkFunTys (map idType work_arg_ids) ccall_result_ty)+ the_ccall_app = mkFCall dflags ccall_uniq fcall' val_args ccall_result_ty+ work_rhs = mkLams tvs (mkLams work_arg_ids the_ccall_app)+ work_id = mkSysLocal (fsLit "$wccall") work_uniq worker_ty++ -- Build the wrapper+ work_app = mkApps (mkVarApps (Var work_id) tvs) val_args+ wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers+ wrap_rhs = mkLams (tvs ++ args) wrapper_body+ wrap_rhs' = Cast wrap_rhs co+ fn_id_w_inl = fn_id `setIdUnfolding` mkInlineUnfolding (Just (length args)) wrap_rhs'++ return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], empty, cDoc)++{-+************************************************************************+* *+\subsection{Primitive calls}+* *+************************************************************************++This is for `@foreign import prim@' declarations.++Currently, at the core level we pretend that these primitive calls are+foreign calls. It may make more sense in future to have them as a distinct+kind of Id, or perhaps to bundle them with PrimOps since semantically and+for calling convention they are really prim ops.+-}++dsPrimCall :: Id -> Coercion -> ForeignCall+ -> DsM ([(Id, Expr TyVar)], SDoc, SDoc)+dsPrimCall fn_id co fcall = do+ let+ ty = pFst $ coercionKind co+ (tvs, fun_ty) = tcSplitForAllTys ty+ (arg_tys, io_res_ty) = tcSplitFunTys fun_ty+ -- Must use tcSplit* functions because we want to+ -- see that (IO t) in the corner++ args <- newSysLocalsDs arg_tys++ ccall_uniq <- newUnique+ dflags <- getDynFlags+ let+ call_app = mkFCall dflags ccall_uniq fcall (map Var args) io_res_ty+ rhs = mkLams tvs (mkLams args call_app)+ rhs' = Cast rhs co+ return ([(fn_id, rhs')], empty, empty)++{-+************************************************************************+* *+\subsection{Foreign export}+* *+************************************************************************++The function that does most of the work for `@foreign export@' declarations.+(see below for the boilerplate code a `@foreign export@' declaration expands+ into.)++For each `@foreign export foo@' in a module M we generate:+\begin{itemize}+\item a C function `@foo@', which calls+\item a Haskell stub `@M.\$ffoo@', which calls+\end{itemize}+the user-written Haskell function `@M.foo@'.+-}++dsFExport :: Id -- Either the exported Id,+ -- or the foreign-export-dynamic constructor+ -> Coercion -- Coercion between the Haskell type callable+ -- from C, and its representation type+ -> CLabelString -- The name to export to C land+ -> CCallConv+ -> Bool -- True => foreign export dynamic+ -- so invoke IO action that's hanging off+ -- the first argument's stable pointer+ -> DsM ( SDoc -- contents of Module_stub.h+ , SDoc -- contents of Module_stub.c+ , String -- string describing type to pass to createAdj.+ , Int -- size of args to stub function+ )++dsFExport fn_id co ext_name cconv isDyn = do+ let+ ty = pSnd $ coercionKind co+ (_tvs,sans_foralls) = tcSplitForAllTys ty+ (fe_arg_tys', orig_res_ty) = tcSplitFunTys sans_foralls+ -- We must use tcSplits here, because we want to see+ -- the (IO t) in the corner of the type!+ fe_arg_tys | isDyn = tail fe_arg_tys'+ | otherwise = fe_arg_tys'++ -- Look at the result type of the exported function, orig_res_ty+ -- If it's IO t, return (t, True)+ -- If it's plain t, return (t, False)+ (res_ty, is_IO_res_ty) = case tcSplitIOType_maybe orig_res_ty of+ -- The function already returns IO t+ Just (_ioTyCon, res_ty) -> (res_ty, True)+ -- The function returns t+ Nothing -> (orig_res_ty, False)++ dflags <- getDynFlags+ return $+ mkFExportCBits dflags ext_name+ (if isDyn then Nothing else Just fn_id)+ fe_arg_tys res_ty is_IO_res_ty cconv++{-+@foreign import "wrapper"@ (previously "foreign export dynamic") lets+you dress up Haskell IO actions of some fixed type behind an+externally callable interface (i.e., as a C function pointer). Useful+for callbacks and stuff.++\begin{verbatim}+type Fun = Bool -> Int -> IO Int+foreign import "wrapper" f :: Fun -> IO (FunPtr Fun)++-- Haskell-visible constructor, which is generated from the above:+-- SUP: No check for NULL from createAdjustor anymore???++f :: Fun -> IO (FunPtr Fun)+f cback =+ bindIO (newStablePtr cback)+ (\StablePtr sp# -> IO (\s1# ->+ case _ccall_ createAdjustor cconv sp# ``f_helper'' <arg info> s1# of+ (# s2#, a# #) -> (# s2#, A# a# #)))++foreign import "&f_helper" f_helper :: FunPtr (StablePtr Fun -> Fun)++-- and the helper in C: (approximately; see `mkFExportCBits` below)++f_helper(StablePtr s, HsBool b, HsInt i)+{+ Capability *cap;+ cap = rts_lock();+ rts_evalIO(&cap,+ rts_apply(rts_apply(deRefStablePtr(s),+ rts_mkBool(b)), rts_mkInt(i)));+ rts_unlock(cap);+}+\end{verbatim}+-}++dsFExportDynamic :: Id+ -> Coercion+ -> CCallConv+ -> DsM ([Binding], SDoc, SDoc)+dsFExportDynamic id co0 cconv = do+ fe_id <- newSysLocalDs ty+ mod <- getModule+ dflags <- getDynFlags+ let+ -- hack: need to get at the name of the C stub we're about to generate.+ -- TODO: There's no real need to go via String with+ -- (mkFastString . zString). In fact, is there a reason to convert+ -- to FastString at all now, rather than sticking with FastZString?+ fe_nm = mkFastString (zString (zEncodeFS (moduleNameFS (moduleName mod))) ++ "_" ++ toCName dflags fe_id)++ cback <- newSysLocalDs arg_ty+ newStablePtrId <- dsLookupGlobalId newStablePtrName+ stable_ptr_tycon <- dsLookupTyCon stablePtrTyConName+ let+ stable_ptr_ty = mkTyConApp stable_ptr_tycon [arg_ty]+ export_ty = mkFunTy stable_ptr_ty arg_ty+ bindIOId <- dsLookupGlobalId bindIOName+ stbl_value <- newSysLocalDs stable_ptr_ty+ (h_code, c_code, typestring, args_size) <- dsFExport id (mkReflCo Representational export_ty) fe_nm cconv True+ let+ {-+ The arguments to the external function which will+ create a little bit of (template) code on the fly+ for allowing the (stable pointed) Haskell closure+ to be entered using an external calling convention+ (stdcall, ccall).+ -}+ adj_args = [ mkIntLitInt dflags (ccallConvToInt cconv)+ , Var stbl_value+ , Lit (MachLabel fe_nm mb_sz_args IsFunction)+ , Lit (mkMachString typestring)+ ]+ -- name of external entry point providing these services.+ -- (probably in the RTS.)+ adjustor = fsLit "createAdjustor"++ -- Determine the number of bytes of arguments to the stub function,+ -- so that we can attach the '@N' suffix to its label if it is a+ -- stdcall on Windows.+ mb_sz_args = case cconv of+ StdCallConv -> Just args_size+ _ -> Nothing++ ccall_adj <- dsCCall adjustor adj_args PlayRisky (mkTyConApp io_tc [res_ty])+ -- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback++ let io_app = mkLams tvs $+ Lam cback $+ mkApps (Var bindIOId)+ [ Type stable_ptr_ty+ , Type res_ty+ , mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ]+ , Lam stbl_value ccall_adj+ ]++ fed = (id `setInlineActivation` NeverActive, Cast io_app co0)+ -- Never inline the f.e.d. function, because the litlit+ -- might not be in scope in other modules.++ return ([fed], h_code, c_code)++ where+ ty = pFst (coercionKind co0)+ (tvs,sans_foralls) = tcSplitForAllTys ty+ ([arg_ty], fn_res_ty) = tcSplitFunTys sans_foralls+ Just (io_tc, res_ty) = tcSplitIOType_maybe fn_res_ty+ -- Must have an IO type; hence Just++toCName :: DynFlags -> Id -> String+toCName dflags i = showSDoc dflags (pprCode CStyle (ppr (idName i)))++{-+*++\subsection{Generating @foreign export@ stubs}++*++For each @foreign export@ function, a C stub function is generated.+The C stub constructs the application of the exported Haskell function+using the hugs/ghc rts invocation API.+-}++mkFExportCBits :: DynFlags+ -> FastString+ -> Maybe Id -- Just==static, Nothing==dynamic+ -> [Type]+ -> Type+ -> Bool -- True <=> returns an IO type+ -> CCallConv+ -> (SDoc,+ SDoc,+ String, -- the argument reps+ Int -- total size of arguments+ )+mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc+ = (header_bits, c_bits, type_string,+ sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- aug_arg_info] -- all the args+ -- NB. the calculation here isn't strictly speaking correct.+ -- We have a primitive Haskell type (eg. Int#, Double#), and+ -- we want to know the size, when passed on the C stack, of+ -- the associated C type (eg. HsInt, HsDouble). We don't have+ -- this information to hand, but we know what GHC's conventions+ -- are for passing around the primitive Haskell types, so we+ -- use that instead. I hope the two coincide --SDM+ )+ where+ -- list the arguments to the C function+ arg_info :: [(SDoc, -- arg name+ SDoc, -- C type+ Type, -- Haskell type+ CmmType)] -- the CmmType+ arg_info = [ let stg_type = showStgType ty in+ (arg_cname n stg_type,+ stg_type,+ ty,+ typeCmmType dflags (getPrimTyOf ty))+ | (ty,n) <- zip arg_htys [1::Int ..] ]++ arg_cname n stg_ty+ | libffi = char '*' <> parens (stg_ty <> char '*') <>+ ptext (sLit "args") <> brackets (int (n-1))+ | otherwise = text ('a':show n)++ -- generate a libffi-style stub if this is a "wrapper" and libffi is enabled+ libffi = cLibFFI && isNothing maybe_target++ type_string+ -- libffi needs to know the result type too:+ | libffi = primTyDescChar dflags res_hty : arg_type_string+ | otherwise = arg_type_string++ arg_type_string = [primTyDescChar dflags ty | (_,_,ty,_) <- arg_info]+ -- just the real args++ -- add some auxiliary args; the stable ptr in the wrapper case, and+ -- a slot for the dummy return address in the wrapper + ccall case+ aug_arg_info+ | isNothing maybe_target = stable_ptr_arg : insertRetAddr dflags cc arg_info+ | otherwise = arg_info++ stable_ptr_arg =+ (text "the_stableptr", text "StgStablePtr", undefined,+ typeCmmType dflags (mkStablePtrPrimTy alphaTy))++ -- stuff to do with the return type of the C function+ res_hty_is_unit = res_hty `eqType` unitTy -- Look through any newtypes++ cResType | res_hty_is_unit = text "void"+ | otherwise = showStgType res_hty++ -- when the return type is integral and word-sized or smaller, it+ -- must be assigned as type ffi_arg (#3516). To see what type+ -- libffi is expecting here, take a look in its own testsuite, e.g.+ -- libffi/testsuite/libffi.call/cls_align_ulonglong.c+ ffi_cResType+ | is_ffi_arg_type = text "ffi_arg"+ | otherwise = cResType+ where+ res_ty_key = getUnique (getName (typeTyCon res_hty))+ is_ffi_arg_type = res_ty_key `notElem`+ [floatTyConKey, doubleTyConKey,+ int64TyConKey, word64TyConKey]++ -- Now we can cook up the prototype for the exported function.+ pprCconv = ccallConvAttribute cc++ header_bits = ptext (sLit "extern") <+> fun_proto <> semi++ fun_args+ | null aug_arg_info = text "void"+ | otherwise = hsep $ punctuate comma+ $ map (\(nm,ty,_,_) -> ty <+> nm) aug_arg_info++ fun_proto+ | libffi+ = ptext (sLit "void") <+> ftext c_nm <>+ parens (ptext (sLit "void *cif STG_UNUSED, void* resp, void** args, void* the_stableptr"))+ | otherwise+ = cResType <+> pprCconv <+> ftext c_nm <> parens fun_args++ -- the target which will form the root of what we ask rts_evalIO to run+ the_cfun+ = case maybe_target of+ Nothing -> text "(StgClosure*)deRefStablePtr(the_stableptr)"+ Just hs_fn -> char '&' <> ppr hs_fn <> text "_closure"++ cap = text "cap" <> comma++ -- the expression we give to rts_evalIO+ expr_to_run+ = foldl appArg the_cfun arg_info -- NOT aug_arg_info+ where+ appArg acc (arg_cname, _, arg_hty, _)+ = text "rts_apply"+ <> parens (cap <> acc <> comma <> mkHObj arg_hty <> parens (cap <> arg_cname))++ -- various other bits for inside the fn+ declareResult = text "HaskellObj ret;"+ declareCResult | res_hty_is_unit = empty+ | otherwise = cResType <+> text "cret;"++ assignCResult | res_hty_is_unit = empty+ | otherwise =+ text "cret=" <> unpackHObj res_hty <> parens (text "ret") <> semi++ -- an extern decl for the fn being called+ extern_decl+ = case maybe_target of+ Nothing -> empty+ Just hs_fn -> text "extern StgClosure " <> ppr hs_fn <> text "_closure" <> semi+++ -- finally, the whole darn thing+ c_bits =+ space $$+ extern_decl $$+ fun_proto $$+ vcat+ [ lbrace+ , ptext (sLit "Capability *cap;")+ , declareResult+ , declareCResult+ , text "cap = rts_lock();"+ -- create the application + perform it.+ , ptext (sLit "rts_evalIO") <> parens (+ char '&' <> cap <>+ ptext (sLit "rts_apply") <> parens (+ cap <>+ text "(HaskellObj)"+ <> ptext (if is_IO_res_ty+ then (sLit "runIO_closure")+ else (sLit "runNonIO_closure"))+ <> comma+ <> expr_to_run+ ) <+> comma+ <> text "&ret"+ ) <> semi+ , ptext (sLit "rts_checkSchedStatus") <> parens (doubleQuotes (ftext c_nm)+ <> comma <> text "cap") <> semi+ , assignCResult+ , ptext (sLit "rts_unlock(cap);")+ , ppUnless res_hty_is_unit $+ if libffi+ then char '*' <> parens (ffi_cResType <> char '*') <>+ ptext (sLit "resp = cret;")+ else ptext (sLit "return cret;")+ , rbrace+ ]+++foreignExportInitialiser :: Id -> SDoc+foreignExportInitialiser hs_fn =+ -- Initialise foreign exports by registering a stable pointer from an+ -- __attribute__((constructor)) function.+ -- The alternative is to do this from stginit functions generated in+ -- codeGen/CodeGen.lhs; however, stginit functions have a negative impact+ -- on binary sizes and link times because the static linker will think that+ -- all modules that are imported directly or indirectly are actually used by+ -- the program.+ -- (this is bad for big umbrella modules like Graphics.Rendering.OpenGL)+ vcat+ [ text "static void stginit_export_" <> ppr hs_fn+ <> text "() __attribute__((constructor));"+ , text "static void stginit_export_" <> ppr hs_fn <> text "()"+ , braces (text "foreignExportStablePtr"+ <> parens (text "(StgPtr) &" <> ppr hs_fn <> text "_closure")+ <> semi)+ ]+++mkHObj :: Type -> SDoc+mkHObj t = text "rts_mk" <> text (showFFIType t)++unpackHObj :: Type -> SDoc+unpackHObj t = text "rts_get" <> text (showFFIType t)++showStgType :: Type -> SDoc+showStgType t = text "Hs" <> text (showFFIType t)++showFFIType :: Type -> String+showFFIType t = getOccString (getName (typeTyCon t))++toCType :: Type -> (Maybe Header, SDoc)+toCType = f False+ where f voidOK t+ -- First, if we have (Ptr t) of (FunPtr t), then we need to+ -- convert t to a C type and put a * after it. If we don't+ -- know a type for t, then "void" is fine, though.+ | Just (ptr, [t']) <- splitTyConApp_maybe t+ , tyConName ptr `elem` [ptrTyConName, funPtrTyConName]+ = case f True t' of+ (mh, cType') ->+ (mh, cType' <> char '*')+ -- Otherwise, if we have a type constructor application, then+ -- see if there is a C type associated with that constructor.+ -- Note that we aren't looking through type synonyms or+ -- anything, as it may be the synonym that is annotated.+ | TyConApp tycon _ <- t+ , Just (CType _ mHeader cType) <- tyConCType_maybe tycon+ = (mHeader, ftext cType)+ -- If we don't know a C type for this type, then try looking+ -- through one layer of type synonym etc.+ | Just t' <- coreView t+ = f voidOK t'+ -- Otherwise we don't know the C type. If we are allowing+ -- void then return that; otherwise something has gone wrong.+ | voidOK = (Nothing, ptext (sLit "void"))+ | otherwise+ = pprPanic "toCType" (ppr t)++typeTyCon :: Type -> TyCon+typeTyCon ty+ | UnaryRep rep_ty <- repType ty+ , Just (tc, _) <- tcSplitTyConApp_maybe rep_ty+ = tc+ | otherwise+ = pprPanic "DsForeign.typeTyCon" (ppr ty)++insertRetAddr :: DynFlags -> CCallConv+ -> [(SDoc, SDoc, Type, CmmType)]+ -> [(SDoc, SDoc, Type, CmmType)]+insertRetAddr dflags CCallConv args+ = case platformArch platform of+ ArchX86_64+ | platformOS platform == OSMinGW32 ->+ -- On other Windows x86_64 we insert the return address+ -- after the 4th argument, because this is the point+ -- at which we need to flush a register argument to the stack+ -- (See rts/Adjustor.c for details).+ let go :: Int -> [(SDoc, SDoc, Type, CmmType)]+ -> [(SDoc, SDoc, Type, CmmType)]+ go 4 args = ret_addr_arg dflags : args+ go n (arg:args) = arg : go (n+1) args+ go _ [] = []+ in go 0 args+ | otherwise ->+ -- On other x86_64 platforms we insert the return address+ -- after the 6th integer argument, because this is the point+ -- at which we need to flush a register argument to the stack+ -- (See rts/Adjustor.c for details).+ let go :: Int -> [(SDoc, SDoc, Type, CmmType)]+ -> [(SDoc, SDoc, Type, CmmType)]+ go 6 args = ret_addr_arg dflags : args+ go n (arg@(_,_,_,rep):args)+ | cmmEqType_ignoring_ptrhood rep b64 = arg : go (n+1) args+ | otherwise = arg : go n args+ go _ [] = []+ in go 0 args+ _ ->+ ret_addr_arg dflags : args+ where platform = targetPlatform dflags+insertRetAddr _ _ args = args++ret_addr_arg :: DynFlags -> (SDoc, SDoc, Type, CmmType)+ret_addr_arg dflags = (text "original_return_addr", text "void*", undefined,+ typeCmmType dflags addrPrimTy)++-- This function returns the primitive type associated with the boxed+-- type argument to a foreign export (eg. Int ==> Int#).+getPrimTyOf :: Type -> UnaryType+getPrimTyOf ty+ | isBoolTy rep_ty = intPrimTy+ -- Except for Bool, the types we are interested in have a single constructor+ -- with a single primitive-typed argument (see TcType.legalFEArgTyCon).+ | otherwise =+ case splitDataProductType_maybe rep_ty of+ Just (_, _, _, [prim_ty]) ->+ -- ASSERT(dataConSourceArity data_con == 1)+ -- ASSERT2(isUnLiftedType prim_ty, ppr prim_ty)+ prim_ty+ _other -> pprPanic "DsForeign.getPrimTyOf" (ppr ty)+ where+ UnaryRep rep_ty = repType ty++-- represent a primitive type as a Char, for building a string that+-- described the foreign function type. The types are size-dependent,+-- e.g. 'W' is a signed 32-bit integer.+primTyDescChar :: DynFlags -> Type -> Char+primTyDescChar dflags ty+ | ty `eqType` unitTy = 'v'+ | otherwise+ = case typePrimRep (getPrimTyOf ty) of+ IntRep -> signed_word+ WordRep -> unsigned_word+ Int64Rep -> 'L'+ Word64Rep -> 'l'+ AddrRep -> 'p'+ FloatRep -> 'f'+ DoubleRep -> 'd'+ _ -> pprPanic "primTyDescChar" (ppr ty)+ where+ (signed_word, unsigned_word)+ | wORD_SIZE dflags == 4 = ('W','w')+ | wORD_SIZE dflags == 8 = ('L','l')+ | otherwise = panic "primTyDescChar"
+ src/Language/Haskell/Liquid/Desugar710/DsGRHSs.hs view
@@ -0,0 +1,158 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++Matching guarded right-hand-sides (GRHSs)+-}++{-# LANGUAGE CPP #-}++module Language.Haskell.Liquid.Desugar710.DsGRHSs ( dsGuarded, dsGRHSs, dsGRHS ) where++-- #include "HsVersions.h"++import {-# SOURCE #-} Language.Haskell.Liquid.Desugar710.DsExpr ( dsLExpr, dsLocalBinds )+import {-# SOURCE #-} Language.Haskell.Liquid.Desugar710.Match ( matchSinglePat )++import HsSyn+import MkCore+import CoreSyn+import Var+import Type++import DsMonad+import Language.Haskell.Liquid.Desugar710.DsUtils+import TysWiredIn+import PrelNames+import Module+import Name+import SrcLoc+import Outputable++{-+@dsGuarded@ is used for both @case@ expressions and pattern bindings.+It desugars:+\begin{verbatim}+ | g1 -> e1+ ...+ | gn -> en+ where binds+\end{verbatim}+producing an expression with a runtime error in the corner if+necessary. The type argument gives the type of the @ei@.+-}++dsGuarded :: GRHSs Id (LHsExpr Id) -> Type -> DsM CoreExpr++dsGuarded grhss rhs_ty = do+ match_result <- dsGRHSs PatBindRhs [] grhss rhs_ty+ error_expr <- mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID rhs_ty empty+ extractMatchResult match_result error_expr++-- In contrast, @dsGRHSs@ produces a @MatchResult@.++dsGRHSs :: HsMatchContext Name -> [Pat Id] -- These are to build a MatchContext from+ -> GRHSs Id (LHsExpr Id) -- Guarded RHSs+ -> Type -- Type of RHS+ -> DsM MatchResult+dsGRHSs hs_ctx _ (GRHSs grhss binds) rhs_ty+ = -- ASSERT( notNull grhss )+ do { match_results <- mapM (dsGRHS hs_ctx rhs_ty) grhss+ ; let match_result1 = foldr1 combineMatchResults match_results+ match_result2 = adjustMatchResultDs (dsLocalBinds binds) match_result1+ -- NB: nested dsLet inside matchResult+ ; return match_result2 }++dsGRHS :: HsMatchContext Name -> Type -> LGRHS Id (LHsExpr Id) -> DsM MatchResult+dsGRHS hs_ctx rhs_ty (L _ (GRHS guards rhs))+ = matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs rhs_ty++{-+************************************************************************+* *+* matchGuard : make a MatchResult from a guarded RHS *+* *+************************************************************************+-}++matchGuards :: [GuardStmt Id] -- Guard+ -> HsStmtContext Name -- Context+ -> LHsExpr Id -- RHS+ -> Type -- Type of RHS of guard+ -> DsM MatchResult++-- See comments with HsExpr.Stmt re what a BodyStmt means+-- Here we must be in a guard context (not do-expression, nor list-comp)++matchGuards [] _ rhs _+ = do { core_rhs <- dsLExpr rhs+ ; return (cantFailMatchResult core_rhs) }++ -- BodyStmts must be guards+ -- Turn an "otherwise" guard is a no-op. This ensures that+ -- you don't get a "non-exhaustive eqns" message when the guards+ -- finish in "otherwise".+ -- NB: The success of this clause depends on the typechecker not+ -- wrapping the 'otherwise' in empty HsTyApp or HsWrap constructors+ -- If it does, you'll get bogus overlap warnings+matchGuards (BodyStmt e _ _ _ : stmts) ctx rhs rhs_ty+ | Just addTicks <- isTrueLHsExpr e = do+ match_result <- matchGuards stmts ctx rhs rhs_ty+ return (adjustMatchResultDs addTicks match_result)+matchGuards (BodyStmt expr _ _ _ : stmts) ctx rhs rhs_ty = do+ match_result <- matchGuards stmts ctx rhs rhs_ty+ pred_expr <- dsLExpr expr+ return (mkGuardedMatchResult pred_expr match_result)++matchGuards (LetStmt binds : stmts) ctx rhs rhs_ty = do+ match_result <- matchGuards stmts ctx rhs rhs_ty+ return (adjustMatchResultDs (dsLocalBinds binds) match_result)+ -- NB the dsLet occurs inside the match_result+ -- Reason: dsLet takes the body expression as its argument+ -- so we can't desugar the bindings without the+ -- body expression in hand++matchGuards (BindStmt pat bind_rhs _ _ : stmts) ctx rhs rhs_ty = do+ match_result <- matchGuards stmts ctx rhs rhs_ty+ core_rhs <- dsLExpr bind_rhs+ matchSinglePat core_rhs (StmtCtxt ctx) pat rhs_ty match_result++matchGuards (LastStmt {} : _) _ _ _ = panic "matchGuards LastStmt"+matchGuards (ParStmt {} : _) _ _ _ = panic "matchGuards ParStmt"+matchGuards (TransStmt {} : _) _ _ _ = panic "matchGuards TransStmt"+matchGuards (RecStmt {} : _) _ _ _ = panic "matchGuards RecStmt"++isTrueLHsExpr :: LHsExpr Id -> Maybe (CoreExpr -> DsM CoreExpr)++-- Returns Just {..} if we're sure that the expression is True+-- I.e. * 'True' datacon+-- * 'otherwise' Id+-- * Trivial wappings of these+-- The arguments to Just are any HsTicks that we have found,+-- because we still want to tick then, even it they are aways evaluted.+isTrueLHsExpr (L _ (HsVar v)) | v `hasKey` otherwiseIdKey+ || v `hasKey` getUnique trueDataConId+ = Just return+ -- trueDataConId doesn't have the same unique as trueDataCon+isTrueLHsExpr (L _ (HsTick tickish e))+ | Just ticks <- isTrueLHsExpr e+ = Just (\x -> ticks x >>= return . (Tick tickish))+ -- This encodes that the result is constant True for Hpc tick purposes;+ -- which is specifically what isTrueLHsExpr is trying to find out.+isTrueLHsExpr (L _ (HsBinTick ixT _ e))+ | Just ticks <- isTrueLHsExpr e+ = Just (\x -> do e <- ticks x+ this_mod <- getModule+ return (Tick (HpcTick this_mod ixT) e))++isTrueLHsExpr (L _ (HsPar e)) = isTrueLHsExpr e+isTrueLHsExpr _ = Nothing++{-+Should {\em fail} if @e@ returns @D@+\begin{verbatim}+f x | p <- e', let C y# = e, f y# = r1+ | otherwise = r2+\end{verbatim}+-}
+ src/Language/Haskell/Liquid/Desugar710/DsListComp.hs view
@@ -0,0 +1,871 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++Desugaring list comprehensions, monad comprehensions and array comprehensions+-}++{-# LANGUAGE CPP, NamedFieldPuns #-}++module Language.Haskell.Liquid.Desugar710.DsListComp ( dsListComp, dsPArrComp, dsMonadComp ) where++-- #include "HsVersions.h"++import {-# SOURCE #-} Language.Haskell.Liquid.Desugar710.DsExpr ( dsExpr, dsLExpr, dsLocalBinds )++import HsSyn+import TcHsSyn+import CoreSyn+import MkCore++import DsMonad -- the monadery used in the desugarer+import Language.Haskell.Liquid.Desugar710.DsUtils++import DynFlags+import CoreUtils+import Id+import Type+import TysWiredIn+import Language.Haskell.Liquid.Desugar710.Match+import PrelNames+import SrcLoc+import Outputable+import FastString+import TcType+import ListSetOps( getNth )+-- import Util++{-+List comprehensions may be desugared in one of two ways: ``ordinary''+(as you would expect if you read SLPJ's book) and ``with foldr/build+turned on'' (if you read Gill {\em et al.}'s paper on the subject).++There will be at least one ``qualifier'' in the input.+-}++dsListComp :: [ExprLStmt Id]+ -> Type -- Type of entire list+ -> DsM CoreExpr+dsListComp lquals res_ty = do+ dflags <- getDynFlags+ let quals = map unLoc lquals+ elt_ty = case tcTyConAppArgs res_ty of+ [elt_ty] -> elt_ty+ _ -> pprPanic "dsListComp" (ppr res_ty $$ ppr lquals)++ if not (gopt Opt_EnableRewriteRules dflags) || gopt Opt_IgnoreInterfacePragmas dflags+ -- Either rules are switched off, or we are ignoring what there are;+ -- Either way foldr/build won't happen, so use the more efficient+ -- Wadler-style desugaring+ || isParallelComp quals+ -- Foldr-style desugaring can't handle parallel list comprehensions+ then deListComp quals (mkNilExpr elt_ty)+ else mkBuildExpr elt_ty (\(c, _) (n, _) -> dfListComp c n quals)+ -- Foldr/build should be enabled, so desugar+ -- into foldrs and builds++ where+ -- We must test for ParStmt anywhere, not just at the head, because an extension+ -- to list comprehensions would be to add brackets to specify the associativity+ -- of qualifier lists. This is really easy to do by adding extra ParStmts into the+ -- mix of possibly a single element in length, so we do this to leave the possibility open+ isParallelComp = any isParallelStmt++ isParallelStmt (ParStmt {}) = True+ isParallelStmt _ = False+++-- This function lets you desugar a inner list comprehension and a list of the binders+-- of that comprehension that we need in the outer comprehension into such an expression+-- and the type of the elements that it outputs (tuples of binders)+dsInnerListComp :: (ParStmtBlock Id Id) -> DsM (CoreExpr, Type)+dsInnerListComp (ParStmtBlock stmts bndrs _)+ = do { expr <- dsListComp (stmts ++ [noLoc $ mkLastStmt (mkBigLHsVarTup bndrs)])+ (mkListTy bndrs_tuple_type)+ ; return (expr, bndrs_tuple_type) }+ where+ bndrs_tuple_type = mkBigCoreVarTupTy bndrs++-- This function factors out commonality between the desugaring strategies for GroupStmt.+-- Given such a statement it gives you back an expression representing how to compute the transformed+-- list and the tuple that you need to bind from that list in order to proceed with your desugaring+dsTransStmt :: ExprStmt Id -> DsM (CoreExpr, LPat Id)+dsTransStmt (TransStmt { trS_form = form, trS_stmts = stmts, trS_bndrs = binderMap+ , trS_by = by, trS_using = using }) = do+ let (from_bndrs, to_bndrs) = unzip binderMap+ from_bndrs_tys = map idType from_bndrs+ to_bndrs_tys = map idType to_bndrs+ to_bndrs_tup_ty = mkBigCoreTupTy to_bndrs_tys++ -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders+ (expr, from_tup_ty) <- dsInnerListComp (ParStmtBlock stmts from_bndrs noSyntaxExpr)++ -- Work out what arguments should be supplied to that expression: i.e. is an extraction+ -- function required? If so, create that desugared function and add to arguments+ usingExpr' <- dsLExpr using+ usingArgs <- case by of+ Nothing -> return [expr]+ Just by_e -> do { by_e' <- dsLExpr by_e+ ; lam <- matchTuple from_bndrs by_e'+ ; return [lam, expr] }++ -- Create an unzip function for the appropriate arity and element types and find "map"+ unzip_stuff <- mkUnzipBind form from_bndrs_tys+ map_id <- dsLookupGlobalId mapName++ -- Generate the expressions to build the grouped list+ let -- First we apply the grouping function to the inner list+ inner_list_expr = mkApps usingExpr' usingArgs+ -- Then we map our "unzip" across it to turn the lists of tuples into tuples of lists+ -- We make sure we instantiate the type variable "a" to be a list of "from" tuples and+ -- the "b" to be a tuple of "to" lists!+ -- Then finally we bind the unzip function around that expression+ bound_unzipped_inner_list_expr+ = case unzip_stuff of+ Nothing -> inner_list_expr+ Just (unzip_fn, unzip_rhs) -> Let (Rec [(unzip_fn, unzip_rhs)]) $+ mkApps (Var map_id) $+ [ Type (mkListTy from_tup_ty)+ , Type to_bndrs_tup_ty+ , Var unzip_fn+ , inner_list_expr]++ -- Build a pattern that ensures the consumer binds into the NEW binders,+ -- which hold lists rather than single values+ let pat = mkBigLHsVarPatTup to_bndrs+ return (bound_unzipped_inner_list_expr, pat)++dsTransStmt _ = panic "dsTransStmt: Not given a TransStmt"++{-+************************************************************************+* *+\subsection[DsListComp-ordinary]{Ordinary desugaring of list comprehensions}+* *+************************************************************************++Just as in Phil's chapter~7 in SLPJ, using the rules for+optimally-compiled list comprehensions. This is what Kevin followed+as well, and I quite happily do the same. The TQ translation scheme+transforms a list of qualifiers (either boolean expressions or+generators) into a single expression which implements the list+comprehension. Because we are generating 2nd-order polymorphic+lambda-calculus, calls to NIL and CONS must be applied to a type+argument, as well as their usual value arguments.+\begin{verbatim}+TE << [ e | qs ] >> = TQ << [ e | qs ] ++ Nil (typeOf e) >>++(Rule C)+TQ << [ e | ] ++ L >> = Cons (typeOf e) TE <<e>> TE <<L>>++(Rule B)+TQ << [ e | b , qs ] ++ L >> =+ if TE << b >> then TQ << [ e | qs ] ++ L >> else TE << L >>++(Rule A')+TQ << [ e | p <- L1, qs ] ++ L2 >> =+ letrec+ h = \ u1 ->+ case u1 of+ [] -> TE << L2 >>+ (u2 : u3) ->+ (( \ TE << p >> -> ( TQ << [e | qs] ++ (h u3) >> )) u2)+ [] (h u3)+ in+ h ( TE << L1 >> )++"h", "u1", "u2", and "u3" are new variables.+\end{verbatim}++@deListComp@ is the TQ translation scheme. Roughly speaking, @dsExpr@+is the TE translation scheme. Note that we carry around the @L@ list+already desugared. @dsListComp@ does the top TE rule mentioned above.++To the above, we add an additional rule to deal with parallel list+comprehensions. The translation goes roughly as follows:+ [ e | p1 <- e11, let v1 = e12, p2 <- e13+ | q1 <- e21, let v2 = e22, q2 <- e23]+ =>+ [ e | ((x1, .., xn), (y1, ..., ym)) <-+ zip [(x1,..,xn) | p1 <- e11, let v1 = e12, p2 <- e13]+ [(y1,..,ym) | q1 <- e21, let v2 = e22, q2 <- e23]]+where (x1, .., xn) are the variables bound in p1, v1, p2+ (y1, .., ym) are the variables bound in q1, v2, q2++In the translation below, the ParStmt branch translates each parallel branch+into a sub-comprehension, and desugars each independently. The resulting lists+are fed to a zip function, we create a binding for all the variables bound in all+the comprehensions, and then we hand things off the the desugarer for bindings.+The zip function is generated here a) because it's small, and b) because then we+don't have to deal with arbitrary limits on the number of zip functions in the+prelude, nor which library the zip function came from.+The introduced tuples are Boxed, but only because I couldn't get it to work+with the Unboxed variety.+-}++deListComp :: [ExprStmt Id] -> CoreExpr -> DsM CoreExpr++deListComp [] _ = panic "deListComp"++deListComp (LastStmt body _ : _) list+ = -- Figure 7.4, SLPJ, p 135, rule C above+ -- ASSERT( null quals )+ do { core_body <- dsLExpr body+ ; return (mkConsExpr (exprType core_body) core_body list) }++ -- Non-last: must be a guard+deListComp (BodyStmt guard _ _ _ : quals) list = do -- rule B above+ core_guard <- dsLExpr guard+ core_rest <- deListComp quals list+ return (mkIfThenElse core_guard core_rest list)++-- [e | let B, qs] = let B in [e | qs]+deListComp (LetStmt binds : quals) list = do+ core_rest <- deListComp quals list+ dsLocalBinds binds core_rest++deListComp (stmt@(TransStmt {}) : quals) list = do+ (inner_list_expr, pat) <- dsTransStmt stmt+ deBindComp pat inner_list_expr quals list++deListComp (BindStmt pat list1 _ _ : quals) core_list2 = do -- rule A' above+ core_list1 <- dsLExpr list1+ deBindComp pat core_list1 quals core_list2++deListComp (ParStmt stmtss_w_bndrs _ _ : quals) list+ = do { exps_and_qual_tys <- mapM dsInnerListComp stmtss_w_bndrs+ ; let (exps, qual_tys) = unzip exps_and_qual_tys++ ; (zip_fn, zip_rhs) <- mkZipBind qual_tys++ -- Deal with [e | pat <- zip l1 .. ln] in example above+ ; deBindComp pat (Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) exps))+ quals list }+ where+ bndrs_s = [bs | ParStmtBlock _ bs _ <- stmtss_w_bndrs]++ -- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above+ pat = mkBigLHsPatTup pats+ pats = map mkBigLHsVarPatTup bndrs_s++deListComp (RecStmt {} : _) _ = panic "deListComp RecStmt"++deBindComp :: OutPat Id+ -> CoreExpr+ -> [ExprStmt Id]+ -> CoreExpr+ -> DsM (Expr Id)+deBindComp pat core_list1 quals core_list2 = do+ let+ u3_ty@u1_ty = exprType core_list1 -- two names, same thing++ -- u1_ty is a [alpha] type, and u2_ty = alpha+ u2_ty = hsLPatType pat++ res_ty = exprType core_list2+ h_ty = u1_ty `mkFunTy` res_ty++ [h, u1, u2, u3] <- newSysLocalsDs [h_ty, u1_ty, u2_ty, u3_ty]++ -- the "fail" value ...+ let+ core_fail = App (Var h) (Var u3)+ letrec_body = App (Var h) core_list1++ rest_expr <- deListComp quals core_fail+ core_match <- matchSimply (Var u2) (StmtCtxt ListComp) pat rest_expr core_fail++ let+ rhs = Lam u1 $+ Case (Var u1) u1 res_ty+ [(DataAlt nilDataCon, [], core_list2),+ (DataAlt consDataCon, [u2, u3], core_match)]+ -- Increasing order of tag++ return (Let (Rec [(h, rhs)]) letrec_body)++{-+************************************************************************+* *+\subsection[DsListComp-foldr-build]{Foldr/Build desugaring of list comprehensions}+* *+************************************************************************++@dfListComp@ are the rules used with foldr/build turned on:++\begin{verbatim}+TE[ e | ] c n = c e n+TE[ e | b , q ] c n = if b then TE[ e | q ] c n else n+TE[ e | p <- l , q ] c n = let+ f = \ x b -> case x of+ p -> TE[ e | q ] c b+ _ -> b+ in+ foldr f n l+\end{verbatim}+-}++dfListComp :: Id -> Id -- 'c' and 'n'+ -> [ExprStmt Id] -- the rest of the qual's+ -> DsM CoreExpr++dfListComp _ _ [] = panic "dfListComp"++dfListComp c_id n_id (LastStmt body _ : _)+ = -- ASSERT( null quals )+ do { core_body <- dsLExpr body+ ; return (mkApps (Var c_id) [core_body, Var n_id]) }++ -- Non-last: must be a guard+dfListComp c_id n_id (BodyStmt guard _ _ _ : quals) = do+ core_guard <- dsLExpr guard+ core_rest <- dfListComp c_id n_id quals+ return (mkIfThenElse core_guard core_rest (Var n_id))++dfListComp c_id n_id (LetStmt binds : quals) = do+ -- new in 1.3, local bindings+ core_rest <- dfListComp c_id n_id quals+ dsLocalBinds binds core_rest++dfListComp c_id n_id (stmt@(TransStmt {}) : quals) = do+ (inner_list_expr, pat) <- dsTransStmt stmt+ -- Anyway, we bind the newly grouped list via the generic binding function+ dfBindComp c_id n_id (pat, inner_list_expr) quals++dfListComp c_id n_id (BindStmt pat list1 _ _ : quals) = do+ -- evaluate the two lists+ core_list1 <- dsLExpr list1++ -- Do the rest of the work in the generic binding builder+ dfBindComp c_id n_id (pat, core_list1) quals++dfListComp _ _ (ParStmt {} : _) = panic "dfListComp ParStmt"+dfListComp _ _ (RecStmt {} : _) = panic "dfListComp RecStmt"++dfBindComp :: Id -> Id -- 'c' and 'n'+ -> (LPat Id, CoreExpr)+ -> [ExprStmt Id] -- the rest of the qual's+ -> DsM CoreExpr+dfBindComp c_id n_id (pat, core_list1) quals = do+ -- find the required type+ let x_ty = hsLPatType pat+ b_ty = idType n_id++ -- create some new local id's+ [b, x] <- newSysLocalsDs [b_ty, x_ty]++ -- build rest of the comprehesion+ core_rest <- dfListComp c_id b quals++ -- build the pattern match+ core_expr <- matchSimply (Var x) (StmtCtxt ListComp)+ pat core_rest (Var b)++ -- now build the outermost foldr, and return+ mkFoldrExpr x_ty b_ty (mkLams [x, b] core_expr) (Var n_id) core_list1++{-+************************************************************************+* *+\subsection[DsFunGeneration]{Generation of zip/unzip functions for use in desugaring}+* *+************************************************************************+-}++mkZipBind :: [Type] -> DsM (Id, CoreExpr)+-- mkZipBind [t1, t2]+-- = (zip, \as1:[t1] as2:[t2]+-- -> case as1 of+-- [] -> []+-- (a1:as'1) -> case as2 of+-- [] -> []+-- (a2:as'2) -> (a1, a2) : zip as'1 as'2)]++mkZipBind elt_tys = do+ ass <- mapM newSysLocalDs elt_list_tys+ as' <- mapM newSysLocalDs elt_tys+ as's <- mapM newSysLocalDs elt_list_tys++ zip_fn <- newSysLocalDs zip_fn_ty++ let inner_rhs = mkConsExpr elt_tuple_ty+ (mkBigCoreVarTup as')+ (mkVarApps (Var zip_fn) as's)+ zip_body = foldr mk_case inner_rhs (zip3 ass as' as's)++ return (zip_fn, mkLams ass zip_body)+ where+ elt_list_tys = map mkListTy elt_tys+ elt_tuple_ty = mkBigCoreTupTy elt_tys+ elt_tuple_list_ty = mkListTy elt_tuple_ty++ zip_fn_ty = mkFunTys elt_list_tys elt_tuple_list_ty++ mk_case (as, a', as') rest+ = Case (Var as) as elt_tuple_list_ty+ [(DataAlt nilDataCon, [], mkNilExpr elt_tuple_ty),+ (DataAlt consDataCon, [a', as'], rest)]+ -- Increasing order of tag+++mkUnzipBind :: TransForm -> [Type] -> DsM (Maybe (Id, CoreExpr))+-- mkUnzipBind [t1, t2]+-- = (unzip, \ys :: [(t1, t2)] -> foldr (\ax :: (t1, t2) axs :: ([t1], [t2])+-- -> case ax of+-- (x1, x2) -> case axs of+-- (xs1, xs2) -> (x1 : xs1, x2 : xs2))+-- ([], [])+-- ys)+--+-- We use foldr here in all cases, even if rules are turned off, because we may as well!+mkUnzipBind ThenForm _+ = return Nothing -- No unzipping for ThenForm+mkUnzipBind _ elt_tys+ = do { ax <- newSysLocalDs elt_tuple_ty+ ; axs <- newSysLocalDs elt_list_tuple_ty+ ; ys <- newSysLocalDs elt_tuple_list_ty+ ; xs <- mapM newSysLocalDs elt_tys+ ; xss <- mapM newSysLocalDs elt_list_tys++ ; unzip_fn <- newSysLocalDs unzip_fn_ty++ ; [us1, us2] <- sequence [newUniqueSupply, newUniqueSupply]++ ; let nil_tuple = mkBigCoreTup (map mkNilExpr elt_tys)+ concat_expressions = map mkConcatExpression (zip3 elt_tys (map Var xs) (map Var xss))+ tupled_concat_expression = mkBigCoreTup concat_expressions++ folder_body_inner_case = mkTupleCase us1 xss tupled_concat_expression axs (Var axs)+ folder_body_outer_case = mkTupleCase us2 xs folder_body_inner_case ax (Var ax)+ folder_body = mkLams [ax, axs] folder_body_outer_case++ ; unzip_body <- mkFoldrExpr elt_tuple_ty elt_list_tuple_ty folder_body nil_tuple (Var ys)+ ; return (Just (unzip_fn, mkLams [ys] unzip_body)) }+ where+ elt_tuple_ty = mkBigCoreTupTy elt_tys+ elt_tuple_list_ty = mkListTy elt_tuple_ty+ elt_list_tys = map mkListTy elt_tys+ elt_list_tuple_ty = mkBigCoreTupTy elt_list_tys++ unzip_fn_ty = elt_tuple_list_ty `mkFunTy` elt_list_tuple_ty++ mkConcatExpression (list_element_ty, head, tail) = mkConsExpr list_element_ty head tail++{-+************************************************************************+* *+\subsection[DsPArrComp]{Desugaring of array comprehensions}+* *+************************************************************************+-}++-- entry point for desugaring a parallel array comprehension+--+-- [:e | qss:] = <<[:e | qss:]>> () [:():]+--+dsPArrComp :: [ExprStmt Id]+ -> DsM CoreExpr++-- Special case for parallel comprehension+dsPArrComp (ParStmt qss _ _ : quals) = dePArrParComp qss quals++-- Special case for simple generators:+--+-- <<[:e' | p <- e, qs:]>> = <<[: e' | qs :]>> p e+--+-- if matching again p cannot fail, or else+--+-- <<[:e' | p <- e, qs:]>> =+-- <<[:e' | qs:]>> p (filterP (\x -> case x of {p -> True; _ -> False}) e)+--+dsPArrComp (BindStmt p e _ _ : qs) = do+ filterP <- dsDPHBuiltin filterPVar+ ce <- dsLExpr e+ let ety'ce = parrElemType ce+ false = Var falseDataConId+ true = Var trueDataConId+ v <- newSysLocalDs ety'ce+ pred <- matchSimply (Var v) (StmtCtxt PArrComp) p true false+ let gen | isIrrefutableHsPat p = ce+ | otherwise = mkApps (Var filterP) [Type ety'ce, mkLams [v] pred, ce]+ dePArrComp qs p gen++dsPArrComp qs = do -- no ParStmt in `qs'+ sglP <- dsDPHBuiltin singletonPVar+ let unitArray = mkApps (Var sglP) [Type unitTy, mkCoreTup []]+ dePArrComp qs (noLoc $ WildPat unitTy) unitArray++++-- the work horse+--+dePArrComp :: [ExprStmt Id]+ -> LPat Id -- the current generator pattern+ -> CoreExpr -- the current generator expression+ -> DsM CoreExpr++dePArrComp [] _ _ = panic "dePArrComp"++--+-- <<[:e' | :]>> pa ea = mapP (\pa -> e') ea+--+dePArrComp (LastStmt e' _ : _) pa cea+ = -- ASSERT( null quals )+ do { mapP <- dsDPHBuiltin mapPVar+ ; let ty = parrElemType cea+ ; (clam, ty'e') <- deLambda ty pa e'+ ; return $ mkApps (Var mapP) [Type ty, Type ty'e', clam, cea] }+--+-- <<[:e' | b, qs:]>> pa ea = <<[:e' | qs:]>> pa (filterP (\pa -> b) ea)+--+dePArrComp (BodyStmt b _ _ _ : qs) pa cea = do+ filterP <- dsDPHBuiltin filterPVar+ let ty = parrElemType cea+ (clam,_) <- deLambda ty pa b+ dePArrComp qs pa (mkApps (Var filterP) [Type ty, clam, cea])++--+-- <<[:e' | p <- e, qs:]>> pa ea =+-- let ef = \pa -> e+-- in+-- <<[:e' | qs:]>> (pa, p) (crossMap ea ef)+--+-- if matching again p cannot fail, or else+--+-- <<[:e' | p <- e, qs:]>> pa ea =+-- let ef = \pa -> filterP (\x -> case x of {p -> True; _ -> False}) e+-- in+-- <<[:e' | qs:]>> (pa, p) (crossMapP ea ef)+--+dePArrComp (BindStmt p e _ _ : qs) pa cea = do+ filterP <- dsDPHBuiltin filterPVar+ crossMapP <- dsDPHBuiltin crossMapPVar+ ce <- dsLExpr e+ let ety'cea = parrElemType cea+ ety'ce = parrElemType ce+ false = Var falseDataConId+ true = Var trueDataConId+ v <- newSysLocalDs ety'ce+ pred <- matchSimply (Var v) (StmtCtxt PArrComp) p true false+ let cef | isIrrefutableHsPat p = ce+ | otherwise = mkApps (Var filterP) [Type ety'ce, mkLams [v] pred, ce]+ (clam, _) <- mkLambda ety'cea pa cef+ let ety'cef = ety'ce -- filter doesn't change the element type+ pa' = mkLHsPatTup [pa, p]++ dePArrComp qs pa' (mkApps (Var crossMapP)+ [Type ety'cea, Type ety'cef, cea, clam])+--+-- <<[:e' | let ds, qs:]>> pa ea =+-- <<[:e' | qs:]>> (pa, (x_1, ..., x_n))+-- (mapP (\v@pa -> let ds in (v, (x_1, ..., x_n))) ea)+-- where+-- {x_1, ..., x_n} = DV (ds) -- Defined Variables+--+dePArrComp (LetStmt ds : qs) pa cea = do+ mapP <- dsDPHBuiltin mapPVar+ let xs = collectLocalBinders ds+ ty'cea = parrElemType cea+ v <- newSysLocalDs ty'cea+ clet <- dsLocalBinds ds (mkCoreTup (map Var xs))+ let'v <- newSysLocalDs (exprType clet)+ let projBody = mkCoreLet (NonRec let'v clet) $+ mkCoreTup [Var v, Var let'v]+ errTy = exprType projBody+ errMsg = ptext (sLit "DsListComp.dePArrComp: internal error!")+ cerr <- mkErrorAppDs pAT_ERROR_ID errTy errMsg+ ccase <- matchSimply (Var v) (StmtCtxt PArrComp) pa projBody cerr+ let pa' = mkLHsPatTup [pa, mkLHsPatTup (map nlVarPat xs)]+ proj = mkLams [v] ccase+ dePArrComp qs pa' (mkApps (Var mapP)+ [Type ty'cea, Type errTy, proj, cea])+--+-- The parser guarantees that parallel comprehensions can only appear as+-- singleton qualifier lists, which we already special case in the caller.+-- So, encountering one here is a bug.+--+dePArrComp (ParStmt {} : _) _ _ =+ panic "DsListComp.dePArrComp: malformed comprehension AST: ParStmt"+dePArrComp (TransStmt {} : _) _ _ = panic "DsListComp.dePArrComp: TransStmt"+dePArrComp (RecStmt {} : _) _ _ = panic "DsListComp.dePArrComp: RecStmt"++-- <<[:e' | qs | qss:]>> pa ea =+-- <<[:e' | qss:]>> (pa, (x_1, ..., x_n))+-- (zipP ea <<[:(x_1, ..., x_n) | qs:]>>)+-- where+-- {x_1, ..., x_n} = DV (qs)+--+dePArrParComp :: [ParStmtBlock Id Id] -> [ExprStmt Id] -> DsM CoreExpr+dePArrParComp qss quals = do+ (pQss, ceQss) <- deParStmt qss+ dePArrComp quals pQss ceQss+ where+ deParStmt [] =+ -- empty parallel statement lists have no source representation+ panic "DsListComp.dePArrComp: Empty parallel list comprehension"+ deParStmt (ParStmtBlock qs xs _:qss) = do -- first statement+ let res_expr = mkLHsVarTuple xs+ cqs <- dsPArrComp (map unLoc qs ++ [mkLastStmt res_expr])+ parStmts qss (mkLHsVarPatTup xs) cqs+ ---+ parStmts [] pa cea = return (pa, cea)+ parStmts (ParStmtBlock qs xs _:qss) pa cea = do -- subsequent statements (zip'ed)+ zipP <- dsDPHBuiltin zipPVar+ let pa' = mkLHsPatTup [pa, mkLHsVarPatTup xs]+ ty'cea = parrElemType cea+ res_expr = mkLHsVarTuple xs+ cqs <- dsPArrComp (map unLoc qs ++ [mkLastStmt res_expr])+ let ty'cqs = parrElemType cqs+ cea' = mkApps (Var zipP) [Type ty'cea, Type ty'cqs, cea, cqs]+ parStmts qss pa' cea'++-- generate Core corresponding to `\p -> e'+--+deLambda :: Type -- type of the argument+ -> LPat Id -- argument pattern+ -> LHsExpr Id -- body+ -> DsM (CoreExpr, Type)+deLambda ty p e =+ mkLambda ty p =<< dsLExpr e++-- generate Core for a lambda pattern match, where the body is already in Core+--+mkLambda :: Type -- type of the argument+ -> LPat Id -- argument pattern+ -> CoreExpr -- desugared body+ -> DsM (CoreExpr, Type)+mkLambda ty p ce = do+ v <- newSysLocalDs ty+ let errMsg = ptext (sLit "DsListComp.deLambda: internal error!")+ ce'ty = exprType ce+ cerr <- mkErrorAppDs pAT_ERROR_ID ce'ty errMsg+ res <- matchSimply (Var v) (StmtCtxt PArrComp) p ce cerr+ return (mkLams [v] res, ce'ty)++-- obtain the element type of the parallel array produced by the given Core+-- expression+--+parrElemType :: CoreExpr -> Type+parrElemType e =+ case splitTyConApp_maybe (exprType e) of+ Just (tycon, [ty]) | tycon == parrTyCon -> ty+ _ -> panic+ "DsListComp.parrElemType: not a parallel array type"++-- Translation for monad comprehensions++-- Entry point for monad comprehension desugaring+dsMonadComp :: [ExprLStmt Id] -> DsM CoreExpr+dsMonadComp stmts = dsMcStmts stmts++dsMcStmts :: [ExprLStmt Id] -> DsM CoreExpr+dsMcStmts [] = panic "dsMcStmts"+dsMcStmts (L loc stmt : lstmts) = putSrcSpanDs loc (dsMcStmt stmt lstmts)++---------------+dsMcStmt :: ExprStmt Id -> [ExprLStmt Id] -> DsM CoreExpr++dsMcStmt (LastStmt body ret_op) _+ = -- ASSERT( null stmts )+ do { body' <- dsLExpr body+ ; ret_op' <- dsExpr ret_op+ ; return (App ret_op' body') }++-- [ .. | let binds, stmts ]+dsMcStmt (LetStmt binds) stmts+ = do { rest <- dsMcStmts stmts+ ; dsLocalBinds binds rest }++-- [ .. | a <- m, stmts ]+dsMcStmt (BindStmt pat rhs bind_op fail_op) stmts+ = do { rhs' <- dsLExpr rhs+ ; dsMcBindStmt pat rhs' bind_op fail_op stmts }++-- Apply `guard` to the `exp` expression+--+-- [ .. | exp, stmts ]+--+dsMcStmt (BodyStmt exp then_exp guard_exp _) stmts+ = do { exp' <- dsLExpr exp+ ; guard_exp' <- dsExpr guard_exp+ ; then_exp' <- dsExpr then_exp+ ; rest <- dsMcStmts stmts+ ; return $ mkApps then_exp' [ mkApps guard_exp' [exp']+ , rest ] }++-- Group statements desugar like this:+--+-- [| (q, then group by e using f); rest |]+-- ---> f {qt} (\qv -> e) [| q; return qv |] >>= \ n_tup ->+-- case unzip n_tup of qv' -> [| rest |]+--+-- where variables (v1:t1, ..., vk:tk) are bound by q+-- qv = (v1, ..., vk)+-- qt = (t1, ..., tk)+-- (>>=) :: m2 a -> (a -> m3 b) -> m3 b+-- f :: forall a. (a -> t) -> m1 a -> m2 (n a)+-- n_tup :: n qt+-- unzip :: n qt -> (n t1, ..., n tk) (needs Functor n)++dsMcStmt (TransStmt { trS_stmts = stmts, trS_bndrs = bndrs+ , trS_by = by, trS_using = using+ , trS_ret = return_op, trS_bind = bind_op+ , trS_fmap = fmap_op, trS_form = form }) stmts_rest+ = do { let (from_bndrs, to_bndrs) = unzip bndrs+ from_bndr_tys = map idType from_bndrs -- Types ty++ -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders+ ; expr <- dsInnerMonadComp stmts from_bndrs return_op++ -- Work out what arguments should be supplied to that expression: i.e. is an extraction+ -- function required? If so, create that desugared function and add to arguments+ ; usingExpr' <- dsLExpr using+ ; usingArgs <- case by of+ Nothing -> return [expr]+ Just by_e -> do { by_e' <- dsLExpr by_e+ ; lam <- matchTuple from_bndrs by_e'+ ; return [lam, expr] }++ -- Generate the expressions to build the grouped list+ -- Build a pattern that ensures the consumer binds into the NEW binders,+ -- which hold monads rather than single values+ ; bind_op' <- dsExpr bind_op+ ; let bind_ty = exprType bind_op' -- m2 (n (a,b,c)) -> (n (a,b,c) -> r1) -> r2+ n_tup_ty = funArgTy $ funArgTy $ funResultTy bind_ty -- n (a,b,c)+ tup_n_ty = mkBigCoreVarTupTy to_bndrs++ ; body <- dsMcStmts stmts_rest+ ; n_tup_var <- newSysLocalDs n_tup_ty+ ; tup_n_var <- newSysLocalDs tup_n_ty+ ; tup_n_expr <- mkMcUnzipM form fmap_op n_tup_var from_bndr_tys+ ; us <- newUniqueSupply+ ; let rhs' = mkApps usingExpr' usingArgs+ body' = mkTupleCase us to_bndrs body tup_n_var tup_n_expr++ ; return (mkApps bind_op' [rhs', Lam n_tup_var body']) }++-- Parallel statements. Use `Control.Monad.Zip.mzip` to zip parallel+-- statements, for example:+--+-- [ body | qs1 | qs2 | qs3 ]+-- -> [ body | (bndrs1, (bndrs2, bndrs3))+-- <- [bndrs1 | qs1] `mzip` ([bndrs2 | qs2] `mzip` [bndrs3 | qs3]) ]+--+-- where `mzip` has type+-- mzip :: forall a b. m a -> m b -> m (a,b)+-- NB: we need a polymorphic mzip because we call it several times++dsMcStmt (ParStmt blocks mzip_op bind_op) stmts_rest+ = do { exps_w_tys <- mapM ds_inner blocks -- Pairs (exp :: m ty, ty)+ ; mzip_op' <- dsExpr mzip_op++ ; let -- The pattern variables+ pats = [ mkBigLHsVarPatTup bs | ParStmtBlock _ bs _ <- blocks]+ -- Pattern with tuples of variables+ -- [v1,v2,v3] => (v1, (v2, v3))+ pat = foldr1 (\p1 p2 -> mkLHsPatTup [p1, p2]) pats+ (rhs, _) = foldr1 (\(e1,t1) (e2,t2) ->+ (mkApps mzip_op' [Type t1, Type t2, e1, e2],+ mkBoxedTupleTy [t1,t2]))+ exps_w_tys++ ; dsMcBindStmt pat rhs bind_op noSyntaxExpr stmts_rest }+ where+ ds_inner (ParStmtBlock stmts bndrs return_op)+ = do { exp <- dsInnerMonadComp stmts bndrs return_op+ ; return (exp, mkBigCoreVarTupTy bndrs) }++dsMcStmt stmt _ = pprPanic "dsMcStmt: unexpected stmt" (ppr stmt)+++matchTuple :: [Id] -> CoreExpr -> DsM CoreExpr+-- (matchTuple [a,b,c] body)+-- returns the Core term+-- \x. case x of (a,b,c) -> body+matchTuple ids body+ = do { us <- newUniqueSupply+ ; tup_id <- newSysLocalDs (mkBigCoreVarTupTy ids)+ ; return (Lam tup_id $ mkTupleCase us ids body tup_id (Var tup_id)) }++-- general `rhs' >>= \pat -> stmts` desugaring where `rhs'` is already a+-- desugared `CoreExpr`+dsMcBindStmt :: LPat Id+ -> CoreExpr -- ^ the desugared rhs of the bind statement+ -> SyntaxExpr Id+ -> SyntaxExpr Id+ -> [ExprLStmt Id]+ -> DsM CoreExpr+dsMcBindStmt pat rhs' bind_op fail_op stmts+ = do { body <- dsMcStmts stmts+ ; bind_op' <- dsExpr bind_op+ ; var <- selectSimpleMatchVarL pat+ ; let bind_ty = exprType bind_op' -- rhs -> (pat -> res1) -> res2+ res1_ty = funResultTy (funArgTy (funResultTy bind_ty))+ ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat+ res1_ty (cantFailMatchResult body)+ ; match_code <- handle_failure pat match fail_op+ ; return (mkApps bind_op' [rhs', Lam var match_code]) }++ where+ -- In a monad comprehension expression, pattern-match failure just calls+ -- the monadic `fail` rather than throwing an exception+ handle_failure pat match fail_op+ | matchCanFail match+ = do { fail_op' <- dsExpr fail_op+ ; dflags <- getDynFlags+ ; fail_msg <- mkStringExpr (mk_fail_msg dflags pat)+ ; extractMatchResult match (App fail_op' fail_msg) }+ | otherwise+ = extractMatchResult match (error "It can't fail")++ mk_fail_msg :: DynFlags -> Located e -> String+ mk_fail_msg dflags pat+ = "Pattern match failure in monad comprehension at " +++ showPpr dflags (getLoc pat)++-- Desugar nested monad comprehensions, for example in `then..` constructs+-- dsInnerMonadComp quals [a,b,c] ret_op+-- returns the desugaring of+-- [ (a,b,c) | quals ]++dsInnerMonadComp :: [ExprLStmt Id]+ -> [Id] -- Return a tuple of these variables+ -> HsExpr Id -- The monomorphic "return" operator+ -> DsM CoreExpr+dsInnerMonadComp stmts bndrs ret_op+ = dsMcStmts (stmts ++ [noLoc (LastStmt (mkBigLHsVarTup bndrs) ret_op)])++-- The `unzip` function for `GroupStmt` in a monad comprehensions+--+-- unzip :: m (a,b,..) -> (m a,m b,..)+-- unzip m_tuple = ( liftM selN1 m_tuple+-- , liftM selN2 m_tuple+-- , .. )+--+-- mkMcUnzipM fmap ys [t1, t2]+-- = ( fmap (selN1 :: (t1, t2) -> t1) ys+-- , fmap (selN2 :: (t1, t2) -> t2) ys )++mkMcUnzipM :: TransForm+ -> SyntaxExpr TcId -- fmap+ -> Id -- Of type n (a,b,c)+ -> [Type] -- [a,b,c]+ -> DsM CoreExpr -- Of type (n a, n b, n c)+mkMcUnzipM ThenForm _ ys _+ = return (Var ys) -- No unzipping to do++mkMcUnzipM _ fmap_op ys elt_tys+ = do { fmap_op' <- dsExpr fmap_op+ ; xs <- mapM newSysLocalDs elt_tys+ ; let tup_ty = mkBigCoreTupTy elt_tys+ ; tup_xs <- newSysLocalDs tup_ty++ ; let mk_elt i = mkApps fmap_op' -- fmap :: forall a b. (a -> b) -> n a -> n b+ [ Type tup_ty, Type (getNth elt_tys i)+ , mk_sel i, Var ys]++ mk_sel n = Lam tup_xs $+ mkTupleSelector xs (getNth xs n) tup_xs (Var tup_xs)++ ; return (mkBigCoreTup (map mk_elt [0..length elt_tys - 1])) }
+ src/Language/Haskell/Liquid/Desugar710/DsMeta.hs view
@@ -0,0 +1,2917 @@+{-# LANGUAGE CPP #-}++-----------------------------------------------------------------------------+--+-- (c) The University of Glasgow 2006+--+-- The purpose of this module is to transform an HsExpr into a CoreExpr which+-- when evaluated, returns a (Meta.Q Meta.Exp) computation analogous to the+-- input HsExpr. We do this in the DsM monad, which supplies access to+-- CoreExpr's of the "smart constructors" of the Meta.Exp datatype.+--+-- It also defines a bunch of knownKeyNames, in the same way as is done+-- in prelude/PrelNames. It's much more convenient to do it here, because+-- otherwise we have to recompile PrelNames whenever we add a Name, which is+-- a Royal Pain (triggers other recompilation).+-----------------------------------------------------------------------------++module Language.Haskell.Liquid.Desugar710.DsMeta( dsBracket,+ templateHaskellNames, qTyConName, nameTyConName,+ liftName, liftStringName, expQTyConName, patQTyConName,+ decQTyConName, decsQTyConName, typeQTyConName,+ decTyConName, typeTyConName, mkNameG_dName, mkNameG_vName, mkNameG_tcName,+ quoteExpName, quotePatName, quoteDecName, quoteTypeName,+ tExpTyConName, tExpDataConName, unTypeName, unTypeQName,+ unsafeTExpCoerceName+ ) where++-- #include "HsVersions.h"++import Language.Haskell.Liquid.Desugar710.DsExpr ( dsExpr )++import Language.Haskell.Liquid.Desugar710.MatchLit+import DsMonad++import qualified Language.Haskell.TH as TH++import HsSyn+import Class+import PrelNames+-- To avoid clashes with DsMeta.varName we must make a local alias for+-- OccName.varName we do this by removing varName from the import of+-- OccName above, making a qualified instance of OccName and using+-- OccNameAlias.varName where varName ws previously used in this file.+import qualified OccName( isDataOcc, isVarOcc, isTcOcc, varName, tcName, dataName )++import Module+import Id+import Name hiding( isVarOcc, isTcOcc, varName, tcName )+import NameEnv+import TcType+import TyCon+import TysWiredIn+import TysPrim ( liftedTypeKindTyConName, constraintKindTyConName )+import CoreSyn+import MkCore+import CoreUtils+import SrcLoc+import Unique+import BasicTypes+import Outputable+import Bag+import DynFlags+import FastString+import ForeignCall+import Util+import MonadUtils++import Data.Maybe+import Control.Monad+import Data.List++-----------------------------------------------------------------------------+dsBracket :: HsBracket Name -> [PendingTcSplice] -> DsM CoreExpr+-- Returns a CoreExpr of type TH.ExpQ+-- The quoted thing is parameterised over Name, even though it has+-- been type checked. We don't want all those type decorations!++dsBracket brack splices+ = dsExtendMetaEnv new_bit (do_brack brack)+ where+ new_bit = mkNameEnv [(n, DsSplice (unLoc e)) | PendSplice n e <- splices]++ do_brack (VarBr _ n) = do { MkC e1 <- lookupOcc n ; return e1 }+ do_brack (ExpBr e) = do { MkC e1 <- repLE e ; return e1 }+ do_brack (PatBr p) = do { MkC p1 <- repTopP p ; return p1 }+ do_brack (TypBr t) = do { MkC t1 <- repLTy t ; return t1 }+ do_brack (DecBrG gp) = do { MkC ds1 <- repTopDs gp ; return ds1 }+ do_brack (DecBrL _) = panic "dsBracket: unexpected DecBrL"+ do_brack (TExpBr e) = do { MkC e1 <- repLE e ; return e1 }++{- -------------- Examples --------------------++ [| \x -> x |]+====>+ gensym (unpackString "x"#) `bindQ` \ x1::String ->+ lam (pvar x1) (var x1)+++ [| \x -> $(f [| x |]) |]+====>+ gensym (unpackString "x"#) `bindQ` \ x1::String ->+ lam (pvar x1) (f (var x1))+-}+++-------------------------------------------------------+-- Declarations+-------------------------------------------------------++repTopP :: LPat Name -> DsM (Core TH.PatQ)+repTopP pat = do { ss <- mkGenSyms (collectPatBinders pat)+ ; pat' <- addBinds ss (repLP pat)+ ; wrapGenSyms ss pat' }++repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec]))+repTopDs group@(HsGroup { hs_valds = valds+ , hs_splcds = splcds+ , hs_tyclds = tyclds+ , hs_instds = instds+ , hs_derivds = derivds+ , hs_fixds = fixds+ , hs_defds = defds+ , hs_fords = fords+ , hs_warnds = warnds+ , hs_annds = annds+ , hs_ruleds = ruleds+ , hs_vects = vects+ , hs_docs = docs })+ = do { let { tv_bndrs = hsSigTvBinders valds+ ; bndrs = tv_bndrs ++ hsGroupBinders group } ;+ ss <- mkGenSyms bndrs ;++ -- Bind all the names mainly to avoid repeated use of explicit strings.+ -- Thus we get+ -- do { t :: String <- genSym "T" ;+ -- return (Data t [] ...more t's... }+ -- The other important reason is that the output must mention+ -- only "T", not "Foo:T" where Foo is the current module++ decls <- addBinds ss (+ do { val_ds <- rep_val_binds valds+ ; _ <- mapM no_splice splcds+ ; tycl_ds <- mapM repTyClD (tyClGroupConcat tyclds)+ ; role_ds <- mapM repRoleD (concatMap group_roles tyclds)+ ; inst_ds <- mapM repInstD instds+ ; deriv_ds <- mapM repStandaloneDerivD derivds+ ; fix_ds <- mapM repFixD fixds+ ; _ <- mapM no_default_decl defds+ ; for_ds <- mapM repForD fords+ ; _ <- mapM no_warn (concatMap (wd_warnings . unLoc)+ warnds)+ ; ann_ds <- mapM repAnnD annds+ ; rule_ds <- mapM repRuleD (concatMap (rds_rules . unLoc)+ ruleds)+ ; _ <- mapM no_vect vects+ ; _ <- mapM no_doc docs++ -- more needed+ ; return (de_loc $ sort_by_loc $+ val_ds ++ catMaybes tycl_ds ++ role_ds+ ++ (concat fix_ds)+ ++ inst_ds ++ rule_ds ++ for_ds+ ++ ann_ds ++ deriv_ds) }) ;++ decl_ty <- lookupType decQTyConName ;+ let { core_list = coreList' decl_ty decls } ;++ dec_ty <- lookupType decTyConName ;+ q_decs <- repSequenceQ dec_ty core_list ;++ wrapGenSyms ss q_decs+ }+ where+ no_splice (L loc _)+ = notHandledL loc "Splices within declaration brackets" empty+ no_default_decl (L loc decl)+ = notHandledL loc "Default declarations" (ppr decl)+ no_warn (L loc (Warning thing _))+ = notHandledL loc "WARNING and DEPRECATION pragmas" $+ text "Pragma for declaration of" <+> ppr thing+ no_vect (L loc decl)+ = notHandledL loc "Vectorisation pragmas" (ppr decl)+ no_doc (L loc _)+ = notHandledL loc "Haddock documentation" empty++hsSigTvBinders :: HsValBinds Name -> [Name]+-- See Note [Scoped type variables in bindings]+hsSigTvBinders binds+ = [hsLTyVarName tv | L _ (TypeSig _ (L _ (HsForAllTy Explicit _ qtvs _ _)) _) <- sigs+ , tv <- hsQTvBndrs qtvs]+ where+ sigs = case binds of+ ValBindsIn _ sigs -> sigs+ ValBindsOut _ sigs -> sigs+++{- Notes++Note [Scoped type variables in bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+ f :: forall a. a -> a+ f x = x::a+Here the 'forall a' brings 'a' into scope over the binding group.+To achieve this we++ a) Gensym a binding for 'a' at the same time as we do one for 'f'+ collecting the relevant binders with hsSigTvBinders++ b) When processing the 'forall', don't gensym++The relevant places are signposted with references to this Note++Note [Binders and occurrences]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we desugar [d| data T = MkT |]+we want to get+ Data "T" [] [Con "MkT" []] []+and *not*+ Data "Foo:T" [] [Con "Foo:MkT" []] []+That is, the new data decl should fit into whatever new module it is+asked to fit in. We do *not* clone, though; no need for this:+ Data "T79" ....++But if we see this:+ data T = MkT+ foo = reifyDecl T++then we must desugar to+ foo = Data "Foo:T" [] [Con "Foo:MkT" []] []++So in repTopDs we bring the binders into scope with mkGenSyms and addBinds.+And we use lookupOcc, rather than lookupBinder+in repTyClD and repC.++-}++-- represent associated family instances+--+repTyClD :: LTyClDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ))++repTyClD (L loc (FamDecl { tcdFam = fam })) = liftM Just $ repFamilyDecl (L loc fam)++repTyClD (L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs }))+ = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]+ ; dec <- addTyClTyVarBinds tvs $ \bndrs ->+ repSynDecl tc1 bndrs rhs+ ; return (Just (loc, dec)) }++repTyClD (L loc (DataDecl { tcdLName = tc, tcdTyVars = tvs, tcdDataDefn = defn }))+ = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]+ ; tc_tvs <- mk_extra_tvs tc tvs defn+ ; dec <- addTyClTyVarBinds tc_tvs $ \bndrs ->+ repDataDefn tc1 bndrs Nothing (hsLTyVarNames tc_tvs) defn+ ; return (Just (loc, dec)) }++repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,+ tcdTyVars = tvs, tcdFDs = fds,+ tcdSigs = sigs, tcdMeths = meth_binds,+ tcdATs = ats, tcdATDefs = [] }))+ = do { cls1 <- lookupLOcc cls -- See note [Binders and occurrences]+ ; dec <- addTyVarBinds tvs $ \bndrs ->+ do { cxt1 <- repLContext cxt+ ; sigs1 <- rep_sigs sigs+ ; binds1 <- rep_binds meth_binds+ ; fds1 <- repLFunDeps fds+ ; ats1 <- repFamilyDecls ats+ ; decls1 <- coreList decQTyConName (ats1 ++ sigs1 ++ binds1)+ ; repClass cxt1 cls1 bndrs fds1 decls1+ }+ ; return $ Just (loc, dec)+ }++-- Un-handled cases+repTyClD (L loc d) = putSrcSpanDs loc $+ do { warnDs (hang ds_msg 4 (ppr d))+ ; return Nothing }++-------------------------+repRoleD :: LRoleAnnotDecl Name -> DsM (SrcSpan, Core TH.DecQ)+repRoleD (L loc (RoleAnnotDecl tycon roles))+ = do { tycon1 <- lookupLOcc tycon+ ; roles1 <- mapM repRole roles+ ; roles2 <- coreList roleTyConName roles1+ ; dec <- repRoleAnnotD tycon1 roles2+ ; return (loc, dec) }++-------------------------+repDataDefn :: Core TH.Name -> Core [TH.TyVarBndr]+ -> Maybe (Core [TH.TypeQ])+ -> [Name] -> HsDataDefn Name+ -> DsM (Core TH.DecQ)+repDataDefn tc bndrs opt_tys tv_names+ (HsDataDefn { dd_ND = new_or_data, dd_ctxt = cxt+ , dd_cons = cons, dd_derivs = mb_derivs })+ = do { cxt1 <- repLContext cxt+ ; derivs1 <- repDerivs mb_derivs+ ; case new_or_data of+ NewType -> do { con1 <- repC tv_names (head cons)+ ; case con1 of+ [c] -> repNewtype cxt1 tc bndrs opt_tys c derivs1+ _cs -> failWithDs (ptext+ (sLit "Multiple constructors for newtype:")+ <+> pprQuotedList+ (con_names $ unLoc $ head cons))+ }+ DataType -> do { consL <- concatMapM (repC tv_names) cons+ ; cons1 <- coreList conQTyConName consL+ ; repData cxt1 tc bndrs opt_tys cons1 derivs1 } }++repSynDecl :: Core TH.Name -> Core [TH.TyVarBndr]+ -> LHsType Name+ -> DsM (Core TH.DecQ)+repSynDecl tc bndrs ty+ = do { ty1 <- repLTy ty+ ; repTySyn tc bndrs ty1 }++repFamilyDecl :: LFamilyDecl Name -> DsM (SrcSpan, Core TH.DecQ)+repFamilyDecl (L loc (FamilyDecl { fdInfo = info,+ fdLName = tc,+ fdTyVars = tvs,+ fdKindSig = opt_kind }))+ = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]+ ; dec <- addTyClTyVarBinds tvs $ \bndrs ->+ case (opt_kind, info) of+ (Nothing, ClosedTypeFamily eqns) ->+ do { eqns1 <- mapM repTyFamEqn eqns+ ; eqns2 <- coreList tySynEqnQTyConName eqns1+ ; repClosedFamilyNoKind tc1 bndrs eqns2 }+ (Just ki, ClosedTypeFamily eqns) ->+ do { eqns1 <- mapM repTyFamEqn eqns+ ; eqns2 <- coreList tySynEqnQTyConName eqns1+ ; ki1 <- repLKind ki+ ; repClosedFamilyKind tc1 bndrs ki1 eqns2 }+ (Nothing, _) ->+ do { info' <- repFamilyInfo info+ ; repFamilyNoKind info' tc1 bndrs }+ (Just ki, _) ->+ do { info' <- repFamilyInfo info+ ; ki1 <- repLKind ki+ ; repFamilyKind info' tc1 bndrs ki1 }+ ; return (loc, dec)+ }++repFamilyDecls :: [LFamilyDecl Name] -> DsM [Core TH.DecQ]+repFamilyDecls fds = liftM de_loc (mapM repFamilyDecl fds)++-------------------------+mk_extra_tvs :: Located Name -> LHsTyVarBndrs Name+ -> HsDataDefn Name -> DsM (LHsTyVarBndrs Name)+-- If there is a kind signature it must be of form+-- k1 -> .. -> kn -> *+-- Return type variables [tv1:k1, tv2:k2, .., tvn:kn]+mk_extra_tvs tc tvs defn+ | HsDataDefn { dd_kindSig = Just hs_kind } <- defn+ = do { extra_tvs <- go hs_kind+ ; return (tvs { hsq_tvs = hsq_tvs tvs ++ extra_tvs }) }+ | otherwise+ = return tvs+ where+ go :: LHsKind Name -> DsM [LHsTyVarBndr Name]+ go (L loc (HsFunTy kind rest))+ = do { uniq <- newUnique+ ; let { occ = mkTyVarOccFS (fsLit "t")+ ; nm = mkInternalName uniq occ loc+ ; hs_tv = L loc (KindedTyVar (noLoc nm) kind) }+ ; hs_tvs <- go rest+ ; return (hs_tv : hs_tvs) }++ go (L _ (HsTyVar n))+ | n == liftedTypeKindTyConName+ = return []++ go _ = failWithDs (ptext (sLit "Malformed kind signature for") <+> ppr tc)++-------------------------+-- represent fundeps+--+repLFunDeps :: [Located (FunDep (Located Name))] -> DsM (Core [TH.FunDep])+repLFunDeps fds = repList funDepTyConName repLFunDep fds++repLFunDep :: Located (FunDep (Located Name)) -> DsM (Core TH.FunDep)+repLFunDep (L _ (xs, ys))+ = do xs' <- repList nameTyConName (lookupBinder . unLoc) xs+ ys' <- repList nameTyConName (lookupBinder . unLoc) ys+ repFunDep xs' ys'++-- represent family declaration flavours+--+repFamilyInfo :: FamilyInfo Name -> DsM (Core TH.FamFlavour)+repFamilyInfo OpenTypeFamily = rep2 typeFamName []+repFamilyInfo DataFamily = rep2 dataFamName []+repFamilyInfo ClosedTypeFamily {} = panic "repFamilyInfo"++-- Represent instance declarations+--+repInstD :: LInstDecl Name -> DsM (SrcSpan, Core TH.DecQ)+repInstD (L loc (TyFamInstD { tfid_inst = fi_decl }))+ = do { dec <- repTyFamInstD fi_decl+ ; return (loc, dec) }+repInstD (L loc (DataFamInstD { dfid_inst = fi_decl }))+ = do { dec <- repDataFamInstD fi_decl+ ; return (loc, dec) }+repInstD (L loc (ClsInstD { cid_inst = cls_decl }))+ = do { dec <- repClsInstD cls_decl+ ; return (loc, dec) }++repClsInstD :: ClsInstDecl Name -> DsM (Core TH.DecQ)+repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds+ , cid_sigs = prags, cid_tyfam_insts = ats+ , cid_datafam_insts = adts })+ = addTyVarBinds tvs $ \_ ->+ -- We must bring the type variables into scope, so their+ -- occurrences don't fail, even though the binders don't+ -- appear in the resulting data structure+ --+ -- But we do NOT bring the binders of 'binds' into scope+ -- because they are properly regarded as occurrences+ -- For example, the method names should be bound to+ -- the selector Ids, not to fresh names (Trac #5410)+ --+ do { cxt1 <- repContext cxt+ ; cls_tcon <- repTy (HsTyVar (unLoc cls))+ ; cls_tys <- repLTys tys+ ; inst_ty1 <- repTapps cls_tcon cls_tys+ ; binds1 <- rep_binds binds+ ; prags1 <- rep_sigs prags+ ; ats1 <- mapM (repTyFamInstD . unLoc) ats+ ; adts1 <- mapM (repDataFamInstD . unLoc) adts+ ; decls <- coreList decQTyConName (ats1 ++ adts1 ++ binds1 ++ prags1)+ ; repInst cxt1 inst_ty1 decls }+ where+ Just (tvs, cxt, cls, tys) = splitLHsInstDeclTy_maybe ty++repStandaloneDerivD :: LDerivDecl Name -> DsM (SrcSpan, Core TH.DecQ)+repStandaloneDerivD (L loc (DerivDecl { deriv_type = ty }))+ = do { dec <- addTyVarBinds tvs $ \_ ->+ do { cxt' <- repContext cxt+ ; cls_tcon <- repTy (HsTyVar (unLoc cls))+ ; cls_tys <- repLTys tys+ ; inst_ty <- repTapps cls_tcon cls_tys+ ; repDeriv cxt' inst_ty }+ ; return (loc, dec) }+ where+ Just (tvs, cxt, cls, tys) = splitLHsInstDeclTy_maybe ty++repTyFamInstD :: TyFamInstDecl Name -> DsM (Core TH.DecQ)+repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn })+ = do { let tc_name = tyFamInstDeclLName decl+ ; tc <- lookupLOcc tc_name -- See note [Binders and occurrences]+ ; eqn1 <- repTyFamEqn eqn+ ; repTySynInst tc eqn1 }++repTyFamEqn :: LTyFamInstEqn Name -> DsM (Core TH.TySynEqnQ)+repTyFamEqn (L loc (TyFamEqn { tfe_pats = HsWB { hswb_cts = tys+ , hswb_kvs = kv_names+ , hswb_tvs = tv_names }+ , tfe_rhs = rhs }))+ = do { let hs_tvs = HsQTvs { hsq_kvs = kv_names+ , hsq_tvs = userHsTyVarBndrs loc tv_names } -- Yuk+ ; addTyClTyVarBinds hs_tvs $ \ _ ->+ do { tys1 <- repLTys tys+ ; tys2 <- coreList typeQTyConName tys1+ ; rhs1 <- repLTy rhs+ ; repTySynEqn tys2 rhs1 } }++repDataFamInstD :: DataFamInstDecl Name -> DsM (Core TH.DecQ)+repDataFamInstD (DataFamInstDecl { dfid_tycon = tc_name+ , dfid_pats = HsWB { hswb_cts = tys, hswb_kvs = kv_names, hswb_tvs = tv_names }+ , dfid_defn = defn })+ = do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences]+ ; let loc = getLoc tc_name+ hs_tvs = HsQTvs { hsq_kvs = kv_names, hsq_tvs = userHsTyVarBndrs loc tv_names } -- Yuk+ ; addTyClTyVarBinds hs_tvs $ \ bndrs ->+ do { tys1 <- repList typeQTyConName repLTy tys+ ; repDataDefn tc bndrs (Just tys1) tv_names defn } }++repForD :: Located (ForeignDecl Name) -> DsM (SrcSpan, Core TH.DecQ)+repForD (L loc (ForeignImport name typ _ (CImport (L _ cc) (L _ s) mch cis _)))+ = do MkC name' <- lookupLOcc name+ MkC typ' <- repLTy typ+ MkC cc' <- repCCallConv cc+ MkC s' <- repSafety s+ cis' <- conv_cimportspec cis+ MkC str <- coreStringLit (static ++ chStr ++ cis')+ dec <- rep2 forImpDName [cc', s', str, name', typ']+ return (loc, dec)+ where+ conv_cimportspec (CLabel cls) = notHandled "Foreign label" (doubleQuotes (ppr cls))+ conv_cimportspec (CFunction DynamicTarget) = return "dynamic"+ conv_cimportspec (CFunction (StaticTarget fs _ True)) = return (unpackFS fs)+ conv_cimportspec (CFunction (StaticTarget _ _ False)) = panic "conv_cimportspec: values not supported yet"+ conv_cimportspec CWrapper = return "wrapper"+ static = case cis of+ CFunction (StaticTarget _ _ _) -> "static "+ _ -> ""+ chStr = case mch of+ Nothing -> ""+ Just (Header h) -> unpackFS h ++ " "+repForD decl = notHandled "Foreign declaration" (ppr decl)++repCCallConv :: CCallConv -> DsM (Core TH.Callconv)+repCCallConv CCallConv = rep2 cCallName []+repCCallConv StdCallConv = rep2 stdCallName []+repCCallConv CApiConv = rep2 cApiCallName []+repCCallConv PrimCallConv = rep2 primCallName []+repCCallConv JavaScriptCallConv = rep2 javaScriptCallName []++repSafety :: Safety -> DsM (Core TH.Safety)+repSafety PlayRisky = rep2 unsafeName []+repSafety PlayInterruptible = rep2 interruptibleName []+repSafety PlaySafe = rep2 safeName []++repFixD :: LFixitySig Name -> DsM [(SrcSpan, Core TH.DecQ)]+repFixD (L loc (FixitySig names (Fixity prec dir)))+ = do { MkC prec' <- coreIntLit prec+ ; let rep_fn = case dir of+ InfixL -> infixLDName+ InfixR -> infixRDName+ InfixN -> infixNDName+ ; let do_one name+ = do { MkC name' <- lookupLOcc name+ ; dec <- rep2 rep_fn [prec', name']+ ; return (loc,dec) }+ ; mapM do_one names }++repRuleD :: LRuleDecl Name -> DsM (SrcSpan, Core TH.DecQ)+repRuleD (L loc (HsRule n act bndrs lhs _ rhs _))+ = do { let bndr_names = concatMap ruleBndrNames bndrs+ ; ss <- mkGenSyms bndr_names+ ; rule1 <- addBinds ss $+ do { bndrs' <- repList ruleBndrQTyConName repRuleBndr bndrs+ ; n' <- coreStringLit $ unpackFS $ unLoc n+ ; act' <- repPhases act+ ; lhs' <- repLE lhs+ ; rhs' <- repLE rhs+ ; repPragRule n' bndrs' lhs' rhs' act' }+ ; rule2 <- wrapGenSyms ss rule1+ ; return (loc, rule2) }++ruleBndrNames :: LRuleBndr Name -> [Name]+ruleBndrNames (L _ (RuleBndr n)) = [unLoc n]+ruleBndrNames (L _ (RuleBndrSig n (HsWB { hswb_kvs = kvs, hswb_tvs = tvs })))+ = unLoc n : kvs ++ tvs++repRuleBndr :: LRuleBndr Name -> DsM (Core TH.RuleBndrQ)+repRuleBndr (L _ (RuleBndr n))+ = do { MkC n' <- lookupLBinder n+ ; rep2 ruleVarName [n'] }+repRuleBndr (L _ (RuleBndrSig n (HsWB { hswb_cts = ty })))+ = do { MkC n' <- lookupLBinder n+ ; MkC ty' <- repLTy ty+ ; rep2 typedRuleVarName [n', ty'] }++repAnnD :: LAnnDecl Name -> DsM (SrcSpan, Core TH.DecQ)+repAnnD (L loc (HsAnnotation _ ann_prov (L _ exp)))+ = do { target <- repAnnProv ann_prov+ ; exp' <- repE exp+ ; dec <- repPragAnn target exp'+ ; return (loc, dec) }++repAnnProv :: AnnProvenance Name -> DsM (Core TH.AnnTarget)+repAnnProv (ValueAnnProvenance (L _ n))+ = do { MkC n' <- globalVar n -- ANNs are allowed only at top-level+ ; rep2 valueAnnotationName [ n' ] }+repAnnProv (TypeAnnProvenance (L _ n))+ = do { MkC n' <- globalVar n+ ; rep2 typeAnnotationName [ n' ] }+repAnnProv ModuleAnnProvenance+ = rep2 moduleAnnotationName []++ds_msg :: SDoc+ds_msg = ptext (sLit "Cannot desugar this Template Haskell declaration:")++-------------------------------------------------------+-- Constructors+-------------------------------------------------------++repC :: [Name] -> LConDecl Name -> DsM [Core TH.ConQ]+repC _ (L _ (ConDecl { con_names = con, con_qvars = con_tvs, con_cxt = L _ []+ , con_details = details, con_res = ResTyH98 }))+ | null (hsQTvBndrs con_tvs)+ = do { con1 <- mapM lookupLOcc con -- See Note [Binders and occurrences]+ ; mapM (\c -> repConstr c details) con1 }++repC tvs (L _ (ConDecl { con_names = cons+ , con_qvars = con_tvs, con_cxt = L _ ctxt+ , con_details = details+ , con_res = res_ty }))+ = do { (eq_ctxt, con_tv_subst) <- mkGadtCtxt tvs res_ty+ ; let ex_tvs = HsQTvs { hsq_kvs = filterOut (in_subst con_tv_subst) (hsq_kvs con_tvs)+ , hsq_tvs = filterOut (in_subst con_tv_subst . hsLTyVarName) (hsq_tvs con_tvs) }++ ; binds <- mapM dupBinder con_tv_subst+ ; b <- dsExtendMetaEnv (mkNameEnv binds) $ -- Binds some of the con_tvs+ addTyVarBinds ex_tvs $ \ ex_bndrs -> -- Binds the remaining con_tvs+ do { cons1 <- mapM lookupLOcc cons -- See Note [Binders and occurrences]+ ; c' <- mapM (\c -> repConstr c details) cons1+ ; ctxt' <- repContext (eq_ctxt ++ ctxt)+ ; rep2 forallCName ([unC ex_bndrs, unC ctxt'] ++ (map unC c')) }+ ; return [b]+ }++in_subst :: [(Name,Name)] -> Name -> Bool+in_subst [] _ = False+in_subst ((n',_):ns) n = n==n' || in_subst ns n++mkGadtCtxt :: [Name] -- Tyvars of the data type+ -> ResType (LHsType Name)+ -> DsM (HsContext Name, [(Name,Name)])+-- Given a data type in GADT syntax, figure out the equality+-- context, so that we can represent it with an explicit+-- equality context, because that is the only way to express+-- the GADT in TH syntax+--+-- Example:+-- data T a b c where { MkT :: forall d e. d -> e -> T d [e] e+-- mkGadtCtxt [a,b,c] [d,e] (T d [e] e)+-- returns+-- (b~[e], c~e), [d->a]+--+-- This function is fiddly, but not really hard+mkGadtCtxt _ ResTyH98+ = return ([], [])+mkGadtCtxt data_tvs (ResTyGADT _ res_ty)+ | Just (_, tys) <- hsTyGetAppHead_maybe res_ty+ , data_tvs `equalLength` tys+ = return (go [] [] (data_tvs `zip` tys))++ | otherwise+ = failWithDs (ptext (sLit "Malformed constructor result type:") <+> ppr res_ty)+ where+ go cxt subst [] = (cxt, subst)+ go cxt subst ((data_tv, ty) : rest)+ | Just con_tv <- is_hs_tyvar ty+ , isTyVarName con_tv+ , not (in_subst subst con_tv)+ = go cxt ((con_tv, data_tv) : subst) rest+ | otherwise+ = go (eq_pred : cxt) subst rest+ where+ loc = getLoc ty+ eq_pred = L loc (HsEqTy (L loc (HsTyVar data_tv)) ty)++ is_hs_tyvar (L _ (HsTyVar n)) = Just n -- Type variables *and* tycons+ is_hs_tyvar (L _ (HsParTy ty)) = is_hs_tyvar ty+ is_hs_tyvar _ = Nothing+++repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ))+repBangTy ty= do+ MkC s <- rep2 str []+ MkC t <- repLTy ty'+ rep2 strictTypeName [s, t]+ where+ (str, ty') = case ty of+ L _ (HsBangTy (HsSrcBang _ (Just True) True) ty) -> (unpackedName, ty)+ L _ (HsBangTy (HsSrcBang _ _ True) ty) -> (isStrictName, ty)+ _ -> (notStrictName, ty)++-------------------------------------------------------+-- Deriving clause+-------------------------------------------------------++repDerivs :: Maybe (Located [LHsType Name]) -> DsM (Core [TH.Name])+repDerivs Nothing = coreList nameTyConName []+repDerivs (Just (L _ ctxt))+ = repList nameTyConName rep_deriv ctxt+ where+ rep_deriv :: LHsType Name -> DsM (Core TH.Name)+ -- Deriving clauses must have the simple H98 form+ rep_deriv ty+ | Just (cls, []) <- splitHsClassTy_maybe (unLoc ty)+ = lookupOcc cls+ | otherwise+ = notHandled "Non-H98 deriving clause" (ppr ty)+++-------------------------------------------------------+-- Signatures in a class decl, or a group of bindings+-------------------------------------------------------++rep_sigs :: [LSig Name] -> DsM [Core TH.DecQ]+rep_sigs sigs = do locs_cores <- rep_sigs' sigs+ return $ de_loc $ sort_by_loc locs_cores++rep_sigs' :: [LSig Name] -> DsM [(SrcSpan, Core TH.DecQ)]+ -- We silently ignore ones we don't recognise+rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ;+ return (concat sigs1) }++rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]+rep_sig (L loc (TypeSig nms ty _)) = mapM (rep_ty_sig sigDName loc ty) nms+rep_sig (L _ (PatSynSig {})) = notHandled "Pattern type signatures" empty+rep_sig (L loc (GenericSig nms ty)) = mapM (rep_ty_sig defaultSigDName loc ty) nms+rep_sig d@(L _ (IdSig {})) = pprPanic "rep_sig IdSig" (ppr d)+rep_sig (L _ (FixSig {})) = return [] -- fixity sigs at top level+rep_sig (L loc (InlineSig nm ispec)) = rep_inline nm ispec loc+rep_sig (L loc (SpecSig nm tys ispec))+ = concatMapM (\t -> rep_specialise nm t ispec loc) tys+rep_sig (L loc (SpecInstSig _ ty)) = rep_specialiseInst ty loc+rep_sig (L _ (MinimalSig {})) = notHandled "MINIMAL pragmas" empty++rep_ty_sig :: Name -> SrcSpan -> LHsType Name -> Located Name+ -> DsM (SrcSpan, Core TH.DecQ)+rep_ty_sig mk_sig loc (L _ ty) nm+ = do { nm1 <- lookupLOcc nm+ ; ty1 <- rep_ty ty+ ; sig <- repProto mk_sig nm1 ty1+ ; return (loc, sig) }+ where+ -- We must special-case the top-level explicit for-all of a TypeSig+ -- See Note [Scoped type variables in bindings]+ rep_ty (HsForAllTy Explicit _ tvs ctxt ty)+ = do { let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)+ ; repTyVarBndrWithKind tv name }+ ; bndrs1 <- repList tyVarBndrTyConName rep_in_scope_tv (hsQTvBndrs tvs)+ ; ctxt1 <- repLContext ctxt+ ; ty1 <- repLTy ty+ ; repTForall bndrs1 ctxt1 ty1 }++ rep_ty ty = repTy ty++rep_inline :: Located Name+ -> InlinePragma -- Never defaultInlinePragma+ -> SrcSpan+ -> DsM [(SrcSpan, Core TH.DecQ)]+rep_inline nm ispec loc+ = do { nm1 <- lookupLOcc nm+ ; inline <- repInline $ inl_inline ispec+ ; rm <- repRuleMatch $ inl_rule ispec+ ; phases <- repPhases $ inl_act ispec+ ; pragma <- repPragInl nm1 inline rm phases+ ; return [(loc, pragma)]+ }++rep_specialise :: Located Name -> LHsType Name -> InlinePragma -> SrcSpan+ -> DsM [(SrcSpan, Core TH.DecQ)]+rep_specialise nm ty ispec loc+ = do { nm1 <- lookupLOcc nm+ ; ty1 <- repLTy ty+ ; phases <- repPhases $ inl_act ispec+ ; let inline = inl_inline ispec+ ; pragma <- if isEmptyInlineSpec inline+ then -- SPECIALISE+ repPragSpec nm1 ty1 phases+ else -- SPECIALISE INLINE+ do { inline1 <- repInline inline+ ; repPragSpecInl nm1 ty1 inline1 phases }+ ; return [(loc, pragma)]+ }++rep_specialiseInst :: LHsType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)]+rep_specialiseInst ty loc+ = do { ty1 <- repLTy ty+ ; pragma <- repPragSpecInst ty1+ ; return [(loc, pragma)] }++repInline :: InlineSpec -> DsM (Core TH.Inline)+repInline NoInline = dataCon noInlineDataConName+repInline Inline = dataCon inlineDataConName+repInline Inlinable = dataCon inlinableDataConName+repInline spec = notHandled "repInline" (ppr spec)++repRuleMatch :: RuleMatchInfo -> DsM (Core TH.RuleMatch)+repRuleMatch ConLike = dataCon conLikeDataConName+repRuleMatch FunLike = dataCon funLikeDataConName++repPhases :: Activation -> DsM (Core TH.Phases)+repPhases (ActiveBefore i) = do { MkC arg <- coreIntLit i+ ; dataCon' beforePhaseDataConName [arg] }+repPhases (ActiveAfter i) = do { MkC arg <- coreIntLit i+ ; dataCon' fromPhaseDataConName [arg] }+repPhases _ = dataCon allPhasesDataConName++-------------------------------------------------------+-- Types+-------------------------------------------------------++addTyVarBinds :: LHsTyVarBndrs Name -- the binders to be added+ -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a))) -- action in the ext env+ -> DsM (Core (TH.Q a))+-- gensym a list of type variables and enter them into the meta environment;+-- the computations passed as the second argument is executed in that extended+-- meta environment and gets the *new* names on Core-level as an argument++addTyVarBinds (HsQTvs { hsq_kvs = kvs, hsq_tvs = tvs }) m+ = do { fresh_kv_names <- mkGenSyms kvs+ ; fresh_tv_names <- mkGenSyms (map hsLTyVarName tvs)+ ; let fresh_names = fresh_kv_names ++ fresh_tv_names+ ; term <- addBinds fresh_names $+ do { kbs <- repList tyVarBndrTyConName mk_tv_bndr (tvs `zip` fresh_tv_names)+ ; m kbs }+ ; wrapGenSyms fresh_names term }+ where+ mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)++addTyClTyVarBinds :: LHsTyVarBndrs Name+ -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a)))+ -> DsM (Core (TH.Q a))++-- Used for data/newtype declarations, and family instances,+-- so that the nested type variables work right+-- instance C (T a) where+-- type W (T a) = blah+-- The 'a' in the type instance is the one bound by the instance decl+addTyClTyVarBinds tvs m+ = do { let tv_names = hsLKiTyVarNames tvs+ ; env <- dsGetMetaEnv+ ; freshNames <- mkGenSyms (filterOut (`elemNameEnv` env) tv_names)+ -- Make fresh names for the ones that are not already in scope+ -- This makes things work for family declarations++ ; term <- addBinds freshNames $+ do { kbs <- repList tyVarBndrTyConName mk_tv_bndr (hsQTvBndrs tvs)+ ; m kbs }++ ; wrapGenSyms freshNames term }+ where+ mk_tv_bndr tv = do { v <- lookupBinder (hsLTyVarName tv)+ ; repTyVarBndrWithKind tv v }++-- Produce kinded binder constructors from the Haskell tyvar binders+--+repTyVarBndrWithKind :: LHsTyVarBndr Name+ -> Core TH.Name -> DsM (Core TH.TyVarBndr)+repTyVarBndrWithKind (L _ (UserTyVar _)) nm+ = repPlainTV nm+repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm+ = repLKind ki >>= repKindedTV nm++-- represent a type context+--+repLContext :: LHsContext Name -> DsM (Core TH.CxtQ)+repLContext (L _ ctxt) = repContext ctxt++repContext :: HsContext Name -> DsM (Core TH.CxtQ)+repContext ctxt = do preds <- repList typeQTyConName repLTy ctxt+ repCtxt preds++-- yield the representation of a list of types+--+repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ]+repLTys tys = mapM repLTy tys++-- represent a type+--+repLTy :: LHsType Name -> DsM (Core TH.TypeQ)+repLTy (L _ ty) = repTy ty++repTy :: HsType Name -> DsM (Core TH.TypeQ)+repTy (HsForAllTy _ _ tvs ctxt ty) =+ addTyVarBinds tvs $ \bndrs -> do+ ctxt1 <- repLContext ctxt+ ty1 <- repLTy ty+ repTForall bndrs ctxt1 ty1++repTy (HsTyVar n)+ | isTvOcc occ = do tv1 <- lookupOcc n+ repTvar tv1+ | isDataOcc occ = do tc1 <- lookupOcc n+ repPromotedTyCon tc1+ | otherwise = do tc1 <- lookupOcc n+ repNamedTyCon tc1+ where+ occ = nameOccName n++repTy (HsAppTy f a) = do+ f1 <- repLTy f+ a1 <- repLTy a+ repTapp f1 a1+repTy (HsFunTy f a) = do+ f1 <- repLTy f+ a1 <- repLTy a+ tcon <- repArrowTyCon+ repTapps tcon [f1, a1]+repTy (HsListTy t) = do+ t1 <- repLTy t+ tcon <- repListTyCon+ repTapp tcon t1+repTy (HsPArrTy t) = do+ t1 <- repLTy t+ tcon <- repTy (HsTyVar (tyConName parrTyCon))+ repTapp tcon t1+repTy (HsTupleTy HsUnboxedTuple tys) = do+ tys1 <- repLTys tys+ tcon <- repUnboxedTupleTyCon (length tys)+ repTapps tcon tys1+repTy (HsTupleTy _ tys) = do tys1 <- repLTys tys+ tcon <- repTupleTyCon (length tys)+ repTapps tcon tys1+repTy (HsOpTy ty1 (_, n) ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)+ `nlHsAppTy` ty2)+repTy (HsParTy t) = repLTy t+repTy (HsEqTy t1 t2) = do+ t1' <- repLTy t1+ t2' <- repLTy t2+ eq <- repTequality+ repTapps eq [t1', t2']+repTy (HsKindSig t k) = do+ t1 <- repLTy t+ k1 <- repLKind k+ repTSig t1 k1+repTy (HsSpliceTy splice _) = repSplice splice+repTy (HsExplicitListTy _ tys) = do+ tys1 <- repLTys tys+ repTPromotedList tys1+repTy (HsExplicitTupleTy _ tys) = do+ tys1 <- repLTys tys+ tcon <- repPromotedTupleTyCon (length tys)+ repTapps tcon tys1+repTy (HsTyLit lit) = do+ lit' <- repTyLit lit+ repTLit lit'+ +repTy ty = notHandled "Exotic form of type" (ppr ty)++repTyLit :: HsTyLit -> DsM (Core TH.TyLitQ)+repTyLit (HsNumTy _ i) = do iExpr <- mkIntegerExpr i+ rep2 numTyLitName [iExpr]+repTyLit (HsStrTy _ s) = do { s' <- mkStringExprFS s+ ; rep2 strTyLitName [s']+ }++-- represent a kind+--+repLKind :: LHsKind Name -> DsM (Core TH.Kind)+repLKind ki+ = do { let (kis, ki') = splitHsFunType ki+ ; kis_rep <- mapM repLKind kis+ ; ki'_rep <- repNonArrowLKind ki'+ ; kcon <- repKArrow+ ; let f k1 k2 = repKApp kcon k1 >>= flip repKApp k2+ ; foldrM f ki'_rep kis_rep+ }++repNonArrowLKind :: LHsKind Name -> DsM (Core TH.Kind)+repNonArrowLKind (L _ ki) = repNonArrowKind ki++repNonArrowKind :: HsKind Name -> DsM (Core TH.Kind)+repNonArrowKind (HsTyVar name)+ | name == liftedTypeKindTyConName = repKStar+ | name == constraintKindTyConName = repKConstraint+ | isTvOcc (nameOccName name) = lookupOcc name >>= repKVar+ | otherwise = lookupOcc name >>= repKCon+repNonArrowKind (HsAppTy f a) = do { f' <- repLKind f+ ; a' <- repLKind a+ ; repKApp f' a'+ }+repNonArrowKind (HsListTy k) = do { k' <- repLKind k+ ; kcon <- repKList+ ; repKApp kcon k'+ }+repNonArrowKind (HsTupleTy _ ks) = do { ks' <- mapM repLKind ks+ ; kcon <- repKTuple (length ks)+ ; repKApps kcon ks'+ }+repNonArrowKind k = notHandled "Exotic form of kind" (ppr k)++repRole :: Located (Maybe Role) -> DsM (Core TH.Role)+repRole (L _ (Just Nominal)) = rep2 nominalRName []+repRole (L _ (Just Representational)) = rep2 representationalRName []+repRole (L _ (Just Phantom)) = rep2 phantomRName []+repRole (L _ Nothing) = rep2 inferRName []++-----------------------------------------------------------------------------+-- Splices+-----------------------------------------------------------------------------++repSplice :: HsSplice Name -> DsM (Core a)+-- See Note [How brackets and nested splices are handled] in TcSplice+-- We return a CoreExpr of any old type; the context should know+repSplice (HsSplice n _)+ = do { mb_val <- dsLookupMetaEnv n+ ; case mb_val of+ Just (DsSplice e) -> do { e' <- dsExpr e+ ; return (MkC e') }+ _ -> pprPanic "HsSplice" (ppr n) }+ -- Should not happen; statically checked++-----------------------------------------------------------------------------+-- Expressions+-----------------------------------------------------------------------------++repLEs :: [LHsExpr Name] -> DsM (Core [TH.ExpQ])+repLEs es = repList expQTyConName repLE es++-- FIXME: some of these panics should be converted into proper error messages+-- unless we can make sure that constructs, which are plainly not+-- supported in TH already lead to error messages at an earlier stage+repLE :: LHsExpr Name -> DsM (Core TH.ExpQ)+repLE (L loc e) = putSrcSpanDs loc (repE e)++repE :: HsExpr Name -> DsM (Core TH.ExpQ)+repE (HsVar x) =+ do { mb_val <- dsLookupMetaEnv x+ ; case mb_val of+ Nothing -> do { str <- globalVar x+ ; repVarOrCon x str }+ Just (DsBound y) -> repVarOrCon x (coreVar y)+ Just (DsSplice e) -> do { e' <- dsExpr e+ ; return (MkC e') } }+repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e)++ -- Remember, we're desugaring renamer output here, so+ -- HsOverlit can definitely occur+repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }+repE (HsLit l) = do { a <- repLiteral l; repLit a }+repE (HsLam (MG { mg_alts = [m] })) = repLambda m+repE (HsLamCase _ (MG { mg_alts = ms }))+ = do { ms' <- mapM repMatchTup ms+ ; core_ms <- coreList matchQTyConName ms'+ ; repLamCase core_ms }+repE (HsApp x y) = do {a <- repLE x; b <- repLE y; repApp a b}++repE (OpApp e1 op _ e2) =+ do { arg1 <- repLE e1;+ arg2 <- repLE e2;+ the_op <- repLE op ;+ repInfixApp arg1 the_op arg2 }+repE (NegApp x _) = do+ a <- repLE x+ negateVar <- lookupOcc negateName >>= repVar+ negateVar `repApp` a+repE (HsPar x) = repLE x+repE (SectionL x y) = do { a <- repLE x; b <- repLE y; repSectionL a b }+repE (SectionR x y) = do { a <- repLE x; b <- repLE y; repSectionR a b }+repE (HsCase e (MG { mg_alts = ms }))+ = do { arg <- repLE e+ ; ms2 <- mapM repMatchTup ms+ ; core_ms2 <- coreList matchQTyConName ms2+ ; repCaseE arg core_ms2 }+repE (HsIf _ x y z) = do+ a <- repLE x+ b <- repLE y+ c <- repLE z+ repCond a b c+repE (HsMultiIf _ alts)+ = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts+ ; expr' <- repMultiIf (nonEmptyCoreList alts')+ ; wrapGenSyms (concat binds) expr' }+repE (HsLet bs e) = do { (ss,ds) <- repBinds bs+ ; e2 <- addBinds ss (repLE e)+ ; z <- repLetE ds e2+ ; wrapGenSyms ss z }++-- FIXME: I haven't got the types here right yet+repE e@(HsDo ctxt sts _)+ | case ctxt of { DoExpr -> True; GhciStmtCtxt -> True; _ -> False }+ = do { (ss,zs) <- repLSts sts;+ e' <- repDoE (nonEmptyCoreList zs);+ wrapGenSyms ss e' }++ | ListComp <- ctxt+ = do { (ss,zs) <- repLSts sts;+ e' <- repComp (nonEmptyCoreList zs);+ wrapGenSyms ss e' }++ | otherwise+ = notHandled "mdo, monad comprehension and [: :]" (ppr e)++repE (ExplicitList _ _ es) = do { xs <- repLEs es; repListExp xs }+repE e@(ExplicitPArr _ _) = notHandled "Parallel arrays" (ppr e)+repE e@(ExplicitTuple es boxed)+ | not (all tupArgPresent es) = notHandled "Tuple sections" (ppr e)+ | isBoxed boxed = do { xs <- repLEs [e | L _ (Present e) <- es]; repTup xs }+ | otherwise = do { xs <- repLEs [e | L _ (Present e) <- es]+ ; repUnboxedTup xs }++repE (RecordCon c _ flds)+ = do { x <- lookupLOcc c;+ fs <- repFields flds;+ repRecCon x fs }+repE (RecordUpd e flds _ _ _)+ = do { x <- repLE e;+ fs <- repFields flds;+ repRecUpd x fs }++repE (ExprWithTySig e ty _) = do { e1 <- repLE e; t1 <- repLTy ty; repSigExp e1 t1 }+repE (ArithSeq _ _ aseq) =+ case aseq of+ From e -> do { ds1 <- repLE e; repFrom ds1 }+ FromThen e1 e2 -> do+ ds1 <- repLE e1+ ds2 <- repLE e2+ repFromThen ds1 ds2+ FromTo e1 e2 -> do+ ds1 <- repLE e1+ ds2 <- repLE e2+ repFromTo ds1 ds2+ FromThenTo e1 e2 e3 -> do+ ds1 <- repLE e1+ ds2 <- repLE e2+ ds3 <- repLE e3+ repFromThenTo ds1 ds2 ds3++repE (HsSpliceE _ splice) = repSplice splice+repE (HsStatic e) = repLE e >>= rep2 staticEName . (:[]) . unC+repE e@(PArrSeq {}) = notHandled "Parallel arrays" (ppr e)+repE e@(HsCoreAnn {}) = notHandled "Core annotations" (ppr e)+repE e@(HsSCC {}) = notHandled "Cost centres" (ppr e)+repE e@(HsTickPragma {}) = notHandled "Tick Pragma" (ppr e)+repE e@(HsTcBracketOut {}) = notHandled "TH brackets" (ppr e)+repE e = notHandled "Expression form" (ppr e)++-----------------------------------------------------------------------------+-- Building representations of auxillary structures like Match, Clause, Stmt,++repMatchTup :: LMatch Name (LHsExpr Name) -> DsM (Core TH.MatchQ)+repMatchTup (L _ (Match _ [p] _ (GRHSs guards wheres))) =+ do { ss1 <- mkGenSyms (collectPatBinders p)+ ; addBinds ss1 $ do {+ ; p1 <- repLP p+ ; (ss2,ds) <- repBinds wheres+ ; addBinds ss2 $ do {+ ; gs <- repGuards guards+ ; match <- repMatch p1 gs ds+ ; wrapGenSyms (ss1++ss2) match }}}+repMatchTup _ = panic "repMatchTup: case alt with more than one arg"++repClauseTup :: LMatch Name (LHsExpr Name) -> DsM (Core TH.ClauseQ)+repClauseTup (L _ (Match _ ps _ (GRHSs guards wheres))) =+ do { ss1 <- mkGenSyms (collectPatsBinders ps)+ ; addBinds ss1 $ do {+ ps1 <- repLPs ps+ ; (ss2,ds) <- repBinds wheres+ ; addBinds ss2 $ do {+ gs <- repGuards guards+ ; clause <- repClause ps1 gs ds+ ; wrapGenSyms (ss1++ss2) clause }}}++repGuards :: [LGRHS Name (LHsExpr Name)] -> DsM (Core TH.BodyQ)+repGuards [L _ (GRHS [] e)]+ = do {a <- repLE e; repNormal a }+repGuards other+ = do { zs <- mapM repLGRHS other+ ; let (xs, ys) = unzip zs+ ; gd <- repGuarded (nonEmptyCoreList ys)+ ; wrapGenSyms (concat xs) gd }++repLGRHS :: LGRHS Name (LHsExpr Name) -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))+repLGRHS (L _ (GRHS [L _ (BodyStmt e1 _ _ _)] e2))+ = do { guarded <- repLNormalGE e1 e2+ ; return ([], guarded) }+repLGRHS (L _ (GRHS ss rhs))+ = do { (gs, ss') <- repLSts ss+ ; rhs' <- addBinds gs $ repLE rhs+ ; guarded <- repPatGE (nonEmptyCoreList ss') rhs'+ ; return (gs, guarded) }++repFields :: HsRecordBinds Name -> DsM (Core [TH.Q TH.FieldExp])+repFields (HsRecFields { rec_flds = flds })+ = repList fieldExpQTyConName rep_fld flds+ where+ rep_fld (L _ fld) = do { fn <- lookupLOcc (hsRecFieldId fld)+ ; e <- repLE (hsRecFieldArg fld)+ ; repFieldExp fn e }+++-----------------------------------------------------------------------------+-- Representing Stmt's is tricky, especially if bound variables+-- shadow each other. Consider: [| do { x <- f 1; x <- f x; g x } |]+-- First gensym new names for every variable in any of the patterns.+-- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y"))+-- if variables didn't shaddow, the static gensym wouldn't be necessary+-- and we could reuse the original names (x and x).+--+-- do { x'1 <- gensym "x"+-- ; x'2 <- gensym "x"+-- ; doE [ BindSt (pvar x'1) [| f 1 |]+-- , BindSt (pvar x'2) [| f x |]+-- , NoBindSt [| g x |]+-- ]+-- }++-- The strategy is to translate a whole list of do-bindings by building a+-- bigger environment, and a bigger set of meta bindings+-- (like: x'1 <- gensym "x" ) and then combining these with the translations+-- of the expressions within the Do++-----------------------------------------------------------------------------+-- The helper function repSts computes the translation of each sub expression+-- and a bunch of prefix bindings denoting the dynamic renaming.++repLSts :: [LStmt Name (LHsExpr Name)] -> DsM ([GenSymBind], [Core TH.StmtQ])+repLSts stmts = repSts (map unLoc stmts)++repSts :: [Stmt Name (LHsExpr Name)] -> DsM ([GenSymBind], [Core TH.StmtQ])+repSts (BindStmt p e _ _ : ss) =+ do { e2 <- repLE e+ ; ss1 <- mkGenSyms (collectPatBinders p)+ ; addBinds ss1 $ do {+ ; p1 <- repLP p;+ ; (ss2,zs) <- repSts ss+ ; z <- repBindSt p1 e2+ ; return (ss1++ss2, z : zs) }}+repSts (LetStmt bs : ss) =+ do { (ss1,ds) <- repBinds bs+ ; z <- repLetSt ds+ ; (ss2,zs) <- addBinds ss1 (repSts ss)+ ; return (ss1++ss2, z : zs) }+repSts (BodyStmt e _ _ _ : ss) =+ do { e2 <- repLE e+ ; z <- repNoBindSt e2+ ; (ss2,zs) <- repSts ss+ ; return (ss2, z : zs) }+repSts (ParStmt stmt_blocks _ _ : ss) =+ do { (ss_s, stmt_blocks1) <- mapAndUnzipM rep_stmt_block stmt_blocks+ ; let stmt_blocks2 = nonEmptyCoreList stmt_blocks1+ ss1 = concat ss_s+ ; z <- repParSt stmt_blocks2+ ; (ss2, zs) <- addBinds ss1 (repSts ss)+ ; return (ss1++ss2, z : zs) }+ where+ rep_stmt_block :: ParStmtBlock Name Name -> DsM ([GenSymBind], Core [TH.StmtQ])+ rep_stmt_block (ParStmtBlock stmts _ _) =+ do { (ss1, zs) <- repSts (map unLoc stmts)+ ; zs1 <- coreList stmtQTyConName zs+ ; return (ss1, zs1) }+repSts [LastStmt e _]+ = do { e2 <- repLE e+ ; z <- repNoBindSt e2+ ; return ([], [z]) }+repSts [] = return ([],[])+repSts other = notHandled "Exotic statement" (ppr other)+++-----------------------------------------------------------+-- Bindings+-----------------------------------------------------------++repBinds :: HsLocalBinds Name -> DsM ([GenSymBind], Core [TH.DecQ])+repBinds EmptyLocalBinds+ = do { core_list <- coreList decQTyConName []+ ; return ([], core_list) }++repBinds b@(HsIPBinds _) = notHandled "Implicit parameters" (ppr b)++repBinds (HsValBinds decs)+ = do { let { bndrs = hsSigTvBinders decs ++ collectHsValBinders decs }+ -- No need to worrry about detailed scopes within+ -- the binding group, because we are talking Names+ -- here, so we can safely treat it as a mutually+ -- recursive group+ -- For hsSigTvBinders see Note [Scoped type variables in bindings]+ ; ss <- mkGenSyms bndrs+ ; prs <- addBinds ss (rep_val_binds decs)+ ; core_list <- coreList decQTyConName+ (de_loc (sort_by_loc prs))+ ; return (ss, core_list) }++rep_val_binds :: HsValBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]+-- Assumes: all the binders of the binding are alrady in the meta-env+rep_val_binds (ValBindsOut binds sigs)+ = do { core1 <- rep_binds' (unionManyBags (map snd binds))+ ; core2 <- rep_sigs' sigs+ ; return (core1 ++ core2) }+rep_val_binds (ValBindsIn _ _)+ = panic "rep_val_binds: ValBindsIn"++rep_binds :: LHsBinds Name -> DsM [Core TH.DecQ]+rep_binds binds = do { binds_w_locs <- rep_binds' binds+ ; return (de_loc (sort_by_loc binds_w_locs)) }++rep_binds' :: LHsBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]+rep_binds' = mapM rep_bind . bagToList++rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ)+-- Assumes: all the binders of the binding are alrady in the meta-env++-- Note GHC treats declarations of a variable (not a pattern)+-- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match+-- with an empty list of patterns+rep_bind (L loc (FunBind+ { fun_id = fn,+ fun_matches = MG { mg_alts = [L _ (Match _ [] _+ (GRHSs guards wheres))] } }))+ = do { (ss,wherecore) <- repBinds wheres+ ; guardcore <- addBinds ss (repGuards guards)+ ; fn' <- lookupLBinder fn+ ; p <- repPvar fn'+ ; ans <- repVal p guardcore wherecore+ ; ans' <- wrapGenSyms ss ans+ ; return (loc, ans') }++rep_bind (L loc (FunBind { fun_id = fn, fun_matches = MG { mg_alts = ms } }))+ = do { ms1 <- mapM repClauseTup ms+ ; fn' <- lookupLBinder fn+ ; ans <- repFun fn' (nonEmptyCoreList ms1)+ ; return (loc, ans) }++rep_bind (L loc (PatBind { pat_lhs = pat, pat_rhs = GRHSs guards wheres }))+ = do { patcore <- repLP pat+ ; (ss,wherecore) <- repBinds wheres+ ; guardcore <- addBinds ss (repGuards guards)+ ; ans <- repVal patcore guardcore wherecore+ ; ans' <- wrapGenSyms ss ans+ ; return (loc, ans') }++rep_bind (L _ (VarBind { var_id = v, var_rhs = e}))+ = do { v' <- lookupBinder v+ ; e2 <- repLE e+ ; x <- repNormal e2+ ; patcore <- repPvar v'+ ; empty_decls <- coreList decQTyConName []+ ; ans <- repVal patcore x empty_decls+ ; return (srcLocSpan (getSrcLoc v), ans) }++rep_bind (L _ (AbsBinds {})) = panic "rep_bind: AbsBinds"+rep_bind (L _ dec@(PatSynBind {})) = notHandled "pattern synonyms" (ppr dec)+-----------------------------------------------------------------------------+-- Since everything in a Bind is mutually recursive we need rename all+-- all the variables simultaneously. For example:+-- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to+-- do { f'1 <- gensym "f"+-- ; g'2 <- gensym "g"+-- ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]},+-- do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]}+-- ]}+-- This requires collecting the bindings (f'1 <- gensym "f"), and the+-- environment ( f |-> f'1 ) from each binding, and then unioning them+-- together. As we do this we collect GenSymBinds's which represent the renamed+-- variables bound by the Bindings. In order not to lose track of these+-- representations we build a shadow datatype MB with the same structure as+-- MonoBinds, but which has slots for the representations+++-----------------------------------------------------------------------------+-- GHC allows a more general form of lambda abstraction than specified+-- by Haskell 98. In particular it allows guarded lambda's like :+-- (\ x | even x -> 0 | odd x -> 1) at the moment we can't represent this in+-- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like+-- (\ p1 .. pn -> exp) by causing an error.++repLambda :: LMatch Name (LHsExpr Name) -> DsM (Core TH.ExpQ)+repLambda (L _ (Match _ ps _ (GRHSs [L _ (GRHS [] e)] EmptyLocalBinds)))+ = do { let bndrs = collectPatsBinders ps ;+ ; ss <- mkGenSyms bndrs+ ; lam <- addBinds ss (+ do { xs <- repLPs ps; body <- repLE e; repLam xs body })+ ; wrapGenSyms ss lam }++repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch (LambdaExpr :: HsMatchContext Name) m)+++-----------------------------------------------------------------------------+-- Patterns+-- repP deals with patterns. It assumes that we have already+-- walked over the pattern(s) once to collect the binders, and+-- have extended the environment. So every pattern-bound+-- variable should already appear in the environment.++-- Process a list of patterns+repLPs :: [LPat Name] -> DsM (Core [TH.PatQ])+repLPs ps = repList patQTyConName repLP ps++repLP :: LPat Name -> DsM (Core TH.PatQ)+repLP (L _ p) = repP p++repP :: Pat Name -> DsM (Core TH.PatQ)+repP (WildPat _) = repPwild+repP (LitPat l) = do { l2 <- repLiteral l; repPlit l2 }+repP (VarPat x) = do { x' <- lookupBinder x; repPvar x' }+repP (LazyPat p) = do { p1 <- repLP p; repPtilde p1 }+repP (BangPat p) = do { p1 <- repLP p; repPbang p1 }+repP (AsPat x p) = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 }+repP (ParPat p) = repLP p+repP (ListPat ps _ Nothing) = do { qs <- repLPs ps; repPlist qs }+repP (ListPat ps ty1 (Just (_,e))) = do { p <- repP (ListPat ps ty1 Nothing); e' <- repE e; repPview e' p}+repP (TuplePat ps boxed _)+ | isBoxed boxed = do { qs <- repLPs ps; repPtup qs }+ | otherwise = do { qs <- repLPs ps; repPunboxedTup qs }+repP (ConPatIn dc details)+ = do { con_str <- lookupLOcc dc+ ; case details of+ PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs }+ RecCon rec -> do { fps <- repList fieldPatQTyConName rep_fld (rec_flds rec)+ ; repPrec con_str fps }+ InfixCon p1 p2 -> do { p1' <- repLP p1;+ p2' <- repLP p2;+ repPinfix p1' con_str p2' }+ }+ where+ rep_fld (L _ fld) = do { MkC v <- lookupLOcc (hsRecFieldId fld)+ ; MkC p <- repLP (hsRecFieldArg fld)+ ; rep2 fieldPatName [v,p] }++repP (NPat (L _ l) Nothing _) = do { a <- repOverloadedLiteral l; repPlit a }+repP (ViewPat e p _) = do { e' <- repLE e; p' <- repLP p; repPview e' p' }+repP p@(NPat _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p)+repP p@(SigPatIn {}) = notHandled "Type signatures in patterns" (ppr p)+ -- The problem is to do with scoped type variables.+ -- To implement them, we have to implement the scoping rules+ -- here in DsMeta, and I don't want to do that today!+ -- do { p' <- repLP p; t' <- repLTy t; repPsig p' t' }+ -- repPsig :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ)+ -- repPsig (MkC p) (MkC t) = rep2 sigPName [p, t]++repP (SplicePat splice) = repSplice splice++repP other = notHandled "Exotic pattern" (ppr other)++----------------------------------------------------------+-- Declaration ordering helpers++sort_by_loc :: [(SrcSpan, a)] -> [(SrcSpan, a)]+sort_by_loc xs = sortBy comp xs+ where comp x y = compare (fst x) (fst y)++de_loc :: [(a, b)] -> [b]+de_loc = map snd++----------------------------------------------------------+-- The meta-environment++-- A name/identifier association for fresh names of locally bound entities+type GenSymBind = (Name, Id) -- Gensym the string and bind it to the Id+ -- I.e. (x, x_id) means+ -- let x_id = gensym "x" in ...++-- Generate a fresh name for a locally bound entity++mkGenSyms :: [Name] -> DsM [GenSymBind]+-- We can use the existing name. For example:+-- [| \x_77 -> x_77 + x_77 |]+-- desugars to+-- do { x_77 <- genSym "x"; .... }+-- We use the same x_77 in the desugared program, but with the type Bndr+-- instead of Int+--+-- We do make it an Internal name, though (hence localiseName)+--+-- Nevertheless, it's monadic because we have to generate nameTy+mkGenSyms ns = do { var_ty <- lookupType nameTyConName+ ; return [(nm, mkLocalId (localiseName nm) var_ty) | nm <- ns] }+++addBinds :: [GenSymBind] -> DsM a -> DsM a+-- Add a list of fresh names for locally bound entities to the+-- meta environment (which is part of the state carried around+-- by the desugarer monad)+addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,DsBound id) | (n,id) <- bs]) m++dupBinder :: (Name, Name) -> DsM (Name, DsMetaVal)+dupBinder (new, old)+ = do { mb_val <- dsLookupMetaEnv old+ ; case mb_val of+ Just val -> return (new, val)+ Nothing -> pprPanic "dupBinder" (ppr old) }++-- Look up a locally bound name+--+lookupLBinder :: Located Name -> DsM (Core TH.Name)+lookupLBinder (L _ n) = lookupBinder n++lookupBinder :: Name -> DsM (Core TH.Name)+lookupBinder = lookupOcc+ -- Binders are brought into scope before the pattern or what-not is+ -- desugared. Moreover, in instance declaration the binder of a method+ -- will be the selector Id and hence a global; so we need the+ -- globalVar case of lookupOcc++-- Look up a name that is either locally bound or a global name+--+-- * If it is a global name, generate the "original name" representation (ie,+-- the <module>:<name> form) for the associated entity+--+lookupLOcc :: Located Name -> DsM (Core TH.Name)+-- Lookup an occurrence; it can't be a splice.+-- Use the in-scope bindings if they exist+lookupLOcc (L _ n) = lookupOcc n++lookupOcc :: Name -> DsM (Core TH.Name)+lookupOcc n+ = do { mb_val <- dsLookupMetaEnv n ;+ case mb_val of+ Nothing -> globalVar n+ Just (DsBound x) -> return (coreVar x)+ Just (DsSplice _) -> pprPanic "repE:lookupOcc" (ppr n)+ }++globalVar :: Name -> DsM (Core TH.Name)+-- Not bound by the meta-env+-- Could be top-level; or could be local+-- f x = $(g [| x |])+-- Here the x will be local+globalVar name+ | isExternalName name+ = do { MkC mod <- coreStringLit name_mod+ ; MkC pkg <- coreStringLit name_pkg+ ; MkC occ <- occNameLit name+ ; rep2 mk_varg [pkg,mod,occ] }+ | otherwise+ = do { MkC occ <- occNameLit name+ ; MkC uni <- coreIntLit (getKey (getUnique name))+ ; rep2 mkNameLName [occ,uni] }+ where+ mod = {- ASSERT( isExternalName name) -} nameModule name+ name_mod = moduleNameString (moduleName mod)+ name_pkg = packageKeyString (modulePackageKey mod)+ name_occ = nameOccName name+ mk_varg | OccName.isDataOcc name_occ = mkNameG_dName+ | OccName.isVarOcc name_occ = mkNameG_vName+ | OccName.isTcOcc name_occ = mkNameG_tcName+ | otherwise = pprPanic "DsMeta.globalVar" (ppr name)++lookupType :: Name -- Name of type constructor (e.g. TH.ExpQ)+ -> DsM Type -- The type+lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;+ return (mkTyConApp tc []) }++wrapGenSyms :: [GenSymBind]+ -> Core (TH.Q a) -> DsM (Core (TH.Q a))+-- wrapGenSyms [(nm1,id1), (nm2,id2)] y+-- --> bindQ (gensym nm1) (\ id1 ->+-- bindQ (gensym nm2 (\ id2 ->+-- y))++wrapGenSyms binds body@(MkC b)+ = do { var_ty <- lookupType nameTyConName+ ; go var_ty binds }+ where+ [elt_ty] = tcTyConAppArgs (exprType b)+ -- b :: Q a, so we can get the type 'a' by looking at the+ -- argument type. NB: this relies on Q being a data/newtype,+ -- not a type synonym++ go _ [] = return body+ go var_ty ((name,id) : binds)+ = do { MkC body' <- go var_ty binds+ ; lit_str <- occNameLit name+ ; gensym_app <- repGensym lit_str+ ; repBindQ var_ty elt_ty+ gensym_app (MkC (Lam id body')) }++occNameLit :: Name -> DsM (Core String)+occNameLit n = coreStringLit (occNameString (nameOccName n))+++-- %*********************************************************************+-- %* *+-- Constructing code+-- %* *+-- %*********************************************************************++-----------------------------------------------------------------------------+-- PHANTOM TYPES for consistency. In order to make sure we do this correct+-- we invent a new datatype which uses phantom types.++newtype Core a = MkC CoreExpr+unC :: Core a -> CoreExpr+unC (MkC x) = x++rep2 :: Name -> [ CoreExpr ] -> DsM (Core a)+rep2 n xs = do { id <- dsLookupGlobalId n+ ; return (MkC (foldl App (Var id) xs)) }++dataCon' :: Name -> [CoreExpr] -> DsM (Core a)+dataCon' n args = do { id <- dsLookupDataCon n+ ; return $ MkC $ mkConApp id args }++dataCon :: Name -> DsM (Core a)+dataCon n = dataCon' n []++-- Then we make "repConstructors" which use the phantom types for each of the+-- smart constructors of the Meta.Meta datatypes.+++-- %*********************************************************************+-- %* *+-- The 'smart constructors'+-- %* *+-- %*********************************************************************++--------------- Patterns -----------------+repPlit :: Core TH.Lit -> DsM (Core TH.PatQ)+repPlit (MkC l) = rep2 litPName [l]++repPvar :: Core TH.Name -> DsM (Core TH.PatQ)+repPvar (MkC s) = rep2 varPName [s]++repPtup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)+repPtup (MkC ps) = rep2 tupPName [ps]++repPunboxedTup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)+repPunboxedTup (MkC ps) = rep2 unboxedTupPName [ps]++repPcon :: Core TH.Name -> Core [TH.PatQ] -> DsM (Core TH.PatQ)+repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps]++repPrec :: Core TH.Name -> Core [(TH.Name,TH.PatQ)] -> DsM (Core TH.PatQ)+repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps]++repPinfix :: Core TH.PatQ -> Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)+repPinfix (MkC p1) (MkC n) (MkC p2) = rep2 infixPName [p1, n, p2]++repPtilde :: Core TH.PatQ -> DsM (Core TH.PatQ)+repPtilde (MkC p) = rep2 tildePName [p]++repPbang :: Core TH.PatQ -> DsM (Core TH.PatQ)+repPbang (MkC p) = rep2 bangPName [p]++repPaspat :: Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)+repPaspat (MkC s) (MkC p) = rep2 asPName [s, p]++repPwild :: DsM (Core TH.PatQ)+repPwild = rep2 wildPName []++repPlist :: Core [TH.PatQ] -> DsM (Core TH.PatQ)+repPlist (MkC ps) = rep2 listPName [ps]++repPview :: Core TH.ExpQ -> Core TH.PatQ -> DsM (Core TH.PatQ)+repPview (MkC e) (MkC p) = rep2 viewPName [e,p]++--------------- Expressions -----------------+repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ)+repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str+ | otherwise = repVar str++repVar :: Core TH.Name -> DsM (Core TH.ExpQ)+repVar (MkC s) = rep2 varEName [s]++repCon :: Core TH.Name -> DsM (Core TH.ExpQ)+repCon (MkC s) = rep2 conEName [s]++repLit :: Core TH.Lit -> DsM (Core TH.ExpQ)+repLit (MkC c) = rep2 litEName [c]++repApp :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)+repApp (MkC x) (MkC y) = rep2 appEName [x,y]++repLam :: Core [TH.PatQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)+repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]++repLamCase :: Core [TH.MatchQ] -> DsM (Core TH.ExpQ)+repLamCase (MkC ms) = rep2 lamCaseEName [ms]++repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)+repTup (MkC es) = rep2 tupEName [es]++repUnboxedTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)+repUnboxedTup (MkC es) = rep2 unboxedTupEName [es]++repCond :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)+repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z]++repMultiIf :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.ExpQ)+repMultiIf (MkC alts) = rep2 multiIfEName [alts]++repLetE :: Core [TH.DecQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)+repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]++repCaseE :: Core TH.ExpQ -> Core [TH.MatchQ] -> DsM( Core TH.ExpQ)+repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]++repDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)+repDoE (MkC ss) = rep2 doEName [ss]++repComp :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)+repComp (MkC ss) = rep2 compEName [ss]++repListExp :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)+repListExp (MkC es) = rep2 listEName [es]++repSigExp :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ)+repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t]++repRecCon :: Core TH.Name -> Core [TH.Q TH.FieldExp]-> DsM (Core TH.ExpQ)+repRecCon (MkC c) (MkC fs) = rep2 recConEName [c,fs]++repRecUpd :: Core TH.ExpQ -> Core [TH.Q TH.FieldExp] -> DsM (Core TH.ExpQ)+repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs]++repFieldExp :: Core TH.Name -> Core TH.ExpQ -> DsM (Core (TH.Q TH.FieldExp))+repFieldExp (MkC n) (MkC x) = rep2 fieldExpName [n,x]++repInfixApp :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)+repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]++repSectionL :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)+repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y]++repSectionR :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)+repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y]++------------ Right hand sides (guarded expressions) ----+repGuarded :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.BodyQ)+repGuarded (MkC pairs) = rep2 guardedBName [pairs]++repNormal :: Core TH.ExpQ -> DsM (Core TH.BodyQ)+repNormal (MkC e) = rep2 normalBName [e]++------------ Guards ----+repLNormalGE :: LHsExpr Name -> LHsExpr Name -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))+repLNormalGE g e = do g' <- repLE g+ e' <- repLE e+ repNormalGE g' e'++repNormalGE :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))+repNormalGE (MkC g) (MkC e) = rep2 normalGEName [g, e]++repPatGE :: Core [TH.StmtQ] -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))+repPatGE (MkC ss) (MkC e) = rep2 patGEName [ss, e]++------------- Stmts -------------------+repBindSt :: Core TH.PatQ -> Core TH.ExpQ -> DsM (Core TH.StmtQ)+repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e]++repLetSt :: Core [TH.DecQ] -> DsM (Core TH.StmtQ)+repLetSt (MkC ds) = rep2 letSName [ds]++repNoBindSt :: Core TH.ExpQ -> DsM (Core TH.StmtQ)+repNoBindSt (MkC e) = rep2 noBindSName [e]++repParSt :: Core [[TH.StmtQ]] -> DsM (Core TH.StmtQ)+repParSt (MkC sss) = rep2 parSName [sss]++-------------- Range (Arithmetic sequences) -----------+repFrom :: Core TH.ExpQ -> DsM (Core TH.ExpQ)+repFrom (MkC x) = rep2 fromEName [x]++repFromThen :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)+repFromThen (MkC x) (MkC y) = rep2 fromThenEName [x,y]++repFromTo :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)+repFromTo (MkC x) (MkC y) = rep2 fromToEName [x,y]++repFromThenTo :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)+repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z]++------------ Match and Clause Tuples -----------+repMatch :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.MatchQ)+repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]++repClause :: Core [TH.PatQ] -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.ClauseQ)+repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]++-------------- Dec -----------------------------+repVal :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)+repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds]++repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ)+repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]++repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]+ -> Maybe (Core [TH.TypeQ])+ -> Core [TH.ConQ] -> Core [TH.Name] -> DsM (Core TH.DecQ)+repData (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC cons) (MkC derivs)+ = rep2 dataDName [cxt, nm, tvs, cons, derivs]+repData (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC cons) (MkC derivs)+ = rep2 dataInstDName [cxt, nm, tys, cons, derivs]++repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]+ -> Maybe (Core [TH.TypeQ])+ -> Core TH.ConQ -> Core [TH.Name] -> DsM (Core TH.DecQ)+repNewtype (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC con) (MkC derivs)+ = rep2 newtypeDName [cxt, nm, tvs, con, derivs]+repNewtype (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC con) (MkC derivs)+ = rep2 newtypeInstDName [cxt, nm, tys, con, derivs]++repTySyn :: Core TH.Name -> Core [TH.TyVarBndr]+ -> Core TH.TypeQ -> DsM (Core TH.DecQ)+repTySyn (MkC nm) (MkC tvs) (MkC rhs)+ = rep2 tySynDName [nm, tvs, rhs]++repInst :: Core TH.CxtQ -> Core TH.TypeQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)+repInst (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceDName [cxt, ty, ds]++repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]+ -> Core [TH.FunDep] -> Core [TH.DecQ]+ -> DsM (Core TH.DecQ)+repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds)+ = rep2 classDName [cxt, cls, tvs, fds, ds]++repDeriv :: Core TH.CxtQ -> Core TH.TypeQ -> DsM (Core TH.DecQ)+repDeriv (MkC cxt) (MkC ty) = rep2 standaloneDerivDName [cxt, ty]++repPragInl :: Core TH.Name -> Core TH.Inline -> Core TH.RuleMatch+ -> Core TH.Phases -> DsM (Core TH.DecQ)+repPragInl (MkC nm) (MkC inline) (MkC rm) (MkC phases)+ = rep2 pragInlDName [nm, inline, rm, phases]++repPragSpec :: Core TH.Name -> Core TH.TypeQ -> Core TH.Phases+ -> DsM (Core TH.DecQ)+repPragSpec (MkC nm) (MkC ty) (MkC phases)+ = rep2 pragSpecDName [nm, ty, phases]++repPragSpecInl :: Core TH.Name -> Core TH.TypeQ -> Core TH.Inline+ -> Core TH.Phases -> DsM (Core TH.DecQ)+repPragSpecInl (MkC nm) (MkC ty) (MkC inline) (MkC phases)+ = rep2 pragSpecInlDName [nm, ty, inline, phases]++repPragSpecInst :: Core TH.TypeQ -> DsM (Core TH.DecQ)+repPragSpecInst (MkC ty) = rep2 pragSpecInstDName [ty]++repPragRule :: Core String -> Core [TH.RuleBndrQ] -> Core TH.ExpQ+ -> Core TH.ExpQ -> Core TH.Phases -> DsM (Core TH.DecQ)+repPragRule (MkC nm) (MkC bndrs) (MkC lhs) (MkC rhs) (MkC phases)+ = rep2 pragRuleDName [nm, bndrs, lhs, rhs, phases]++repPragAnn :: Core TH.AnnTarget -> Core TH.ExpQ -> DsM (Core TH.DecQ)+repPragAnn (MkC targ) (MkC e) = rep2 pragAnnDName [targ, e]++repFamilyNoKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr]+ -> DsM (Core TH.DecQ)+repFamilyNoKind (MkC flav) (MkC nm) (MkC tvs)+ = rep2 familyNoKindDName [flav, nm, tvs]++repFamilyKind :: Core TH.FamFlavour -> Core TH.Name -> Core [TH.TyVarBndr]+ -> Core TH.Kind+ -> DsM (Core TH.DecQ)+repFamilyKind (MkC flav) (MkC nm) (MkC tvs) (MkC ki)+ = rep2 familyKindDName [flav, nm, tvs, ki]++repTySynInst :: Core TH.Name -> Core TH.TySynEqnQ -> DsM (Core TH.DecQ)+repTySynInst (MkC nm) (MkC eqn)+ = rep2 tySynInstDName [nm, eqn]++repClosedFamilyNoKind :: Core TH.Name+ -> Core [TH.TyVarBndr]+ -> Core [TH.TySynEqnQ]+ -> DsM (Core TH.DecQ)+repClosedFamilyNoKind (MkC nm) (MkC tvs) (MkC eqns)+ = rep2 closedTypeFamilyNoKindDName [nm, tvs, eqns]++repClosedFamilyKind :: Core TH.Name+ -> Core [TH.TyVarBndr]+ -> Core TH.Kind+ -> Core [TH.TySynEqnQ]+ -> DsM (Core TH.DecQ)+repClosedFamilyKind (MkC nm) (MkC tvs) (MkC ki) (MkC eqns)+ = rep2 closedTypeFamilyKindDName [nm, tvs, ki, eqns]++repTySynEqn :: Core [TH.TypeQ] -> Core TH.TypeQ -> DsM (Core TH.TySynEqnQ)+repTySynEqn (MkC lhs) (MkC rhs)+ = rep2 tySynEqnName [lhs, rhs]++repRoleAnnotD :: Core TH.Name -> Core [TH.Role] -> DsM (Core TH.DecQ)+repRoleAnnotD (MkC n) (MkC roles) = rep2 roleAnnotDName [n, roles]++repFunDep :: Core [TH.Name] -> Core [TH.Name] -> DsM (Core TH.FunDep)+repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys]++repProto :: Name -> Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)+repProto mk_sig (MkC s) (MkC ty) = rep2 mk_sig [s, ty]++repCtxt :: Core [TH.PredQ] -> DsM (Core TH.CxtQ)+repCtxt (MkC tys) = rep2 cxtName [tys]++repConstr :: Core TH.Name -> HsConDeclDetails Name+ -> DsM (Core TH.ConQ)+repConstr con (PrefixCon ps)+ = do arg_tys <- repList strictTypeQTyConName repBangTy ps+ rep2 normalCName [unC con, unC arg_tys]++repConstr con (RecCon (L _ ips))+ = do { args <- concatMapM rep_ip ips+ ; arg_vtys <- coreList varStrictTypeQTyConName args+ ; rep2 recCName [unC con, unC arg_vtys] }+ where+ rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip)+ rep_one_ip t n = do { MkC v <- lookupLOcc n+ ; MkC ty <- repBangTy t+ ; rep2 varStrictTypeName [v,ty] }++repConstr con (InfixCon st1 st2)+ = do arg1 <- repBangTy st1+ arg2 <- repBangTy st2+ rep2 infixCName [unC arg1, unC con, unC arg2]++------------ Types -------------------++repTForall :: Core [TH.TyVarBndr] -> Core TH.CxtQ -> Core TH.TypeQ+ -> DsM (Core TH.TypeQ)+repTForall (MkC tvars) (MkC ctxt) (MkC ty)+ = rep2 forallTName [tvars, ctxt, ty]++repTvar :: Core TH.Name -> DsM (Core TH.TypeQ)+repTvar (MkC s) = rep2 varTName [s]++repTapp :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)+repTapp (MkC t1) (MkC t2) = rep2 appTName [t1, t2]++repTapps :: Core TH.TypeQ -> [Core TH.TypeQ] -> DsM (Core TH.TypeQ)+repTapps f [] = return f+repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }++repTSig :: Core TH.TypeQ -> Core TH.Kind -> DsM (Core TH.TypeQ)+repTSig (MkC ty) (MkC ki) = rep2 sigTName [ty, ki]++repTequality :: DsM (Core TH.TypeQ)+repTequality = rep2 equalityTName []++repTPromotedList :: [Core TH.TypeQ] -> DsM (Core TH.TypeQ)+repTPromotedList [] = repPromotedNilTyCon+repTPromotedList (t:ts) = do { tcon <- repPromotedConsTyCon+ ; f <- repTapp tcon t+ ; t' <- repTPromotedList ts+ ; repTapp f t'+ }++repTLit :: Core TH.TyLitQ -> DsM (Core TH.TypeQ)+repTLit (MkC lit) = rep2 litTName [lit]++--------- Type constructors --------------++repNamedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ)+repNamedTyCon (MkC s) = rep2 conTName [s]++repTupleTyCon :: Int -> DsM (Core TH.TypeQ)+-- Note: not Core Int; it's easier to be direct here+repTupleTyCon i = do dflags <- getDynFlags+ rep2 tupleTName [mkIntExprInt dflags i]++repUnboxedTupleTyCon :: Int -> DsM (Core TH.TypeQ)+-- Note: not Core Int; it's easier to be direct here+repUnboxedTupleTyCon i = do dflags <- getDynFlags+ rep2 unboxedTupleTName [mkIntExprInt dflags i]++repArrowTyCon :: DsM (Core TH.TypeQ)+repArrowTyCon = rep2 arrowTName []++repListTyCon :: DsM (Core TH.TypeQ)+repListTyCon = rep2 listTName []++repPromotedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ)+repPromotedTyCon (MkC s) = rep2 promotedTName [s]++repPromotedTupleTyCon :: Int -> DsM (Core TH.TypeQ)+repPromotedTupleTyCon i = do dflags <- getDynFlags+ rep2 promotedTupleTName [mkIntExprInt dflags i]++repPromotedNilTyCon :: DsM (Core TH.TypeQ)+repPromotedNilTyCon = rep2 promotedNilTName []++repPromotedConsTyCon :: DsM (Core TH.TypeQ)+repPromotedConsTyCon = rep2 promotedConsTName []++------------ Kinds -------------------++repPlainTV :: Core TH.Name -> DsM (Core TH.TyVarBndr)+repPlainTV (MkC nm) = rep2 plainTVName [nm]++repKindedTV :: Core TH.Name -> Core TH.Kind -> DsM (Core TH.TyVarBndr)+repKindedTV (MkC nm) (MkC ki) = rep2 kindedTVName [nm, ki]++repKVar :: Core TH.Name -> DsM (Core TH.Kind)+repKVar (MkC s) = rep2 varKName [s]++repKCon :: Core TH.Name -> DsM (Core TH.Kind)+repKCon (MkC s) = rep2 conKName [s]++repKTuple :: Int -> DsM (Core TH.Kind)+repKTuple i = do dflags <- getDynFlags+ rep2 tupleKName [mkIntExprInt dflags i]++repKArrow :: DsM (Core TH.Kind)+repKArrow = rep2 arrowKName []++repKList :: DsM (Core TH.Kind)+repKList = rep2 listKName []++repKApp :: Core TH.Kind -> Core TH.Kind -> DsM (Core TH.Kind)+repKApp (MkC k1) (MkC k2) = rep2 appKName [k1, k2]++repKApps :: Core TH.Kind -> [Core TH.Kind] -> DsM (Core TH.Kind)+repKApps f [] = return f+repKApps f (k:ks) = do { f' <- repKApp f k; repKApps f' ks }++repKStar :: DsM (Core TH.Kind)+repKStar = rep2 starKName []++repKConstraint :: DsM (Core TH.Kind)+repKConstraint = rep2 constraintKName []++----------------------------------------------------------+-- Literals++repLiteral :: HsLit -> DsM (Core TH.Lit)+repLiteral lit+ = do lit' <- case lit of+ HsIntPrim _ i -> mk_integer i+ HsWordPrim _ w -> mk_integer w+ HsInt _ i -> mk_integer i+ HsFloatPrim r -> mk_rational r+ HsDoublePrim r -> mk_rational r+ _ -> return lit+ lit_expr <- dsLit lit'+ case mb_lit_name of+ Just lit_name -> rep2 lit_name [lit_expr]+ Nothing -> notHandled "Exotic literal" (ppr lit)+ where+ mb_lit_name = case lit of+ HsInteger _ _ _ -> Just integerLName+ HsInt _ _ -> Just integerLName+ HsIntPrim _ _ -> Just intPrimLName+ HsWordPrim _ _ -> Just wordPrimLName+ HsFloatPrim _ -> Just floatPrimLName+ HsDoublePrim _ -> Just doublePrimLName+ HsChar _ _ -> Just charLName+ HsString _ _ -> Just stringLName+ HsRat _ _ -> Just rationalLName+ _ -> Nothing++mk_integer :: Integer -> DsM HsLit+mk_integer i = do integer_ty <- lookupType integerTyConName+ return $ HsInteger "" i integer_ty+mk_rational :: FractionalLit -> DsM HsLit+mk_rational r = do rat_ty <- lookupType rationalTyConName+ return $ HsRat r rat_ty+mk_string :: FastString -> DsM HsLit+mk_string s = return $ HsString "" s++repOverloadedLiteral :: HsOverLit Name -> DsM (Core TH.Lit)+repOverloadedLiteral (OverLit { ol_val = val})+ = do { lit <- mk_lit val; repLiteral lit }+ -- The type Rational will be in the environment, because+ -- the smart constructor 'TH.Syntax.rationalL' uses it in its type,+ -- and rationalL is sucked in when any TH stuff is used++mk_lit :: OverLitVal -> DsM HsLit+mk_lit (HsIntegral _ i) = mk_integer i+mk_lit (HsFractional f) = mk_rational f+mk_lit (HsIsString _ s) = mk_string s++--------------- Miscellaneous -------------------++repGensym :: Core String -> DsM (Core (TH.Q TH.Name))+repGensym (MkC lit_str) = rep2 newNameName [lit_str]++repBindQ :: Type -> Type -- a and b+ -> Core (TH.Q a) -> Core (a -> TH.Q b) -> DsM (Core (TH.Q b))+repBindQ ty_a ty_b (MkC x) (MkC y)+ = rep2 bindQName [Type ty_a, Type ty_b, x, y]++repSequenceQ :: Type -> Core [TH.Q a] -> DsM (Core (TH.Q [a]))+repSequenceQ ty_a (MkC list)+ = rep2 sequenceQName [Type ty_a, list]++------------ Lists and Tuples -------------------+-- turn a list of patterns into a single pattern matching a list++repList :: Name -> (a -> DsM (Core b))+ -> [a] -> DsM (Core [b])+repList tc_name f args+ = do { args1 <- mapM f args+ ; coreList tc_name args1 }++coreList :: Name -- Of the TyCon of the element type+ -> [Core a] -> DsM (Core [a])+coreList tc_name es+ = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) }++coreList' :: Type -- The element type+ -> [Core a] -> Core [a]+coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es ))++nonEmptyCoreList :: [Core a] -> Core [a]+ -- The list must be non-empty so we can get the element type+ -- Otherwise use coreList+nonEmptyCoreList [] = panic "coreList: empty argument"+nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))++coreStringLit :: String -> DsM (Core String)+coreStringLit s = do { z <- mkStringExpr s; return(MkC z) }++------------ Literals & Variables -------------------++coreIntLit :: Int -> DsM (Core Int)+coreIntLit i = do dflags <- getDynFlags+ return (MkC (mkIntExprInt dflags i))++coreVar :: Id -> Core TH.Name -- The Id has type Name+coreVar id = MkC (Var id)++----------------- Failure -----------------------+notHandledL :: SrcSpan -> String -> SDoc -> DsM a+notHandledL loc what doc+ | isGoodSrcSpan loc+ = putSrcSpanDs loc $ notHandled what doc+ | otherwise+ = notHandled what doc++notHandled :: String -> SDoc -> DsM a+notHandled what doc = failWithDs msg+ where+ msg = hang (text what <+> ptext (sLit "not (yet) handled by Template Haskell"))+ 2 doc+++-- %************************************************************************+-- %* *+-- The known-key names for Template Haskell+-- %* *+-- %************************************************************************++-- To add a name, do three things+--+-- 1) Allocate a key+-- 2) Make a "Name"+-- 3) Add the name to knownKeyNames++templateHaskellNames :: [Name]+-- The names that are implicitly mentioned by ``bracket''+-- Should stay in sync with the import list of DsMeta++templateHaskellNames = [+ returnQName, bindQName, sequenceQName, newNameName, liftName,+ mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName,+ liftStringName,+ unTypeName,+ unTypeQName,+ unsafeTExpCoerceName,++ -- Lit+ charLName, stringLName, integerLName, intPrimLName, wordPrimLName,+ floatPrimLName, doublePrimLName, rationalLName,+ -- Pat+ litPName, varPName, tupPName, unboxedTupPName,+ conPName, tildePName, bangPName, infixPName,+ asPName, wildPName, recPName, listPName, sigPName, viewPName,+ -- FieldPat+ fieldPatName,+ -- Match+ matchName,+ -- Clause+ clauseName,+ -- Exp+ varEName, conEName, litEName, appEName, infixEName,+ infixAppName, sectionLName, sectionRName, lamEName, lamCaseEName,+ tupEName, unboxedTupEName,+ condEName, multiIfEName, letEName, caseEName, doEName, compEName,+ fromEName, fromThenEName, fromToEName, fromThenToEName,+ listEName, sigEName, recConEName, recUpdEName, staticEName,+ -- FieldExp+ fieldExpName,+ -- Body+ guardedBName, normalBName,+ -- Guard+ normalGEName, patGEName,+ -- Stmt+ bindSName, letSName, noBindSName, parSName,+ -- Dec+ funDName, valDName, dataDName, newtypeDName, tySynDName,+ classDName, instanceDName, standaloneDerivDName, sigDName, forImpDName,+ pragInlDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName,+ pragRuleDName, pragAnnDName, defaultSigDName,+ familyNoKindDName, familyKindDName, dataInstDName, newtypeInstDName,+ tySynInstDName, closedTypeFamilyKindDName, closedTypeFamilyNoKindDName,+ infixLDName, infixRDName, infixNDName,+ roleAnnotDName,+ -- Cxt+ cxtName,+ -- Strict+ isStrictName, notStrictName, unpackedName,+ -- Con+ normalCName, recCName, infixCName, forallCName,+ -- StrictType+ strictTypeName,+ -- VarStrictType+ varStrictTypeName,+ -- Type+ forallTName, varTName, conTName, appTName, equalityTName,+ tupleTName, unboxedTupleTName, arrowTName, listTName, sigTName, litTName,+ promotedTName, promotedTupleTName, promotedNilTName, promotedConsTName,+ -- TyLit+ numTyLitName, strTyLitName,+ -- TyVarBndr+ plainTVName, kindedTVName,+ -- Role+ nominalRName, representationalRName, phantomRName, inferRName,+ -- Kind+ varKName, conKName, tupleKName, arrowKName, listKName, appKName,+ starKName, constraintKName,+ -- Callconv+ cCallName, stdCallName, cApiCallName, primCallName, javaScriptCallName,+ -- Safety+ unsafeName,+ safeName,+ interruptibleName,+ -- Inline+ noInlineDataConName, inlineDataConName, inlinableDataConName,+ -- RuleMatch+ conLikeDataConName, funLikeDataConName,+ -- Phases+ allPhasesDataConName, fromPhaseDataConName, beforePhaseDataConName,+ -- TExp+ tExpDataConName,+ -- RuleBndr+ ruleVarName, typedRuleVarName,+ -- FunDep+ funDepName,+ -- FamFlavour+ typeFamName, dataFamName,+ -- TySynEqn+ tySynEqnName,+ -- AnnTarget+ valueAnnotationName, typeAnnotationName, moduleAnnotationName,++ -- And the tycons+ qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName,+ clauseQTyConName, expQTyConName, fieldExpTyConName, predTyConName,+ stmtQTyConName, decQTyConName, conQTyConName, strictTypeQTyConName,+ varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName,+ typeTyConName, tyVarBndrTyConName, matchTyConName, clauseTyConName,+ patQTyConName, fieldPatQTyConName, fieldExpQTyConName, funDepTyConName,+ predQTyConName, decsQTyConName, ruleBndrQTyConName, tySynEqnQTyConName,+ roleTyConName, tExpTyConName,++ -- Quasiquoting+ quoteDecName, quoteTypeName, quoteExpName, quotePatName]++thSyn, thLib, qqLib :: Module+thSyn = mkTHModule (fsLit "Language.Haskell.TH.Syntax")+thLib = mkTHModule (fsLit "Language.Haskell.TH.Lib")+qqLib = mkTHModule (fsLit "Language.Haskell.TH.Quote")++mkTHModule :: FastString -> Module+mkTHModule m = mkModule thPackageKey (mkModuleNameFS m)++libFun, libTc, thFun, thTc, thCon, qqFun :: FastString -> Unique -> Name+libFun = mk_known_key_name OccName.varName thLib+libTc = mk_known_key_name OccName.tcName thLib+thFun = mk_known_key_name OccName.varName thSyn+thTc = mk_known_key_name OccName.tcName thSyn+thCon = mk_known_key_name OccName.dataName thSyn+qqFun = mk_known_key_name OccName.varName qqLib++-------------------- TH.Syntax -----------------------+qTyConName, nameTyConName, fieldExpTyConName, patTyConName,+ fieldPatTyConName, expTyConName, decTyConName, typeTyConName,+ tyVarBndrTyConName, matchTyConName, clauseTyConName, funDepTyConName,+ predTyConName, tExpTyConName :: Name+qTyConName = thTc (fsLit "Q") qTyConKey+nameTyConName = thTc (fsLit "Name") nameTyConKey+fieldExpTyConName = thTc (fsLit "FieldExp") fieldExpTyConKey+patTyConName = thTc (fsLit "Pat") patTyConKey+fieldPatTyConName = thTc (fsLit "FieldPat") fieldPatTyConKey+expTyConName = thTc (fsLit "Exp") expTyConKey+decTyConName = thTc (fsLit "Dec") decTyConKey+typeTyConName = thTc (fsLit "Type") typeTyConKey+tyVarBndrTyConName= thTc (fsLit "TyVarBndr") tyVarBndrTyConKey+matchTyConName = thTc (fsLit "Match") matchTyConKey+clauseTyConName = thTc (fsLit "Clause") clauseTyConKey+funDepTyConName = thTc (fsLit "FunDep") funDepTyConKey+predTyConName = thTc (fsLit "Pred") predTyConKey+tExpTyConName = thTc (fsLit "TExp") tExpTyConKey++returnQName, bindQName, sequenceQName, newNameName, liftName,+ mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName,+ mkNameLName, liftStringName, unTypeName, unTypeQName,+ unsafeTExpCoerceName :: Name+returnQName = thFun (fsLit "returnQ") returnQIdKey+bindQName = thFun (fsLit "bindQ") bindQIdKey+sequenceQName = thFun (fsLit "sequenceQ") sequenceQIdKey+newNameName = thFun (fsLit "newName") newNameIdKey+liftName = thFun (fsLit "lift") liftIdKey+liftStringName = thFun (fsLit "liftString") liftStringIdKey+mkNameName = thFun (fsLit "mkName") mkNameIdKey+mkNameG_vName = thFun (fsLit "mkNameG_v") mkNameG_vIdKey+mkNameG_dName = thFun (fsLit "mkNameG_d") mkNameG_dIdKey+mkNameG_tcName = thFun (fsLit "mkNameG_tc") mkNameG_tcIdKey+mkNameLName = thFun (fsLit "mkNameL") mkNameLIdKey+unTypeName = thFun (fsLit "unType") unTypeIdKey+unTypeQName = thFun (fsLit "unTypeQ") unTypeQIdKey+unsafeTExpCoerceName = thFun (fsLit "unsafeTExpCoerce") unsafeTExpCoerceIdKey+++-------------------- TH.Lib -----------------------+-- data Lit = ...+charLName, stringLName, integerLName, intPrimLName, wordPrimLName,+ floatPrimLName, doublePrimLName, rationalLName :: Name+charLName = libFun (fsLit "charL") charLIdKey+stringLName = libFun (fsLit "stringL") stringLIdKey+integerLName = libFun (fsLit "integerL") integerLIdKey+intPrimLName = libFun (fsLit "intPrimL") intPrimLIdKey+wordPrimLName = libFun (fsLit "wordPrimL") wordPrimLIdKey+floatPrimLName = libFun (fsLit "floatPrimL") floatPrimLIdKey+doublePrimLName = libFun (fsLit "doublePrimL") doublePrimLIdKey+rationalLName = libFun (fsLit "rationalL") rationalLIdKey++-- data Pat = ...+litPName, varPName, tupPName, unboxedTupPName, conPName, infixPName, tildePName, bangPName,+ asPName, wildPName, recPName, listPName, sigPName, viewPName :: Name+litPName = libFun (fsLit "litP") litPIdKey+varPName = libFun (fsLit "varP") varPIdKey+tupPName = libFun (fsLit "tupP") tupPIdKey+unboxedTupPName = libFun (fsLit "unboxedTupP") unboxedTupPIdKey+conPName = libFun (fsLit "conP") conPIdKey+infixPName = libFun (fsLit "infixP") infixPIdKey+tildePName = libFun (fsLit "tildeP") tildePIdKey+bangPName = libFun (fsLit "bangP") bangPIdKey+asPName = libFun (fsLit "asP") asPIdKey+wildPName = libFun (fsLit "wildP") wildPIdKey+recPName = libFun (fsLit "recP") recPIdKey+listPName = libFun (fsLit "listP") listPIdKey+sigPName = libFun (fsLit "sigP") sigPIdKey+viewPName = libFun (fsLit "viewP") viewPIdKey++-- type FieldPat = ...+fieldPatName :: Name+fieldPatName = libFun (fsLit "fieldPat") fieldPatIdKey++-- data Match = ...+matchName :: Name+matchName = libFun (fsLit "match") matchIdKey++-- data Clause = ...+clauseName :: Name+clauseName = libFun (fsLit "clause") clauseIdKey++-- data Exp = ...+varEName, conEName, litEName, appEName, infixEName, infixAppName,+ sectionLName, sectionRName, lamEName, lamCaseEName, tupEName,+ unboxedTupEName, condEName, multiIfEName, letEName, caseEName,+ doEName, compEName, staticEName :: Name+varEName = libFun (fsLit "varE") varEIdKey+conEName = libFun (fsLit "conE") conEIdKey+litEName = libFun (fsLit "litE") litEIdKey+appEName = libFun (fsLit "appE") appEIdKey+infixEName = libFun (fsLit "infixE") infixEIdKey+infixAppName = libFun (fsLit "infixApp") infixAppIdKey+sectionLName = libFun (fsLit "sectionL") sectionLIdKey+sectionRName = libFun (fsLit "sectionR") sectionRIdKey+lamEName = libFun (fsLit "lamE") lamEIdKey+lamCaseEName = libFun (fsLit "lamCaseE") lamCaseEIdKey+tupEName = libFun (fsLit "tupE") tupEIdKey+unboxedTupEName = libFun (fsLit "unboxedTupE") unboxedTupEIdKey+condEName = libFun (fsLit "condE") condEIdKey+multiIfEName = libFun (fsLit "multiIfE") multiIfEIdKey+letEName = libFun (fsLit "letE") letEIdKey+caseEName = libFun (fsLit "caseE") caseEIdKey+doEName = libFun (fsLit "doE") doEIdKey+compEName = libFun (fsLit "compE") compEIdKey+-- ArithSeq skips a level+fromEName, fromThenEName, fromToEName, fromThenToEName :: Name+fromEName = libFun (fsLit "fromE") fromEIdKey+fromThenEName = libFun (fsLit "fromThenE") fromThenEIdKey+fromToEName = libFun (fsLit "fromToE") fromToEIdKey+fromThenToEName = libFun (fsLit "fromThenToE") fromThenToEIdKey+-- end ArithSeq+listEName, sigEName, recConEName, recUpdEName :: Name+listEName = libFun (fsLit "listE") listEIdKey+sigEName = libFun (fsLit "sigE") sigEIdKey+recConEName = libFun (fsLit "recConE") recConEIdKey+recUpdEName = libFun (fsLit "recUpdE") recUpdEIdKey+staticEName = libFun (fsLit "staticE") staticEIdKey++-- type FieldExp = ...+fieldExpName :: Name+fieldExpName = libFun (fsLit "fieldExp") fieldExpIdKey++-- data Body = ...+guardedBName, normalBName :: Name+guardedBName = libFun (fsLit "guardedB") guardedBIdKey+normalBName = libFun (fsLit "normalB") normalBIdKey++-- data Guard = ...+normalGEName, patGEName :: Name+normalGEName = libFun (fsLit "normalGE") normalGEIdKey+patGEName = libFun (fsLit "patGE") patGEIdKey++-- data Stmt = ...+bindSName, letSName, noBindSName, parSName :: Name+bindSName = libFun (fsLit "bindS") bindSIdKey+letSName = libFun (fsLit "letS") letSIdKey+noBindSName = libFun (fsLit "noBindS") noBindSIdKey+parSName = libFun (fsLit "parS") parSIdKey++-- data Dec = ...+funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,+ instanceDName, sigDName, forImpDName, pragInlDName, pragSpecDName,+ pragSpecInlDName, pragSpecInstDName, pragRuleDName, pragAnnDName,+ familyNoKindDName, standaloneDerivDName, defaultSigDName,+ familyKindDName, dataInstDName, newtypeInstDName, tySynInstDName,+ closedTypeFamilyKindDName, closedTypeFamilyNoKindDName,+ infixLDName, infixRDName, infixNDName, roleAnnotDName :: Name+funDName = libFun (fsLit "funD") funDIdKey+valDName = libFun (fsLit "valD") valDIdKey+dataDName = libFun (fsLit "dataD") dataDIdKey+newtypeDName = libFun (fsLit "newtypeD") newtypeDIdKey+tySynDName = libFun (fsLit "tySynD") tySynDIdKey+classDName = libFun (fsLit "classD") classDIdKey+instanceDName = libFun (fsLit "instanceD") instanceDIdKey+standaloneDerivDName+ = libFun (fsLit "standaloneDerivD") standaloneDerivDIdKey+sigDName = libFun (fsLit "sigD") sigDIdKey+defaultSigDName = libFun (fsLit "defaultSigD") defaultSigDIdKey+forImpDName = libFun (fsLit "forImpD") forImpDIdKey+pragInlDName = libFun (fsLit "pragInlD") pragInlDIdKey+pragSpecDName = libFun (fsLit "pragSpecD") pragSpecDIdKey+pragSpecInlDName = libFun (fsLit "pragSpecInlD") pragSpecInlDIdKey+pragSpecInstDName = libFun (fsLit "pragSpecInstD") pragSpecInstDIdKey+pragRuleDName = libFun (fsLit "pragRuleD") pragRuleDIdKey+pragAnnDName = libFun (fsLit "pragAnnD") pragAnnDIdKey+familyNoKindDName = libFun (fsLit "familyNoKindD") familyNoKindDIdKey+familyKindDName = libFun (fsLit "familyKindD") familyKindDIdKey+dataInstDName = libFun (fsLit "dataInstD") dataInstDIdKey+newtypeInstDName = libFun (fsLit "newtypeInstD") newtypeInstDIdKey+tySynInstDName = libFun (fsLit "tySynInstD") tySynInstDIdKey+closedTypeFamilyKindDName+ = libFun (fsLit "closedTypeFamilyKindD") closedTypeFamilyKindDIdKey+closedTypeFamilyNoKindDName+ = libFun (fsLit "closedTypeFamilyNoKindD") closedTypeFamilyNoKindDIdKey+infixLDName = libFun (fsLit "infixLD") infixLDIdKey+infixRDName = libFun (fsLit "infixRD") infixRDIdKey+infixNDName = libFun (fsLit "infixND") infixNDIdKey+roleAnnotDName = libFun (fsLit "roleAnnotD") roleAnnotDIdKey++-- type Ctxt = ...+cxtName :: Name+cxtName = libFun (fsLit "cxt") cxtIdKey++-- data Strict = ...+isStrictName, notStrictName, unpackedName :: Name+isStrictName = libFun (fsLit "isStrict") isStrictKey+notStrictName = libFun (fsLit "notStrict") notStrictKey+unpackedName = libFun (fsLit "unpacked") unpackedKey++-- data Con = ...+normalCName, recCName, infixCName, forallCName :: Name+normalCName = libFun (fsLit "normalC") normalCIdKey+recCName = libFun (fsLit "recC") recCIdKey+infixCName = libFun (fsLit "infixC") infixCIdKey+forallCName = libFun (fsLit "forallC") forallCIdKey++-- type StrictType = ...+strictTypeName :: Name+strictTypeName = libFun (fsLit "strictType") strictTKey++-- type VarStrictType = ...+varStrictTypeName :: Name+varStrictTypeName = libFun (fsLit "varStrictType") varStrictTKey++-- data Type = ...+forallTName, varTName, conTName, tupleTName, unboxedTupleTName, arrowTName,+ listTName, appTName, sigTName, equalityTName, litTName,+ promotedTName, promotedTupleTName,+ promotedNilTName, promotedConsTName :: Name+forallTName = libFun (fsLit "forallT") forallTIdKey+varTName = libFun (fsLit "varT") varTIdKey+conTName = libFun (fsLit "conT") conTIdKey+tupleTName = libFun (fsLit "tupleT") tupleTIdKey+unboxedTupleTName = libFun (fsLit "unboxedTupleT") unboxedTupleTIdKey+arrowTName = libFun (fsLit "arrowT") arrowTIdKey+listTName = libFun (fsLit "listT") listTIdKey+appTName = libFun (fsLit "appT") appTIdKey+sigTName = libFun (fsLit "sigT") sigTIdKey+equalityTName = libFun (fsLit "equalityT") equalityTIdKey+litTName = libFun (fsLit "litT") litTIdKey+promotedTName = libFun (fsLit "promotedT") promotedTIdKey+promotedTupleTName = libFun (fsLit "promotedTupleT") promotedTupleTIdKey+promotedNilTName = libFun (fsLit "promotedNilT") promotedNilTIdKey+promotedConsTName = libFun (fsLit "promotedConsT") promotedConsTIdKey++-- data TyLit = ...+numTyLitName, strTyLitName :: Name+numTyLitName = libFun (fsLit "numTyLit") numTyLitIdKey+strTyLitName = libFun (fsLit "strTyLit") strTyLitIdKey++-- data TyVarBndr = ...+plainTVName, kindedTVName :: Name+plainTVName = libFun (fsLit "plainTV") plainTVIdKey+kindedTVName = libFun (fsLit "kindedTV") kindedTVIdKey++-- data Role = ...+nominalRName, representationalRName, phantomRName, inferRName :: Name+nominalRName = libFun (fsLit "nominalR") nominalRIdKey+representationalRName = libFun (fsLit "representationalR") representationalRIdKey+phantomRName = libFun (fsLit "phantomR") phantomRIdKey+inferRName = libFun (fsLit "inferR") inferRIdKey++-- data Kind = ...+varKName, conKName, tupleKName, arrowKName, listKName, appKName,+ starKName, constraintKName :: Name+varKName = libFun (fsLit "varK") varKIdKey+conKName = libFun (fsLit "conK") conKIdKey+tupleKName = libFun (fsLit "tupleK") tupleKIdKey+arrowKName = libFun (fsLit "arrowK") arrowKIdKey+listKName = libFun (fsLit "listK") listKIdKey+appKName = libFun (fsLit "appK") appKIdKey+starKName = libFun (fsLit "starK") starKIdKey+constraintKName = libFun (fsLit "constraintK") constraintKIdKey++-- data Callconv = ...+cCallName, stdCallName, cApiCallName, primCallName, javaScriptCallName :: Name+cCallName = libFun (fsLit "cCall") cCallIdKey+stdCallName = libFun (fsLit "stdCall") stdCallIdKey+cApiCallName = libFun (fsLit "cApi") cApiCallIdKey+primCallName = libFun (fsLit "prim") primCallIdKey+javaScriptCallName = libFun (fsLit "javaScript") javaScriptCallIdKey++-- data Safety = ...+unsafeName, safeName, interruptibleName :: Name+unsafeName = libFun (fsLit "unsafe") unsafeIdKey+safeName = libFun (fsLit "safe") safeIdKey+interruptibleName = libFun (fsLit "interruptible") interruptibleIdKey++-- data Inline = ...+noInlineDataConName, inlineDataConName, inlinableDataConName :: Name+noInlineDataConName = thCon (fsLit "NoInline") noInlineDataConKey+inlineDataConName = thCon (fsLit "Inline") inlineDataConKey+inlinableDataConName = thCon (fsLit "Inlinable") inlinableDataConKey++-- data RuleMatch = ...+conLikeDataConName, funLikeDataConName :: Name+conLikeDataConName = thCon (fsLit "ConLike") conLikeDataConKey+funLikeDataConName = thCon (fsLit "FunLike") funLikeDataConKey++-- data Phases = ...+allPhasesDataConName, fromPhaseDataConName, beforePhaseDataConName :: Name+allPhasesDataConName = thCon (fsLit "AllPhases") allPhasesDataConKey+fromPhaseDataConName = thCon (fsLit "FromPhase") fromPhaseDataConKey+beforePhaseDataConName = thCon (fsLit "BeforePhase") beforePhaseDataConKey++-- newtype TExp a = ...+tExpDataConName :: Name+tExpDataConName = thCon (fsLit "TExp") tExpDataConKey++-- data RuleBndr = ...+ruleVarName, typedRuleVarName :: Name+ruleVarName = libFun (fsLit ("ruleVar")) ruleVarIdKey+typedRuleVarName = libFun (fsLit ("typedRuleVar")) typedRuleVarIdKey++-- data FunDep = ...+funDepName :: Name+funDepName = libFun (fsLit "funDep") funDepIdKey++-- data FamFlavour = ...+typeFamName, dataFamName :: Name+typeFamName = libFun (fsLit "typeFam") typeFamIdKey+dataFamName = libFun (fsLit "dataFam") dataFamIdKey++-- data TySynEqn = ...+tySynEqnName :: Name+tySynEqnName = libFun (fsLit "tySynEqn") tySynEqnIdKey++-- data AnnTarget = ...+valueAnnotationName, typeAnnotationName, moduleAnnotationName :: Name+valueAnnotationName = libFun (fsLit "valueAnnotation") valueAnnotationIdKey+typeAnnotationName = libFun (fsLit "typeAnnotation") typeAnnotationIdKey+moduleAnnotationName = libFun (fsLit "moduleAnnotation") moduleAnnotationIdKey++matchQTyConName, clauseQTyConName, expQTyConName, stmtQTyConName,+ decQTyConName, conQTyConName, strictTypeQTyConName,+ varStrictTypeQTyConName, typeQTyConName, fieldExpQTyConName,+ patQTyConName, fieldPatQTyConName, predQTyConName, decsQTyConName,+ ruleBndrQTyConName, tySynEqnQTyConName, roleTyConName :: Name+matchQTyConName = libTc (fsLit "MatchQ") matchQTyConKey+clauseQTyConName = libTc (fsLit "ClauseQ") clauseQTyConKey+expQTyConName = libTc (fsLit "ExpQ") expQTyConKey+stmtQTyConName = libTc (fsLit "StmtQ") stmtQTyConKey+decQTyConName = libTc (fsLit "DecQ") decQTyConKey+decsQTyConName = libTc (fsLit "DecsQ") decsQTyConKey -- Q [Dec]+conQTyConName = libTc (fsLit "ConQ") conQTyConKey+strictTypeQTyConName = libTc (fsLit "StrictTypeQ") strictTypeQTyConKey+varStrictTypeQTyConName = libTc (fsLit "VarStrictTypeQ") varStrictTypeQTyConKey+typeQTyConName = libTc (fsLit "TypeQ") typeQTyConKey+fieldExpQTyConName = libTc (fsLit "FieldExpQ") fieldExpQTyConKey+patQTyConName = libTc (fsLit "PatQ") patQTyConKey+fieldPatQTyConName = libTc (fsLit "FieldPatQ") fieldPatQTyConKey+predQTyConName = libTc (fsLit "PredQ") predQTyConKey+ruleBndrQTyConName = libTc (fsLit "RuleBndrQ") ruleBndrQTyConKey+tySynEqnQTyConName = libTc (fsLit "TySynEqnQ") tySynEqnQTyConKey+roleTyConName = libTc (fsLit "Role") roleTyConKey++-- quasiquoting+quoteExpName, quotePatName, quoteDecName, quoteTypeName :: Name+quoteExpName = qqFun (fsLit "quoteExp") quoteExpKey+quotePatName = qqFun (fsLit "quotePat") quotePatKey+quoteDecName = qqFun (fsLit "quoteDec") quoteDecKey+quoteTypeName = qqFun (fsLit "quoteType") quoteTypeKey++-- TyConUniques available: 200-299+-- Check in PrelNames if you want to change this++expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey,+ decQTyConKey, patTyConKey, matchQTyConKey, clauseQTyConKey,+ stmtQTyConKey, conQTyConKey, typeQTyConKey, typeTyConKey, tyVarBndrTyConKey,+ decTyConKey, varStrictTypeQTyConKey, strictTypeQTyConKey,+ fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey,+ fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey, predTyConKey,+ predQTyConKey, decsQTyConKey, ruleBndrQTyConKey, tySynEqnQTyConKey,+ roleTyConKey, tExpTyConKey :: Unique+expTyConKey = mkPreludeTyConUnique 200+matchTyConKey = mkPreludeTyConUnique 201+clauseTyConKey = mkPreludeTyConUnique 202+qTyConKey = mkPreludeTyConUnique 203+expQTyConKey = mkPreludeTyConUnique 204+decQTyConKey = mkPreludeTyConUnique 205+patTyConKey = mkPreludeTyConUnique 206+matchQTyConKey = mkPreludeTyConUnique 207+clauseQTyConKey = mkPreludeTyConUnique 208+stmtQTyConKey = mkPreludeTyConUnique 209+conQTyConKey = mkPreludeTyConUnique 210+typeQTyConKey = mkPreludeTyConUnique 211+typeTyConKey = mkPreludeTyConUnique 212+decTyConKey = mkPreludeTyConUnique 213+varStrictTypeQTyConKey = mkPreludeTyConUnique 214+strictTypeQTyConKey = mkPreludeTyConUnique 215+fieldExpTyConKey = mkPreludeTyConUnique 216+fieldPatTyConKey = mkPreludeTyConUnique 217+nameTyConKey = mkPreludeTyConUnique 218+patQTyConKey = mkPreludeTyConUnique 219+fieldPatQTyConKey = mkPreludeTyConUnique 220+fieldExpQTyConKey = mkPreludeTyConUnique 221+funDepTyConKey = mkPreludeTyConUnique 222+predTyConKey = mkPreludeTyConUnique 223+predQTyConKey = mkPreludeTyConUnique 224+tyVarBndrTyConKey = mkPreludeTyConUnique 225+decsQTyConKey = mkPreludeTyConUnique 226+ruleBndrQTyConKey = mkPreludeTyConUnique 227+tySynEqnQTyConKey = mkPreludeTyConUnique 228+roleTyConKey = mkPreludeTyConUnique 229+tExpTyConKey = mkPreludeTyConUnique 230++-- IdUniques available: 200-499+-- If you want to change this, make sure you check in PrelNames++returnQIdKey, bindQIdKey, sequenceQIdKey, liftIdKey, newNameIdKey,+ mkNameIdKey, mkNameG_vIdKey, mkNameG_dIdKey, mkNameG_tcIdKey,+ mkNameLIdKey, unTypeIdKey, unTypeQIdKey, unsafeTExpCoerceIdKey :: Unique+returnQIdKey = mkPreludeMiscIdUnique 200+bindQIdKey = mkPreludeMiscIdUnique 201+sequenceQIdKey = mkPreludeMiscIdUnique 202+liftIdKey = mkPreludeMiscIdUnique 203+newNameIdKey = mkPreludeMiscIdUnique 204+mkNameIdKey = mkPreludeMiscIdUnique 205+mkNameG_vIdKey = mkPreludeMiscIdUnique 206+mkNameG_dIdKey = mkPreludeMiscIdUnique 207+mkNameG_tcIdKey = mkPreludeMiscIdUnique 208+mkNameLIdKey = mkPreludeMiscIdUnique 209+unTypeIdKey = mkPreludeMiscIdUnique 210+unTypeQIdKey = mkPreludeMiscIdUnique 211+unsafeTExpCoerceIdKey = mkPreludeMiscIdUnique 212+++-- data Lit = ...+charLIdKey, stringLIdKey, integerLIdKey, intPrimLIdKey, wordPrimLIdKey,+ floatPrimLIdKey, doublePrimLIdKey, rationalLIdKey :: Unique+charLIdKey = mkPreludeMiscIdUnique 220+stringLIdKey = mkPreludeMiscIdUnique 221+integerLIdKey = mkPreludeMiscIdUnique 222+intPrimLIdKey = mkPreludeMiscIdUnique 223+wordPrimLIdKey = mkPreludeMiscIdUnique 224+floatPrimLIdKey = mkPreludeMiscIdUnique 225+doublePrimLIdKey = mkPreludeMiscIdUnique 226+rationalLIdKey = mkPreludeMiscIdUnique 227++liftStringIdKey :: Unique+liftStringIdKey = mkPreludeMiscIdUnique 228++-- data Pat = ...+litPIdKey, varPIdKey, tupPIdKey, unboxedTupPIdKey, conPIdKey, infixPIdKey, tildePIdKey, bangPIdKey,+ asPIdKey, wildPIdKey, recPIdKey, listPIdKey, sigPIdKey, viewPIdKey :: Unique+litPIdKey = mkPreludeMiscIdUnique 240+varPIdKey = mkPreludeMiscIdUnique 241+tupPIdKey = mkPreludeMiscIdUnique 242+unboxedTupPIdKey = mkPreludeMiscIdUnique 243+conPIdKey = mkPreludeMiscIdUnique 244+infixPIdKey = mkPreludeMiscIdUnique 245+tildePIdKey = mkPreludeMiscIdUnique 246+bangPIdKey = mkPreludeMiscIdUnique 247+asPIdKey = mkPreludeMiscIdUnique 248+wildPIdKey = mkPreludeMiscIdUnique 249+recPIdKey = mkPreludeMiscIdUnique 250+listPIdKey = mkPreludeMiscIdUnique 251+sigPIdKey = mkPreludeMiscIdUnique 252+viewPIdKey = mkPreludeMiscIdUnique 253++-- type FieldPat = ...+fieldPatIdKey :: Unique+fieldPatIdKey = mkPreludeMiscIdUnique 260++-- data Match = ...+matchIdKey :: Unique+matchIdKey = mkPreludeMiscIdUnique 261++-- data Clause = ...+clauseIdKey :: Unique+clauseIdKey = mkPreludeMiscIdUnique 262+++-- data Exp = ...+varEIdKey, conEIdKey, litEIdKey, appEIdKey, infixEIdKey, infixAppIdKey,+ sectionLIdKey, sectionRIdKey, lamEIdKey, lamCaseEIdKey, tupEIdKey,+ unboxedTupEIdKey, condEIdKey, multiIfEIdKey,+ letEIdKey, caseEIdKey, doEIdKey, compEIdKey,+ fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey,+ listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey, staticEIdKey :: Unique+varEIdKey = mkPreludeMiscIdUnique 270+conEIdKey = mkPreludeMiscIdUnique 271+litEIdKey = mkPreludeMiscIdUnique 272+appEIdKey = mkPreludeMiscIdUnique 273+infixEIdKey = mkPreludeMiscIdUnique 274+infixAppIdKey = mkPreludeMiscIdUnique 275+sectionLIdKey = mkPreludeMiscIdUnique 276+sectionRIdKey = mkPreludeMiscIdUnique 277+lamEIdKey = mkPreludeMiscIdUnique 278+lamCaseEIdKey = mkPreludeMiscIdUnique 279+tupEIdKey = mkPreludeMiscIdUnique 280+unboxedTupEIdKey = mkPreludeMiscIdUnique 281+condEIdKey = mkPreludeMiscIdUnique 282+multiIfEIdKey = mkPreludeMiscIdUnique 283+letEIdKey = mkPreludeMiscIdUnique 284+caseEIdKey = mkPreludeMiscIdUnique 285+doEIdKey = mkPreludeMiscIdUnique 286+compEIdKey = mkPreludeMiscIdUnique 287+fromEIdKey = mkPreludeMiscIdUnique 288+fromThenEIdKey = mkPreludeMiscIdUnique 289+fromToEIdKey = mkPreludeMiscIdUnique 290+fromThenToEIdKey = mkPreludeMiscIdUnique 291+listEIdKey = mkPreludeMiscIdUnique 292+sigEIdKey = mkPreludeMiscIdUnique 293+recConEIdKey = mkPreludeMiscIdUnique 294+recUpdEIdKey = mkPreludeMiscIdUnique 295+staticEIdKey = mkPreludeMiscIdUnique 296++-- type FieldExp = ...+fieldExpIdKey :: Unique+fieldExpIdKey = mkPreludeMiscIdUnique 310++-- data Body = ...+guardedBIdKey, normalBIdKey :: Unique+guardedBIdKey = mkPreludeMiscIdUnique 311+normalBIdKey = mkPreludeMiscIdUnique 312++-- data Guard = ...+normalGEIdKey, patGEIdKey :: Unique+normalGEIdKey = mkPreludeMiscIdUnique 313+patGEIdKey = mkPreludeMiscIdUnique 314++-- data Stmt = ...+bindSIdKey, letSIdKey, noBindSIdKey, parSIdKey :: Unique+bindSIdKey = mkPreludeMiscIdUnique 320+letSIdKey = mkPreludeMiscIdUnique 321+noBindSIdKey = mkPreludeMiscIdUnique 322+parSIdKey = mkPreludeMiscIdUnique 323++-- data Dec = ...+funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey,+ classDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey, pragInlDIdKey,+ pragSpecDIdKey, pragSpecInlDIdKey, pragSpecInstDIdKey, pragRuleDIdKey,+ pragAnnDIdKey, familyNoKindDIdKey, familyKindDIdKey, defaultSigDIdKey,+ dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey, standaloneDerivDIdKey,+ closedTypeFamilyKindDIdKey, closedTypeFamilyNoKindDIdKey,+ infixLDIdKey, infixRDIdKey, infixNDIdKey, roleAnnotDIdKey :: Unique+funDIdKey = mkPreludeMiscIdUnique 330+valDIdKey = mkPreludeMiscIdUnique 331+dataDIdKey = mkPreludeMiscIdUnique 332+newtypeDIdKey = mkPreludeMiscIdUnique 333+tySynDIdKey = mkPreludeMiscIdUnique 334+classDIdKey = mkPreludeMiscIdUnique 335+instanceDIdKey = mkPreludeMiscIdUnique 336+sigDIdKey = mkPreludeMiscIdUnique 337+forImpDIdKey = mkPreludeMiscIdUnique 338+pragInlDIdKey = mkPreludeMiscIdUnique 339+pragSpecDIdKey = mkPreludeMiscIdUnique 340+pragSpecInlDIdKey = mkPreludeMiscIdUnique 341+pragSpecInstDIdKey = mkPreludeMiscIdUnique 342+pragRuleDIdKey = mkPreludeMiscIdUnique 343+pragAnnDIdKey = mkPreludeMiscIdUnique 344+familyNoKindDIdKey = mkPreludeMiscIdUnique 345+familyKindDIdKey = mkPreludeMiscIdUnique 346+dataInstDIdKey = mkPreludeMiscIdUnique 347+newtypeInstDIdKey = mkPreludeMiscIdUnique 348+tySynInstDIdKey = mkPreludeMiscIdUnique 349+closedTypeFamilyKindDIdKey = mkPreludeMiscIdUnique 350+closedTypeFamilyNoKindDIdKey = mkPreludeMiscIdUnique 351+infixLDIdKey = mkPreludeMiscIdUnique 352+infixRDIdKey = mkPreludeMiscIdUnique 353+infixNDIdKey = mkPreludeMiscIdUnique 354+roleAnnotDIdKey = mkPreludeMiscIdUnique 355+standaloneDerivDIdKey = mkPreludeMiscIdUnique 356+defaultSigDIdKey = mkPreludeMiscIdUnique 357++-- type Cxt = ...+cxtIdKey :: Unique+cxtIdKey = mkPreludeMiscIdUnique 360++-- data Strict = ...+isStrictKey, notStrictKey, unpackedKey :: Unique+isStrictKey = mkPreludeMiscIdUnique 363+notStrictKey = mkPreludeMiscIdUnique 364+unpackedKey = mkPreludeMiscIdUnique 365++-- data Con = ...+normalCIdKey, recCIdKey, infixCIdKey, forallCIdKey :: Unique+normalCIdKey = mkPreludeMiscIdUnique 370+recCIdKey = mkPreludeMiscIdUnique 371+infixCIdKey = mkPreludeMiscIdUnique 372+forallCIdKey = mkPreludeMiscIdUnique 373++-- type StrictType = ...+strictTKey :: Unique+strictTKey = mkPreludeMiscIdUnique 374++-- type VarStrictType = ...+varStrictTKey :: Unique+varStrictTKey = mkPreludeMiscIdUnique 375++-- data Type = ...+forallTIdKey, varTIdKey, conTIdKey, tupleTIdKey, unboxedTupleTIdKey, arrowTIdKey,+ listTIdKey, appTIdKey, sigTIdKey, equalityTIdKey, litTIdKey,+ promotedTIdKey, promotedTupleTIdKey,+ promotedNilTIdKey, promotedConsTIdKey :: Unique+forallTIdKey = mkPreludeMiscIdUnique 380+varTIdKey = mkPreludeMiscIdUnique 381+conTIdKey = mkPreludeMiscIdUnique 382+tupleTIdKey = mkPreludeMiscIdUnique 383+unboxedTupleTIdKey = mkPreludeMiscIdUnique 384+arrowTIdKey = mkPreludeMiscIdUnique 385+listTIdKey = mkPreludeMiscIdUnique 386+appTIdKey = mkPreludeMiscIdUnique 387+sigTIdKey = mkPreludeMiscIdUnique 388+equalityTIdKey = mkPreludeMiscIdUnique 389+litTIdKey = mkPreludeMiscIdUnique 390+promotedTIdKey = mkPreludeMiscIdUnique 391+promotedTupleTIdKey = mkPreludeMiscIdUnique 392+promotedNilTIdKey = mkPreludeMiscIdUnique 393+promotedConsTIdKey = mkPreludeMiscIdUnique 394++-- data TyLit = ...+numTyLitIdKey, strTyLitIdKey :: Unique+numTyLitIdKey = mkPreludeMiscIdUnique 395+strTyLitIdKey = mkPreludeMiscIdUnique 396++-- data TyVarBndr = ...+plainTVIdKey, kindedTVIdKey :: Unique+plainTVIdKey = mkPreludeMiscIdUnique 397+kindedTVIdKey = mkPreludeMiscIdUnique 398++-- data Role = ...+nominalRIdKey, representationalRIdKey, phantomRIdKey, inferRIdKey :: Unique+nominalRIdKey = mkPreludeMiscIdUnique 400+representationalRIdKey = mkPreludeMiscIdUnique 401+phantomRIdKey = mkPreludeMiscIdUnique 402+inferRIdKey = mkPreludeMiscIdUnique 403++-- data Kind = ...+varKIdKey, conKIdKey, tupleKIdKey, arrowKIdKey, listKIdKey, appKIdKey,+ starKIdKey, constraintKIdKey :: Unique+varKIdKey = mkPreludeMiscIdUnique 404+conKIdKey = mkPreludeMiscIdUnique 405+tupleKIdKey = mkPreludeMiscIdUnique 406+arrowKIdKey = mkPreludeMiscIdUnique 407+listKIdKey = mkPreludeMiscIdUnique 408+appKIdKey = mkPreludeMiscIdUnique 409+starKIdKey = mkPreludeMiscIdUnique 410+constraintKIdKey = mkPreludeMiscIdUnique 411++-- data Callconv = ...+cCallIdKey, stdCallIdKey, cApiCallIdKey, primCallIdKey,+ javaScriptCallIdKey :: Unique+cCallIdKey = mkPreludeMiscIdUnique 420+stdCallIdKey = mkPreludeMiscIdUnique 421+cApiCallIdKey = mkPreludeMiscIdUnique 422+primCallIdKey = mkPreludeMiscIdUnique 423+javaScriptCallIdKey = mkPreludeMiscIdUnique 424++-- data Safety = ...+unsafeIdKey, safeIdKey, interruptibleIdKey :: Unique+unsafeIdKey = mkPreludeMiscIdUnique 430+safeIdKey = mkPreludeMiscIdUnique 431+interruptibleIdKey = mkPreludeMiscIdUnique 432++-- data Inline = ...+noInlineDataConKey, inlineDataConKey, inlinableDataConKey :: Unique+noInlineDataConKey = mkPreludeDataConUnique 40+inlineDataConKey = mkPreludeDataConUnique 41+inlinableDataConKey = mkPreludeDataConUnique 42++-- data RuleMatch = ...+conLikeDataConKey, funLikeDataConKey :: Unique+conLikeDataConKey = mkPreludeDataConUnique 43+funLikeDataConKey = mkPreludeDataConUnique 44++-- data Phases = ...+allPhasesDataConKey, fromPhaseDataConKey, beforePhaseDataConKey :: Unique+allPhasesDataConKey = mkPreludeDataConUnique 45+fromPhaseDataConKey = mkPreludeDataConUnique 46+beforePhaseDataConKey = mkPreludeDataConUnique 47++-- newtype TExp a = ...+tExpDataConKey :: Unique+tExpDataConKey = mkPreludeDataConUnique 48++-- data FunDep = ...+funDepIdKey :: Unique+funDepIdKey = mkPreludeMiscIdUnique 440++-- data FamFlavour = ...+typeFamIdKey, dataFamIdKey :: Unique+typeFamIdKey = mkPreludeMiscIdUnique 450+dataFamIdKey = mkPreludeMiscIdUnique 451++-- data TySynEqn = ...+tySynEqnIdKey :: Unique+tySynEqnIdKey = mkPreludeMiscIdUnique 460++-- quasiquoting+quoteExpKey, quotePatKey, quoteDecKey, quoteTypeKey :: Unique+quoteExpKey = mkPreludeMiscIdUnique 470+quotePatKey = mkPreludeMiscIdUnique 471+quoteDecKey = mkPreludeMiscIdUnique 472+quoteTypeKey = mkPreludeMiscIdUnique 473++-- data RuleBndr = ...+ruleVarIdKey, typedRuleVarIdKey :: Unique+ruleVarIdKey = mkPreludeMiscIdUnique 480+typedRuleVarIdKey = mkPreludeMiscIdUnique 481++-- data AnnTarget = ...+valueAnnotationIdKey, typeAnnotationIdKey, moduleAnnotationIdKey :: Unique+valueAnnotationIdKey = mkPreludeMiscIdUnique 490+typeAnnotationIdKey = mkPreludeMiscIdUnique 491+moduleAnnotationIdKey = mkPreludeMiscIdUnique 492
+ src/Language/Haskell/Liquid/Desugar710/DsUtils.hs view
@@ -0,0 +1,838 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++Utilities for desugaring++This module exports some utility functions of no great interest.+-}++{-# LANGUAGE CPP #-}++-- | Utility functions for constructing Core syntax, principally for desugaring+module Language.Haskell.Liquid.Desugar710.DsUtils (+ EquationInfo(..),+ firstPat, shiftEqns,++ MatchResult(..), CanItFail(..), CaseAlt(..),+ cantFailMatchResult, alwaysFailMatchResult,+ extractMatchResult, combineMatchResults,+ adjustMatchResult, adjustMatchResultDs,+ mkCoLetMatchResult, mkViewMatchResult, mkGuardedMatchResult,+ matchCanFail, mkEvalMatchResult,+ mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult, mkCoSynCaseMatchResult,+ wrapBind, wrapBinds,++ mkErrorAppDs, mkCoreAppDs, mkCoreAppsDs, mkCastDs,++ seqVar,++ -- LHs tuples+ mkLHsVarPatTup, mkLHsPatTup, mkVanillaTuplePat,+ mkBigLHsVarTup, mkBigLHsTup, mkBigLHsVarPatTup, mkBigLHsPatTup,++ mkSelectorBinds,++ selectSimpleMatchVarL, selectMatchVars, selectMatchVar,+ mkOptTickBox, mkBinaryTickBox+ ) where++-- #include "HsVersions.h"++import {-# SOURCE #-} Language.Haskell.Liquid.Desugar710.Match ( matchSimply )++import HsSyn+import TcHsSyn+import Coercion( Coercion, isReflCo )+import TcType( tcSplitTyConApp )+import CoreSyn+import DsMonad+import {-# SOURCE #-} Language.Haskell.Liquid.Desugar710.DsExpr ( dsLExpr )++import CoreUtils+import MkCore+import MkId+import Id+import Literal+import TyCon+import ConLike+import DataCon+import PatSyn+import Type+import TysPrim+import TysWiredIn+import BasicTypes+import UniqSet+import UniqSupply+import Module+import PrelNames+import Outputable+import SrcLoc+import Util+import DynFlags+import FastString++import TcEvidence++import Control.Monad ( zipWithM )++{-+************************************************************************+* *+\subsection{ Selecting match variables}+* *+************************************************************************++We're about to match against some patterns. We want to make some+@Ids@ to use as match variables. If a pattern has an @Id@ readily at+hand, which should indeed be bound to the pattern as a whole, then use it;+otherwise, make one up.+-}++selectSimpleMatchVarL :: LPat Id -> DsM Id+selectSimpleMatchVarL pat = selectMatchVar (unLoc pat)++-- (selectMatchVars ps tys) chooses variables of type tys+-- to use for matching ps against. If the pattern is a variable,+-- we try to use that, to save inventing lots of fresh variables.+--+-- OLD, but interesting note:+-- But even if it is a variable, its type might not match. Consider+-- data T a where+-- T1 :: Int -> T Int+-- T2 :: a -> T a+--+-- f :: T a -> a -> Int+-- f (T1 i) (x::Int) = x+-- f (T2 i) (y::a) = 0+-- Then we must not choose (x::Int) as the matching variable!+-- And nowadays we won't, because the (x::Int) will be wrapped in a CoPat++selectMatchVars :: [Pat Id] -> DsM [Id]+selectMatchVars ps = mapM selectMatchVar ps++selectMatchVar :: Pat Id -> DsM Id+selectMatchVar (BangPat pat) = selectMatchVar (unLoc pat)+selectMatchVar (LazyPat pat) = selectMatchVar (unLoc pat)+selectMatchVar (ParPat pat) = selectMatchVar (unLoc pat)+selectMatchVar (VarPat var) = return (localiseId var) -- Note [Localise pattern binders]+selectMatchVar (AsPat var _) = return (unLoc var)+selectMatchVar other_pat = newSysLocalDs (hsPatType other_pat)+ -- OK, better make up one...++{-+Note [Localise pattern binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider module M where+ [Just a] = e+After renaming it looks like+ module M where+ [Just M.a] = e++We don't generalise, since it's a pattern binding, monomorphic, etc,+so after desugaring we may get something like+ M.a = case e of (v:_) ->+ case v of Just M.a -> M.a+Notice the "M.a" in the pattern; after all, it was in the original+pattern. However, after optimisation those pattern binders can become+let-binders, and then end up floated to top level. They have a+different *unique* by then (the simplifier is good about maintaining+proper scoping), but it's BAD to have two top-level bindings with the+External Name M.a, because that turns into two linker symbols for M.a.+It's quite rare for this to actually *happen* -- the only case I know+of is tc003 compiled with the 'hpc' way -- but that only makes it+all the more annoying.++To avoid this, we craftily call 'localiseId' in the desugarer, which+simply turns the External Name for the Id into an Internal one, but+doesn't change the unique. So the desugarer produces this:+ M.a{r8} = case e of (v:_) ->+ case v of Just a{r8} -> M.a{r8}+The unique is still 'r8', but the binding site in the pattern+is now an Internal Name. Now the simplifier's usual mechanisms+will propagate that Name to all the occurrence sites, as well as+un-shadowing it, so we'll get+ M.a{r8} = case e of (v:_) ->+ case v of Just a{s77} -> a{s77}+In fact, even CoreSubst.simplOptExpr will do this, and simpleOptExpr+runs on the output of the desugarer, so all is well by the end of+the desugaring pass.+++************************************************************************+* *+* type synonym EquationInfo and access functions for its pieces *+* *+************************************************************************+\subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym}++The ``equation info'' used by @match@ is relatively complicated and+worthy of a type synonym and a few handy functions.+-}++firstPat :: EquationInfo -> Pat Id+firstPat eqn = {- ASSERT( notNull (eqn_pats eqn) ) -} head (eqn_pats eqn)++shiftEqns :: [EquationInfo] -> [EquationInfo]+-- Drop the first pattern in each equation+shiftEqns eqns = [ eqn { eqn_pats = tail (eqn_pats eqn) } | eqn <- eqns ]++-- Functions on MatchResults++matchCanFail :: MatchResult -> Bool+matchCanFail (MatchResult CanFail _) = True+matchCanFail (MatchResult CantFail _) = False++alwaysFailMatchResult :: MatchResult+alwaysFailMatchResult = MatchResult CanFail (\fail -> return fail)++cantFailMatchResult :: CoreExpr -> MatchResult+cantFailMatchResult expr = MatchResult CantFail (\_ -> return expr)++extractMatchResult :: MatchResult -> CoreExpr -> DsM CoreExpr+extractMatchResult (MatchResult CantFail match_fn) _+ = match_fn (error "It can't fail!")++extractMatchResult (MatchResult CanFail match_fn) fail_expr = do+ (fail_bind, if_it_fails) <- mkFailurePair fail_expr+ body <- match_fn if_it_fails+ return (mkCoreLet fail_bind body)+++combineMatchResults :: MatchResult -> MatchResult -> MatchResult+combineMatchResults (MatchResult CanFail body_fn1)+ (MatchResult can_it_fail2 body_fn2)+ = MatchResult can_it_fail2 body_fn+ where+ body_fn fail = do body2 <- body_fn2 fail+ (fail_bind, duplicatable_expr) <- mkFailurePair body2+ body1 <- body_fn1 duplicatable_expr+ return (Let fail_bind body1)++combineMatchResults match_result1@(MatchResult CantFail _) _+ = match_result1++adjustMatchResult :: DsWrapper -> MatchResult -> MatchResult+adjustMatchResult encl_fn (MatchResult can_it_fail body_fn)+ = MatchResult can_it_fail (\fail -> encl_fn <$> body_fn fail)++adjustMatchResultDs :: (CoreExpr -> DsM CoreExpr) -> MatchResult -> MatchResult+adjustMatchResultDs encl_fn (MatchResult can_it_fail body_fn)+ = MatchResult can_it_fail (\fail -> encl_fn =<< body_fn fail)++wrapBinds :: [(Var,Var)] -> CoreExpr -> CoreExpr+wrapBinds [] e = e+wrapBinds ((new,old):prs) e = wrapBind new old (wrapBinds prs e)++wrapBind :: Var -> Var -> CoreExpr -> CoreExpr+wrapBind new old body -- NB: this function must deal with term+ | new==old = body -- variables, type variables or coercion variables+ | otherwise = Let (NonRec new (varToCoreExpr old)) body++seqVar :: Var -> CoreExpr -> CoreExpr+seqVar var body = Case (Var var) var (exprType body)+ [(DEFAULT, [], body)]++mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult+mkCoLetMatchResult bind = adjustMatchResult (mkCoreLet bind)++-- (mkViewMatchResult var' viewExpr var mr) makes the expression+-- let var' = viewExpr var in mr+mkViewMatchResult :: Id -> CoreExpr -> Id -> MatchResult -> MatchResult+mkViewMatchResult var' viewExpr var =+ adjustMatchResult (mkCoreLet (NonRec var' (mkCoreAppDs viewExpr (Var var))))++mkEvalMatchResult :: Id -> Type -> MatchResult -> MatchResult+mkEvalMatchResult var ty+ = adjustMatchResult (\e -> Case (Var var) var ty [(DEFAULT, [], e)])++mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult+mkGuardedMatchResult pred_expr (MatchResult _ body_fn)+ = MatchResult CanFail (\fail -> do body <- body_fn fail+ return (mkIfThenElse pred_expr body fail))++mkCoPrimCaseMatchResult :: Id -- Scrutinee+ -> Type -- Type of the case+ -> [(Literal, MatchResult)] -- Alternatives+ -> MatchResult -- Literals are all unlifted+mkCoPrimCaseMatchResult var ty match_alts+ = MatchResult CanFail mk_case+ where+ mk_case fail = do+ alts <- mapM (mk_alt fail) sorted_alts+ return (Case (Var var) var ty ((DEFAULT, [], fail) : alts))++ sorted_alts = sortWith fst match_alts -- Right order for a Case+ mk_alt fail (lit, MatchResult _ body_fn)+ = -- ASSERT( not (litIsLifted lit) )+ do body <- body_fn fail+ return (LitAlt lit, [], body)++data CaseAlt a = MkCaseAlt{ alt_pat :: a,+ alt_bndrs :: [CoreBndr],+ alt_wrapper :: HsWrapper,+ alt_result :: MatchResult }++mkCoAlgCaseMatchResult+ :: DynFlags+ -> Id -- Scrutinee+ -> Type -- Type of exp+ -> [CaseAlt DataCon] -- Alternatives (bndrs *include* tyvars, dicts)+ -> MatchResult+mkCoAlgCaseMatchResult dflags var ty match_alts+ | isNewtype -- Newtype case; use a let+ = -- ASSERT( null (tail match_alts) && null (tail arg_ids1) )+ mkCoLetMatchResult (NonRec arg_id1 newtype_rhs) match_result1++ | isPArrFakeAlts match_alts+ = MatchResult CanFail $ mkPArrCase dflags var ty (sort_alts match_alts)+ | otherwise+ = mkDataConCase var ty match_alts+ where+ isNewtype = isNewTyCon (dataConTyCon (alt_pat alt1))++ -- [Interesting: because of GADTs, we can't rely on the type of+ -- the scrutinised Id to be sufficiently refined to have a TyCon in it]++ alt1@MkCaseAlt{ alt_bndrs = arg_ids1, alt_result = match_result1 }+ = {- ASSERT( notNull match_alts ) -} head match_alts+ -- Stuff for newtype+ arg_id1 = {- ASSERT( notNull arg_ids1 ) -} head arg_ids1+ var_ty = idType var+ (tc, ty_args) = tcSplitTyConApp var_ty -- Don't look through newtypes+ -- (not that splitTyConApp does, these days)+ newtype_rhs = unwrapNewTypeBody tc ty_args (Var var)++ --- Stuff for parallel arrays+ --+ -- Concerning `isPArrFakeAlts':+ --+ -- * it is *not* sufficient to just check the type of the type+ -- constructor, as we have to be careful not to confuse the real+ -- representation of parallel arrays with the fake constructors;+ -- moreover, a list of alternatives must not mix fake and real+ -- constructors (this is checked earlier on)+ --+ -- FIXME: We actually go through the whole list and make sure that+ -- either all or none of the constructors are fake parallel+ -- array constructors. This is to spot equations that mix fake+ -- constructors with the real representation defined in+ -- `PrelPArr'. It would be nicer to spot this situation+ -- earlier and raise a proper error message, but it can really+ -- only happen in `PrelPArr' anyway.+ --++ isPArrFakeAlts :: [CaseAlt DataCon] -> Bool+ isPArrFakeAlts [alt] = isPArrFakeCon (alt_pat alt)+ isPArrFakeAlts (alt:alts) =+ case (isPArrFakeCon (alt_pat alt), isPArrFakeAlts alts) of+ (True , True ) -> True+ (False, False) -> False+ _ -> panic "DsUtils: you may not mix `[:...:]' with `PArr' patterns"+ isPArrFakeAlts [] = panic "DsUtils: unexpectedly found an empty list of PArr fake alternatives"++mkCoSynCaseMatchResult :: Id -> Type -> CaseAlt PatSyn -> MatchResult+mkCoSynCaseMatchResult var ty alt = MatchResult CanFail $ mkPatSynCase var ty alt++sort_alts :: [CaseAlt DataCon] -> [CaseAlt DataCon]+sort_alts = sortWith (dataConTag . alt_pat)++mkPatSynCase :: Id -> Type -> CaseAlt PatSyn -> CoreExpr -> DsM CoreExpr+mkPatSynCase var ty alt fail = do+ matcher <- dsLExpr $ mkLHsWrap wrapper $ nlHsTyApp matcher [ty]+ let MatchResult _ mkCont = match_result+ cont <- mkCoreLams bndrs <$> mkCont fail+ return $ mkCoreAppsDs matcher [Var var, ensure_unstrict cont, Lam voidArgId fail]+ where+ MkCaseAlt{ alt_pat = psyn,+ alt_bndrs = bndrs,+ alt_wrapper = wrapper,+ alt_result = match_result} = alt+ (matcher, needs_void_lam) = patSynMatcher psyn++ -- See Note [Matchers and builders for pattern synonyms] in PatSyns+ -- on these extra Void# arguments+ ensure_unstrict cont | needs_void_lam = Lam voidArgId cont+ | otherwise = cont++mkDataConCase :: Id -> Type -> [CaseAlt DataCon] -> MatchResult+mkDataConCase _ _ [] = panic "mkDataConCase: no alternatives"+mkDataConCase var ty alts@(alt1:_) = MatchResult fail_flag mk_case+ where+ con1 = alt_pat alt1+ tycon = dataConTyCon con1+ data_cons = tyConDataCons tycon+ match_results = map alt_result alts++ sorted_alts :: [CaseAlt DataCon]+ sorted_alts = sort_alts alts++ var_ty = idType var+ (_, ty_args) = tcSplitTyConApp var_ty -- Don't look through newtypes+ -- (not that splitTyConApp does, these days)++ mk_case :: CoreExpr -> DsM CoreExpr+ mk_case fail = do+ alts <- mapM (mk_alt fail) sorted_alts+ return $ mkWildCase (Var var) (idType var) ty (mk_default fail ++ alts)++ mk_alt :: CoreExpr -> CaseAlt DataCon -> DsM CoreAlt+ mk_alt fail MkCaseAlt{ alt_pat = con,+ alt_bndrs = args,+ alt_result = MatchResult _ body_fn }+ = do { body <- body_fn fail+ ; case dataConBoxer con of {+ Nothing -> return (DataAlt con, args, body) ;+ Just (DCB boxer) ->+ do { us <- newUniqueSupply+ ; let (rep_ids, binds) = initUs_ us (boxer ty_args args)+ ; return (DataAlt con, rep_ids, mkLets binds body) } } }++ mk_default :: CoreExpr -> [CoreAlt]+ mk_default fail | exhaustive_case = []+ | otherwise = [(DEFAULT, [], fail)]++ fail_flag :: CanItFail+ fail_flag | exhaustive_case+ = foldr orFail CantFail [can_it_fail | MatchResult can_it_fail _ <- match_results]+ | otherwise+ = CanFail++ mentioned_constructors = mkUniqSet $ map alt_pat alts+ un_mentioned_constructors+ = mkUniqSet data_cons `minusUniqSet` mentioned_constructors+ exhaustive_case = isEmptyUniqSet un_mentioned_constructors++--- Stuff for parallel arrays+--+-- * the following is to desugar cases over fake constructors for+-- parallel arrays, which are introduced by `tidy1' in the `PArrPat'+-- case+--+mkPArrCase :: DynFlags -> Id -> Type -> [CaseAlt DataCon] -> CoreExpr -> DsM CoreExpr+mkPArrCase dflags var ty sorted_alts fail = do+ lengthP <- dsDPHBuiltin lengthPVar+ alt <- unboxAlt+ return (mkWildCase (len lengthP) intTy ty [alt])+ where+ elemTy = case splitTyConApp (idType var) of+ (_, [elemTy]) -> elemTy+ _ -> panic panicMsg+ panicMsg = "DsUtils.mkCoAlgCaseMatchResult: not a parallel array?"+ len lengthP = mkApps (Var lengthP) [Type elemTy, Var var]+ --+ unboxAlt = do+ l <- newSysLocalDs intPrimTy+ indexP <- dsDPHBuiltin indexPVar+ alts <- mapM (mkAlt indexP) sorted_alts+ return (DataAlt intDataCon, [l], mkWildCase (Var l) intPrimTy ty (dft : alts))+ where+ dft = (DEFAULT, [], fail)++ --+ -- each alternative matches one array length (corresponding to one+ -- fake array constructor), so the match is on a literal; each+ -- alternative's body is extended by a local binding for each+ -- constructor argument, which are bound to array elements starting+ -- with the first+ --+ mkAlt indexP alt@MkCaseAlt{alt_result = MatchResult _ bodyFun} = do+ body <- bodyFun fail+ return (LitAlt lit, [], mkCoreLets binds body)+ where+ lit = MachInt $ toInteger (dataConSourceArity (alt_pat alt))+ binds = [NonRec arg (indexExpr i) | (i, arg) <- zip [1..] (alt_bndrs alt)]+ --+ indexExpr i = mkApps (Var indexP) [Type elemTy, Var var, mkIntExpr dflags i]++{-+************************************************************************+* *+\subsection{Desugarer's versions of some Core functions}+* *+************************************************************************+-}++mkErrorAppDs :: Id -- The error function+ -> Type -- Type to which it should be applied+ -> SDoc -- The error message string to pass+ -> DsM CoreExpr++mkErrorAppDs err_id ty msg = do+ src_loc <- getSrcSpanDs+ dflags <- getDynFlags+ let+ full_msg = showSDoc dflags (hcat [ppr src_loc, text "|", msg])+ core_msg = Lit (mkMachString full_msg)+ -- mkMachString returns a result of type String#+ return (mkApps (Var err_id) [Type ty, core_msg])++{-+'mkCoreAppDs' and 'mkCoreAppsDs' hand the special-case desugaring of 'seq'.++Note [Desugaring seq (1)] cf Trac #1031+~~~~~~~~~~~~~~~~~~~~~~~~~+ f x y = x `seq` (y `seq` (# x,y #))++The [CoreSyn let/app invariant] means that, other things being equal, because+the argument to the outer 'seq' has an unlifted type, we'll use call-by-value thus:++ f x y = case (y `seq` (# x,y #)) of v -> x `seq` v++But that is bad for two reasons:+ (a) we now evaluate y before x, and+ (b) we can't bind v to an unboxed pair++Seq is very, very special! So we recognise it right here, and desugar to+ case x of _ -> case y of _ -> (# x,y #)++Note [Desugaring seq (2)] cf Trac #2273+~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+ let chp = case b of { True -> fst x; False -> 0 }+ in chp `seq` ...chp...+Here the seq is designed to plug the space leak of retaining (snd x)+for too long.++If we rely on the ordinary inlining of seq, we'll get+ let chp = case b of { True -> fst x; False -> 0 }+ case chp of _ { I# -> ...chp... }++But since chp is cheap, and the case is an alluring contet, we'll+inline chp into the case scrutinee. Now there is only one use of chp,+so we'll inline a second copy. Alas, we've now ruined the purpose of+the seq, by re-introducing the space leak:+ case (case b of {True -> fst x; False -> 0}) of+ I# _ -> ...case b of {True -> fst x; False -> 0}...++We can try to avoid doing this by ensuring that the binder-swap in the+case happens, so we get his at an early stage:+ case chp of chp2 { I# -> ...chp2... }+But this is fragile. The real culprit is the source program. Perhaps we+should have said explicitly+ let !chp2 = chp in ...chp2...++But that's painful. So the code here does a little hack to make seq+more robust: a saturated application of 'seq' is turned *directly* into+the case expression, thus:+ x `seq` e2 ==> case x of x -> e2 -- Note shadowing!+ e1 `seq` e2 ==> case x of _ -> e2++So we desugar our example to:+ let chp = case b of { True -> fst x; False -> 0 }+ case chp of chp { I# -> ...chp... }+And now all is well.++The reason it's a hack is because if you define mySeq=seq, the hack+won't work on mySeq.++Note [Desugaring seq (3)] cf Trac #2409+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The isLocalId ensures that we don't turn+ True `seq` e+into+ case True of True { ... }+which stupidly tries to bind the datacon 'True'.+-}++mkCoreAppDs :: CoreExpr -> CoreExpr -> CoreExpr+mkCoreAppDs (Var f `App` Type ty1 `App` Type ty2 `App` arg1) arg2+ | f `hasKey` seqIdKey -- Note [Desugaring seq (1), (2)]+ = Case arg1 case_bndr ty2 [(DEFAULT,[],arg2)]+ where+ case_bndr = case arg1 of+ Var v1 | isLocalId v1 -> v1 -- Note [Desugaring seq (2) and (3)]+ _ -> mkWildValBinder ty1++mkCoreAppDs fun arg = mkCoreApp fun arg -- The rest is done in MkCore++mkCoreAppsDs :: CoreExpr -> [CoreExpr] -> CoreExpr+mkCoreAppsDs fun args = foldl mkCoreAppDs fun args++mkCastDs :: CoreExpr -> Coercion -> CoreExpr+-- We define a desugarer-specific verison of CoreUtils.mkCast,+-- because in the immediate output of the desugarer, we can have+-- apparently-mis-matched coercions: E.g.+-- let a = b+-- in (x :: a) |> (co :: b ~ Int)+-- Lint know about type-bindings for let and does not complain+-- So here we do not make the assertion checks that we make in+-- CoreUtils.mkCast; and we do less peephole optimisation too+mkCastDs e co | isReflCo co = e+ | otherwise = Cast e co++{-+************************************************************************+* *+\subsection[mkSelectorBind]{Make a selector bind}+* *+************************************************************************++This is used in various places to do with lazy patterns.+For each binder $b$ in the pattern, we create a binding:+\begin{verbatim}+ b = case v of pat' -> b'+\end{verbatim}+where @pat'@ is @pat@ with each binder @b@ cloned into @b'@.++ToDo: making these bindings should really depend on whether there's+much work to be done per binding. If the pattern is complex, it+should be de-mangled once, into a tuple (and then selected from).+Otherwise the demangling can be in-line in the bindings (as here).++Boring! Boring! One error message per binder. The above ToDo is+even more helpful. Something very similar happens for pattern-bound+expressions.++Note [mkSelectorBinds]+~~~~~~~~~~~~~~~~~~~~~~+Given p = e, where p binds x,y+we are going to make EITHER++EITHER (A) v = e (where v is fresh)+ x = case v of p -> x+ y = case v of p -> y++OR (B) t = case e of p -> (x,y)+ x = case t of (x,_) -> x+ y = case t of (_,y) -> y++We do (A) when+ * Matching the pattern is cheap so we don't mind+ doing it twice.+ * Or if the pattern binds only one variable (so we'll only+ match once)+ * AND the pattern can't fail (else we tiresomely get two inexhaustive+ pattern warning messages)++Otherwise we do (B). Really (A) is just an optimisation for very common+cases like+ Just x = e+ (p,q) = e+-}++mkSelectorBinds :: [[Tickish Id]] -- ticks to add, possibly+ -> LPat Id -- The pattern+ -> CoreExpr -- Expression to which the pattern is bound+ -> DsM [(Id,CoreExpr)]++mkSelectorBinds ticks (L _ (VarPat v)) val_expr+ = return [(v, case ticks of+ [t] -> mkOptTickBox t val_expr+ _ -> val_expr)]++mkSelectorBinds ticks pat val_expr+ | null binders+ = return []++ | isSingleton binders || is_simple_lpat pat+ -- See Note [mkSelectorBinds]+ = do { val_var <- newSysLocalDs (hsLPatType pat)+ -- Make up 'v' in Note [mkSelectorBinds]+ -- NB: give it the type of *pattern* p, not the type of the *rhs* e.+ -- This does not matter after desugaring, but there's a subtle+ -- issue with implicit parameters. Consider+ -- (x,y) = ?i+ -- Then, ?i is given type {?i :: Int}, a PredType, which is opaque+ -- to the desugarer. (Why opaque? Because newtypes have to be. Why+ -- does it get that type? So that when we abstract over it we get the+ -- right top-level type (?i::Int) => ...)+ --+ -- So to get the type of 'v', use the pattern not the rhs. Often more+ -- efficient too.++ -- For the error message we make one error-app, to avoid duplication.+ -- But we need it at different types, so we make it polymorphic:+ -- err_var = /\a. iRREFUT_PAT_ERR a "blah blah blah"+ ; err_app <- mkErrorAppDs iRREFUT_PAT_ERROR_ID alphaTy (ppr pat)+ ; err_var <- newSysLocalDs (mkForAllTy alphaTyVar alphaTy)+ ; binds <- zipWithM (mk_bind val_var err_var) ticks' binders+ ; return ( (val_var, val_expr) :+ (err_var, Lam alphaTyVar err_app) :+ binds ) }++ | otherwise+ = do { error_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID tuple_ty (ppr pat)+ ; tuple_expr <- matchSimply val_expr PatBindRhs pat local_tuple error_expr+ ; tuple_var <- newSysLocalDs tuple_ty+ ; let mk_tup_bind tick binder+ = (binder, mkOptTickBox tick $+ mkTupleSelector local_binders binder+ tuple_var (Var tuple_var))+ ; return ( (tuple_var, tuple_expr) : zipWith mk_tup_bind ticks' binders ) }+ where+ binders = collectPatBinders pat+ ticks' = ticks ++ repeat []++ local_binders = map localiseId binders -- See Note [Localise pattern binders]+ local_tuple = mkBigCoreVarTup binders+ tuple_ty = exprType local_tuple++ mk_bind scrut_var err_var tick bndr_var = do+ -- (mk_bind sv err_var) generates+ -- bv = case sv of { pat -> bv; other -> err_var @ type-of-bv }+ -- Remember, pat binds bv+ rhs_expr <- matchSimply (Var scrut_var) PatBindRhs pat+ (Var bndr_var) error_expr+ return (bndr_var, mkOptTickBox tick rhs_expr)+ where+ error_expr = Var err_var `App` Type (idType bndr_var)++ is_simple_lpat p = is_simple_pat (unLoc p)++ is_simple_pat (TuplePat ps Boxed _) = all is_triv_lpat ps+ is_simple_pat pat@(ConPatOut{}) = case unLoc (pat_con pat) of+ RealDataCon con -> isProductTyCon (dataConTyCon con)+ && all is_triv_lpat (hsConPatArgs (pat_args pat))+ PatSynCon _ -> False+ is_simple_pat (VarPat _) = True+ is_simple_pat (ParPat p) = is_simple_lpat p+ is_simple_pat _ = False++ is_triv_lpat p = is_triv_pat (unLoc p)++ is_triv_pat (VarPat _) = True+ is_triv_pat (WildPat _) = True+ is_triv_pat (ParPat p) = is_triv_lpat p+ is_triv_pat _ = False++{-+Creating big tuples and their types for full Haskell expressions.+They work over *Ids*, and create tuples replete with their types,+which is whey they are not in HsUtils.+-}++mkLHsPatTup :: [LPat Id] -> LPat Id+mkLHsPatTup [] = noLoc $ mkVanillaTuplePat [] Boxed+mkLHsPatTup [lpat] = lpat+mkLHsPatTup lpats = L (getLoc (head lpats)) $+ mkVanillaTuplePat lpats Boxed++mkLHsVarPatTup :: [Id] -> LPat Id+mkLHsVarPatTup bs = mkLHsPatTup (map nlVarPat bs)++mkVanillaTuplePat :: [OutPat Id] -> Boxity -> Pat Id+-- A vanilla tuple pattern simply gets its type from its sub-patterns+mkVanillaTuplePat pats box = TuplePat pats box (map hsLPatType pats)++-- The Big equivalents for the source tuple expressions+mkBigLHsVarTup :: [Id] -> LHsExpr Id+mkBigLHsVarTup ids = mkBigLHsTup (map nlHsVar ids)++mkBigLHsTup :: [LHsExpr Id] -> LHsExpr Id+mkBigLHsTup = mkChunkified mkLHsTupleExpr++-- The Big equivalents for the source tuple patterns+mkBigLHsVarPatTup :: [Id] -> LPat Id+mkBigLHsVarPatTup bs = mkBigLHsPatTup (map nlVarPat bs)++mkBigLHsPatTup :: [LPat Id] -> LPat Id+mkBigLHsPatTup = mkChunkified mkLHsPatTup++{-+************************************************************************+* *+\subsection[mkFailurePair]{Code for pattern-matching and other failures}+* *+************************************************************************++Generally, we handle pattern matching failure like this: let-bind a+fail-variable, and use that variable if the thing fails:+\begin{verbatim}+ let fail.33 = error "Help"+ in+ case x of+ p1 -> ...+ p2 -> fail.33+ p3 -> fail.33+ p4 -> ...+\end{verbatim}+Then+\begin{itemize}+\item+If the case can't fail, then there'll be no mention of @fail.33@, and the+simplifier will later discard it.++\item+If it can fail in only one way, then the simplifier will inline it.++\item+Only if it is used more than once will the let-binding remain.+\end{itemize}++There's a problem when the result of the case expression is of+unboxed type. Then the type of @fail.33@ is unboxed too, and+there is every chance that someone will change the let into a case:+\begin{verbatim}+ case error "Help" of+ fail.33 -> case ....+\end{verbatim}++which is of course utterly wrong. Rather than drop the condition that+only boxed types can be let-bound, we just turn the fail into a function+for the primitive case:+\begin{verbatim}+ let fail.33 :: Void -> Int#+ fail.33 = \_ -> error "Help"+ in+ case x of+ p1 -> ...+ p2 -> fail.33 void+ p3 -> fail.33 void+ p4 -> ...+\end{verbatim}++Now @fail.33@ is a function, so it can be let-bound.+-}++mkFailurePair :: CoreExpr -- Result type of the whole case expression+ -> DsM (CoreBind, -- Binds the newly-created fail variable+ -- to \ _ -> expression+ CoreExpr) -- Fail variable applied to realWorld#+-- See Note [Failure thunks and CPR]+mkFailurePair expr+ = do { fail_fun_var <- newFailLocalDs (voidPrimTy `mkFunTy` ty)+ ; fail_fun_arg <- newSysLocalDs voidPrimTy+ ; let real_arg = setOneShotLambda fail_fun_arg+ ; return (NonRec fail_fun_var (Lam real_arg expr),+ App (Var fail_fun_var) (Var voidPrimId)) }+ where+ ty = exprType expr++{-+Note [Failure thunks and CPR]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we make a failure point we ensure that it+does not look like a thunk. Example:++ let fail = \rw -> error "urk"+ in case x of+ [] -> fail realWorld#+ (y:ys) -> case ys of+ [] -> fail realWorld#+ (z:zs) -> (y,z)++Reason: we know that a failure point is always a "join point" and is+entered at most once. Adding a dummy 'realWorld' token argument makes+it clear that sharing is not an issue. And that in turn makes it more+CPR-friendly. This matters a lot: if you don't get it right, you lose+the tail call property. For example, see Trac #3403.+-}++mkOptTickBox :: [Tickish Id] -> CoreExpr -> CoreExpr+mkOptTickBox = flip (foldr Tick)++mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr+mkBinaryTickBox ixT ixF e = do+ uq <- newUnique+ this_mod <- getModule+ let bndr1 = mkSysLocal (fsLit "t1") uq boolTy+ let+ falseBox = Tick (HpcTick this_mod ixF) (Var falseDataConId)+ trueBox = Tick (HpcTick this_mod ixT) (Var trueDataConId)+ --+ return $ Case e bndr1 boolTy+ [ (DataAlt falseDataCon, [], falseBox)+ , (DataAlt trueDataCon, [], trueBox)+ ]
+ src/Language/Haskell/Liquid/Desugar710/HscMain.hs view
@@ -0,0 +1,95 @@+-------------------------------------------------------------------------------+--+-- | Main API for compiling plain Haskell source code.+--+-- This module implements compilation of a Haskell source. It is+-- /not/ concerned with preprocessing of source files; this is handled+-- in "DriverPipeline".+--+-- There are various entry points depending on what mode we're in:+-- "batch" mode (@--make@), "one-shot" mode (@-c@, @-S@ etc.), and+-- "interactive" mode (GHCi). There are also entry points for+-- individual passes: parsing, typechecking/renaming, desugaring, and+-- simplification.+--+-- All the functions here take an 'HscEnv' as a parameter, but none of+-- them return a new one: 'HscEnv' is treated as an immutable value+-- from here on in (although it has mutable components, for the+-- caches).+--+-- Warning messages are dealt with consistently throughout this API:+-- during compilation warnings are collected, and before any function+-- in @HscMain@ returns, the warnings are either printed, or turned+-- into a real compialtion error if the @-Werror@ flag is enabled.+--+-- (c) The GRASP/AQUA Project, Glasgow University, 1993-2000+--+-------------------------------------------------------------------------------++module Language.Haskell.Liquid.Desugar710.HscMain (hscDesugarWithLoc) where++import Language.Haskell.Liquid.Desugar710.Desugar (deSugarWithLoc)++import Module +import Lexer+import TcRnMonad++import ErrUtils++import HscTypes+import Bag+import Exception+++-- -----------------------------------------------------------------------------++getWarnings :: Hsc WarningMessages+getWarnings = Hsc $ \_ w -> return (w, w)++clearWarnings :: Hsc ()+clearWarnings = Hsc $ \_ _ -> return ((), emptyBag)++logWarnings :: WarningMessages -> Hsc ()+logWarnings w = Hsc $ \_ w0 -> return ((), w0 `unionBags` w)++++-- | Throw some errors.+throwErrors :: ErrorMessages -> Hsc a+throwErrors = liftIO . throwIO . mkSrcErr++-- +-- | Convert a typechecked module to Core+hscDesugarWithLoc :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts+hscDesugarWithLoc hsc_env mod_summary tc_result =+ runHsc hsc_env $ hscDesugar' (ms_location mod_summary) tc_result++hscDesugar' :: ModLocation -> TcGblEnv -> Hsc ModGuts+hscDesugar' mod_location tc_result = do+ hsc_env <- getHscEnv+ r <- ioMsgMaybe $+ {-# SCC "deSugar" #-}+ deSugarWithLoc hsc_env mod_location tc_result++ -- always check -Werror after desugaring, this is the last opportunity for+ -- warnings to arise before the backend.+ handleWarnings+ return r++getHscEnv :: Hsc HscEnv+getHscEnv = Hsc $ \e w -> return (e, w)++handleWarnings :: Hsc ()+handleWarnings = do+ dflags <- getDynFlags+ w <- getWarnings+ liftIO $ printOrThrowWarnings dflags w+ clearWarnings++ioMsgMaybe :: IO (Messages, Maybe a) -> Hsc a+ioMsgMaybe ioA = do+ ((warns,errs), mb_r) <- liftIO ioA+ logWarnings warns+ case mb_r of+ Nothing -> throwErrors errs+ Just r -> return r
+ src/Language/Haskell/Liquid/Desugar710/Match.hs view
@@ -0,0 +1,1091 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++The @match@ function+-}++{-# LANGUAGE CPP #-}++module Language.Haskell.Liquid.Desugar710.Match ( match, matchEquations, matchWrapper, matchSimply, matchSinglePat ) where++-- #include "HsVersions.h"++import {-#SOURCE#-} Language.Haskell.Liquid.Desugar710.DsExpr (dsLExpr, dsExpr)++import DynFlags+import HsSyn+import TcHsSyn+import TcEvidence+import TcRnMonad+import Check+import CoreSyn+import Literal+import CoreUtils+import MkCore+import DsMonad+import Language.Haskell.Liquid.Desugar710.DsBinds+import Language.Haskell.Liquid.Desugar710.DsGRHSs+import Language.Haskell.Liquid.Desugar710.DsUtils+import Id+import ConLike+import DataCon+import PatSyn+import Language.Haskell.Liquid.Desugar710.MatchCon+import Language.Haskell.Liquid.Desugar710.MatchLit+import Type+import TyCon( isNewTyCon )+import TysWiredIn+import ListSetOps+import SrcLoc+import Maybes+import Util+import Name+import Outputable+import BasicTypes ( boxityNormalTupleSort, isGenerated )+import FastString++import Control.Monad( when )+import qualified Data.Map as Map++{-+This function is a wrapper of @match@, it must be called from all the parts where+it was called match, but only substitutes the first call, ....+if the associated flags are declared, warnings will be issued.+It can not be called matchWrapper because this name already exists :-(++JJCQ 30-Nov-1997+-}++matchCheck :: DsMatchContext+ -> [Id] -- Vars rep'ing the exprs we're matching with+ -> Type -- Type of the case expression+ -> [EquationInfo] -- Info about patterns, etc. (type synonym below)+ -> DsM MatchResult -- Desugared result!++matchCheck ctx vars ty qs+ = do { dflags <- getDynFlags+ ; matchCheck_really dflags ctx vars ty qs }++matchCheck_really :: DynFlags+ -> DsMatchContext+ -> [Id]+ -> Type+ -> [EquationInfo]+ -> DsM MatchResult+matchCheck_really dflags ctx@(DsMatchContext hs_ctx _) vars ty qs+ = do { when shadow (dsShadowWarn ctx eqns_shadow)+ ; when incomplete (dsIncompleteWarn ctx pats)+ ; match vars ty qs }+ where+ (pats, eqns_shadow) = check qs+ incomplete = incomplete_flag hs_ctx && notNull pats+ shadow = wopt Opt_WarnOverlappingPatterns dflags+ && notNull eqns_shadow++ incomplete_flag :: HsMatchContext id -> Bool+ incomplete_flag (FunRhs {}) = wopt Opt_WarnIncompletePatterns dflags+ incomplete_flag CaseAlt = wopt Opt_WarnIncompletePatterns dflags+ incomplete_flag IfAlt = False++ incomplete_flag LambdaExpr = wopt Opt_WarnIncompleteUniPatterns dflags+ incomplete_flag PatBindRhs = wopt Opt_WarnIncompleteUniPatterns dflags+ incomplete_flag ProcExpr = wopt Opt_WarnIncompleteUniPatterns dflags++ incomplete_flag RecUpd = wopt Opt_WarnIncompletePatternsRecUpd dflags++ incomplete_flag ThPatSplice = False+ incomplete_flag PatSyn = False+ incomplete_flag ThPatQuote = False+ incomplete_flag (StmtCtxt {}) = False -- Don't warn about incomplete patterns+ -- in list comprehensions, pattern guards+ -- etc. They are often *supposed* to be+ -- incomplete++{-+This variable shows the maximum number of lines of output generated for warnings.+It will limit the number of patterns/equations displayed to@ maximum_output@.++(ToDo: add command-line option?)+-}++maximum_output :: Int+maximum_output = 4++-- The next two functions create the warning message.++dsShadowWarn :: DsMatchContext -> [EquationInfo] -> DsM ()+dsShadowWarn ctx@(DsMatchContext kind loc) qs+ = putSrcSpanDs loc (warnDs warn)+ where+ warn | qs `lengthExceeds` maximum_output+ = pp_context ctx (ptext (sLit "are overlapped"))+ (\ f -> vcat (map (ppr_eqn f kind) (take maximum_output qs)) $$+ ptext (sLit "..."))+ | otherwise+ = pp_context ctx (ptext (sLit "are overlapped"))+ (\ f -> vcat $ map (ppr_eqn f kind) qs)+++dsIncompleteWarn :: DsMatchContext -> [ExhaustivePat] -> DsM ()+dsIncompleteWarn ctx@(DsMatchContext kind loc) pats+ = putSrcSpanDs loc (warnDs warn)+ where+ warn = pp_context ctx (ptext (sLit "are non-exhaustive"))+ (\_ -> hang (ptext (sLit "Patterns not matched:"))+ 4 ((vcat $ map (ppr_incomplete_pats kind)+ (take maximum_output pats))+ $$ dots))++ dots | pats `lengthExceeds` maximum_output = ptext (sLit "...")+ | otherwise = empty++pp_context :: DsMatchContext -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc+pp_context (DsMatchContext kind _loc) msg rest_of_msg_fun+ = vcat [ptext (sLit "Pattern match(es)") <+> msg,+ sep [ptext (sLit "In") <+> ppr_match <> char ':', nest 4 (rest_of_msg_fun pref)]]+ where+ (ppr_match, pref)+ = case kind of+ FunRhs fun _ -> (pprMatchContext kind, \ pp -> ppr fun <+> pp)+ _ -> (pprMatchContext kind, \ pp -> pp)++ppr_pats :: Outputable a => [a] -> SDoc+ppr_pats pats = sep (map ppr pats)++ppr_shadow_pats :: HsMatchContext Name -> [Pat Id] -> SDoc+ppr_shadow_pats kind pats+ = sep [ppr_pats pats, matchSeparator kind, ptext (sLit "...")]++ppr_incomplete_pats :: HsMatchContext Name -> ExhaustivePat -> SDoc+ppr_incomplete_pats _ (pats,[]) = ppr_pats pats+ppr_incomplete_pats _ (pats,constraints) =+ sep [ppr_pats pats, ptext (sLit "with"),+ sep (map ppr_constraint constraints)]++ppr_constraint :: (Name,[HsLit]) -> SDoc+ppr_constraint (var,pats) = sep [ppr var, ptext (sLit "`notElem`"), ppr pats]++ppr_eqn :: (SDoc -> SDoc) -> HsMatchContext Name -> EquationInfo -> SDoc+ppr_eqn prefixF kind eqn = prefixF (ppr_shadow_pats kind (eqn_pats eqn))++{-+************************************************************************+* *+ The main matching function+* *+************************************************************************++The function @match@ is basically the same as in the Wadler chapter,+except it is monadised, to carry around the name supply, info about+annotations, etc.++Notes on @match@'s arguments, assuming $m$ equations and $n$ patterns:+\begin{enumerate}+\item+A list of $n$ variable names, those variables presumably bound to the+$n$ expressions being matched against the $n$ patterns. Using the+list of $n$ expressions as the first argument showed no benefit and+some inelegance.++\item+The second argument, a list giving the ``equation info'' for each of+the $m$ equations:+\begin{itemize}+\item+the $n$ patterns for that equation, and+\item+a list of Core bindings [@(Id, CoreExpr)@ pairs] to be ``stuck on+the front'' of the matching code, as in:+\begin{verbatim}+let <binds>+in <matching-code>+\end{verbatim}+\item+and finally: (ToDo: fill in)++The right way to think about the ``after-match function'' is that it+is an embryonic @CoreExpr@ with a ``hole'' at the end for the+final ``else expression''.+\end{itemize}++There is a type synonym, @EquationInfo@, defined in module @DsUtils@.++An experiment with re-ordering this information about equations (in+particular, having the patterns available in column-major order)+showed no benefit.++\item+A default expression---what to evaluate if the overall pattern-match+fails. This expression will (almost?) always be+a measly expression @Var@, unless we know it will only be used once+(as we do in @glue_success_exprs@).++Leaving out this third argument to @match@ (and slamming in lots of+@Var "fail"@s) is a positively {\em bad} idea, because it makes it+impossible to share the default expressions. (Also, it stands no+chance of working in our post-upheaval world of @Locals@.)+\end{enumerate}++Note: @match@ is often called via @matchWrapper@ (end of this module),+a function that does much of the house-keeping that goes with a call+to @match@.++It is also worth mentioning the {\em typical} way a block of equations+is desugared with @match@. At each stage, it is the first column of+patterns that is examined. The steps carried out are roughly:+\begin{enumerate}+\item+Tidy the patterns in column~1 with @tidyEqnInfo@ (this may add+bindings to the second component of the equation-info):+\begin{itemize}+\item+Remove the `as' patterns from column~1.+\item+Make all constructor patterns in column~1 into @ConPats@, notably+@ListPats@ and @TuplePats@.+\item+Handle any irrefutable (or ``twiddle'') @LazyPats@.+\end{itemize}+\item+Now {\em unmix} the equations into {\em blocks} [w\/ local function+@unmix_eqns@], in which the equations in a block all have variable+patterns in column~1, or they all have constructor patterns in ...+(see ``the mixture rule'' in SLPJ).+\item+Call @matchEqnBlock@ on each block of equations; it will do the+appropriate thing for each kind of column-1 pattern, usually ending up+in a recursive call to @match@.+\end{enumerate}++We are a little more paranoid about the ``empty rule'' (SLPJ, p.~87)+than the Wadler-chapter code for @match@ (p.~93, first @match@ clause).+And gluing the ``success expressions'' together isn't quite so pretty.++This (more interesting) clause of @match@ uses @tidy_and_unmix_eqns@+(a)~to get `as'- and `twiddle'-patterns out of the way (tidying), and+(b)~to do ``the mixture rule'' (SLPJ, p.~88) [which really {\em+un}mixes the equations], producing a list of equation-info+blocks, each block having as its first column of patterns either all+constructors, or all variables (or similar beasts), etc.++@match_unmixed_eqn_blks@ simply takes the place of the @foldr@ in the+Wadler-chapter @match@ (p.~93, last clause), and @match_unmixed_blk@+corresponds roughly to @matchVarCon@.+-}++match :: [Id] -- Variables rep\'ing the exprs we\'re matching with+ -> Type -- Type of the case expression+ -> [EquationInfo] -- Info about patterns, etc. (type synonym below)+ -> DsM MatchResult -- Desugared result!++match [] _ty eqns+ = -- ASSERT2( not (null eqns), ppr ty )+ return (foldr1 combineMatchResults match_results)+ where+ match_results = [ -- ASSERT( null (eqn_pats eqn) )+ eqn_rhs eqn+ | eqn <- eqns ]++match vars@(v:_) ty eqns -- Eqns *can* be empty+ = do { dflags <- getDynFlags+ -- Tidy the first pattern, generating+ -- auxiliary bindings if necessary+ ; (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns++ -- Group the equations and match each group in turn+ ; let grouped = groupEquations dflags tidy_eqns++ -- print the view patterns that are commoned up to help debug+ ; whenDOptM Opt_D_dump_view_pattern_commoning (debug grouped)++ ; match_results <- match_groups grouped+ ; return (adjustMatchResult (foldr (.) id aux_binds) $+ foldr1 combineMatchResults match_results) }+ where+ dropGroup :: [(PatGroup,EquationInfo)] -> [EquationInfo]+ dropGroup = map snd++ match_groups :: [[(PatGroup,EquationInfo)]] -> DsM [MatchResult]+ -- Result list of [MatchResult] is always non-empty+ match_groups [] = matchEmpty v ty+ match_groups gs = mapM match_group gs++ match_group :: [(PatGroup,EquationInfo)] -> DsM MatchResult+ match_group [] = panic "match_group"+ match_group eqns@((group,_) : _)+ = case group of+ PgCon _ -> matchConFamily vars ty (subGroup [(c,e) | (PgCon c, e) <- eqns])+ PgSyn _ -> matchPatSyn vars ty (dropGroup eqns)+ PgLit _ -> matchLiterals vars ty (subGroup [(l,e) | (PgLit l, e) <- eqns])+ PgAny -> matchVariables vars ty (dropGroup eqns)+ PgN _ -> matchNPats vars ty (dropGroup eqns)+ PgNpK _ -> matchNPlusKPats vars ty (dropGroup eqns)+ PgBang -> matchBangs vars ty (dropGroup eqns)+ PgCo _ -> matchCoercion vars ty (dropGroup eqns)+ PgView _ _ -> matchView vars ty (dropGroup eqns)+ PgOverloadedList -> matchOverloadedList vars ty (dropGroup eqns)++ -- FIXME: we should also warn about view patterns that should be+ -- commoned up but are not++ -- print some stuff to see what's getting grouped+ -- use -dppr-debug to see the resolution of overloaded literals+ debug eqns =+ let gs = map (\group -> foldr (\ (p,_) -> \acc ->+ case p of PgView e _ -> e:acc+ _ -> acc) [] group) eqns+ maybeWarn [] = return ()+ maybeWarn l = warnDs (vcat l)+ in+ maybeWarn $ (map (\g -> text "Putting these view expressions into the same case:" <+> (ppr g))+ (filter (not . null) gs))++matchEmpty :: Id -> Type -> DsM [MatchResult]+-- See Note [Empty case expressions]+matchEmpty var res_ty+ = return [MatchResult CanFail mk_seq]+ where+ mk_seq fail = return $ mkWildCase (Var var) (idType var) res_ty+ [(DEFAULT, [], fail)]++matchVariables :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult+-- Real true variables, just like in matchVar, SLPJ p 94+-- No binding to do: they'll all be wildcards by now (done in tidy)+matchVariables (_:vars) ty eqns = match vars ty (shiftEqns eqns)+matchVariables [] _ _ = panic "matchVariables"++matchBangs :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult+matchBangs (var:vars) ty eqns+ = do { match_result <- match (var:vars) ty $+ map (decomposeFirstPat getBangPat) eqns+ ; return (mkEvalMatchResult var ty match_result) }+matchBangs [] _ _ = panic "matchBangs"++matchCoercion :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult+-- Apply the coercion to the match variable and then match that+matchCoercion (var:vars) ty (eqns@(eqn1:_))+ = do { let CoPat co pat _ = firstPat eqn1+ ; var' <- newUniqueId var (hsPatType pat)+ ; match_result <- match (var':vars) ty $+ map (decomposeFirstPat getCoPat) eqns+ ; rhs' <- dsHsWrapper co (Var var)+ ; return (mkCoLetMatchResult (NonRec var' rhs') match_result) }+matchCoercion _ _ _ = panic "matchCoercion"++matchView :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult+-- Apply the view function to the match variable and then match that+matchView (var:vars) ty (eqns@(eqn1:_))+ = do { -- we could pass in the expr from the PgView,+ -- but this needs to extract the pat anyway+ -- to figure out the type of the fresh variable+ let ViewPat viewExpr (L _ pat) _ = firstPat eqn1+ -- do the rest of the compilation+ ; var' <- newUniqueId var (hsPatType pat)+ ; match_result <- match (var':vars) ty $+ map (decomposeFirstPat getViewPat) eqns+ -- compile the view expressions+ ; viewExpr' <- dsLExpr viewExpr+ ; return (mkViewMatchResult var' viewExpr' var match_result) }+matchView _ _ _ = panic "matchView"++matchOverloadedList :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult+matchOverloadedList (var:vars) ty (eqns@(eqn1:_))+-- Since overloaded list patterns are treated as view patterns,+-- the code is roughly the same as for matchView+ = do { let ListPat _ elt_ty (Just (_,e)) = firstPat eqn1+ ; var' <- newUniqueId var (mkListTy elt_ty) -- we construct the overall type by hand+ ; match_result <- match (var':vars) ty $+ map (decomposeFirstPat getOLPat) eqns -- getOLPat builds the pattern inside as a non-overloaded version of the overloaded list pattern+ ; e' <- dsExpr e+ ; return (mkViewMatchResult var' e' var match_result) }+matchOverloadedList _ _ _ = panic "matchOverloadedList"++-- decompose the first pattern and leave the rest alone+decomposeFirstPat :: (Pat Id -> Pat Id) -> EquationInfo -> EquationInfo+decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats }))+ = eqn { eqn_pats = extractpat pat : pats}+decomposeFirstPat _ _ = panic "decomposeFirstPat"++getCoPat, getBangPat, getViewPat, getOLPat :: Pat Id -> Pat Id+getCoPat (CoPat _ pat _) = pat+getCoPat _ = panic "getCoPat"+getBangPat (BangPat pat ) = unLoc pat+getBangPat _ = panic "getBangPat"+getViewPat (ViewPat _ pat _) = unLoc pat+getViewPat _ = panic "getViewPat"+getOLPat (ListPat pats ty (Just _)) = ListPat pats ty Nothing+getOLPat _ = panic "getOLPat"++{-+Note [Empty case alternatives]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The list of EquationInfo can be empty, arising from+ case x of {} or \case {}+In that situation we desugar to+ case x of { _ -> error "pattern match failure" }+The *desugarer* isn't certain whether there really should be no+alternatives, so it adds a default case, as it always does. A later+pass may remove it if it's inaccessible. (See also Note [Empty case+alternatives] in CoreSyn.)++We do *not* desugar simply to+ error "empty case"+or some such, because 'x' might be bound to (error "hello"), in which+case we want to see that "hello" exception, not (error "empty case").+See also Note [Case elimination: lifted case] in Simplify.+++************************************************************************+* *+ Tidying patterns+* *+************************************************************************++Tidy up the leftmost pattern in an @EquationInfo@, given the variable @v@+which will be scrutinised. This means:+\begin{itemize}+\item+Replace variable patterns @x@ (@x /= v@) with the pattern @_@,+together with the binding @x = v@.+\item+Replace the `as' pattern @x@@p@ with the pattern p and a binding @x = v@.+\item+Removing lazy (irrefutable) patterns (you don't want to know...).+\item+Converting explicit tuple-, list-, and parallel-array-pats into ordinary+@ConPats@.+\item+Convert the literal pat "" to [].+\end{itemize}++The result of this tidying is that the column of patterns will include+{\em only}:+\begin{description}+\item[@WildPats@:]+The @VarPat@ information isn't needed any more after this.++\item[@ConPats@:]+@ListPats@, @TuplePats@, etc., are all converted into @ConPats@.++\item[@LitPats@ and @NPats@:]+@LitPats@/@NPats@ of ``known friendly types'' (Int, Char,+Float, Double, at least) are converted to unboxed form; e.g.,+\tr{(NPat (HsInt i) _ _)} is converted to:+\begin{verbatim}+(ConPat I# _ _ [LitPat (HsIntPrim i)])+\end{verbatim}+\end{description}+-}++tidyEqnInfo :: Id -> EquationInfo+ -> DsM (DsWrapper, EquationInfo)+ -- DsM'd because of internal call to dsLHsBinds+ -- and mkSelectorBinds.+ -- "tidy1" does the interesting stuff, looking at+ -- one pattern and fiddling the list of bindings.+ --+ -- POST CONDITION: head pattern in the EqnInfo is+ -- WildPat+ -- ConPat+ -- NPat+ -- LitPat+ -- NPlusKPat+ -- but no other++tidyEqnInfo _ (EqnInfo { eqn_pats = [] })+ = panic "tidyEqnInfo"++tidyEqnInfo v eqn@(EqnInfo { eqn_pats = pat : pats })+ = do { (wrap, pat') <- tidy1 v pat+ ; return (wrap, eqn { eqn_pats = do pat' : pats }) }++tidy1 :: Id -- The Id being scrutinised+ -> Pat Id -- The pattern against which it is to be matched+ -> DsM (DsWrapper, -- Extra bindings to do before the match+ Pat Id) -- Equivalent pattern++-------------------------------------------------------+-- (pat', mr') = tidy1 v pat mr+-- tidies the *outer level only* of pat, giving pat'+-- It eliminates many pattern forms (as-patterns, variable patterns,+-- list patterns, etc) yielding one of:+-- WildPat+-- ConPatOut+-- LitPat+-- NPat+-- NPlusKPat++tidy1 v (ParPat pat) = tidy1 v (unLoc pat)+tidy1 v (SigPatOut pat _) = tidy1 v (unLoc pat)+tidy1 _ (WildPat ty) = return (idDsWrapper, WildPat ty)+tidy1 v (BangPat (L l p)) = tidy_bang_pat v l p++ -- case v of { x -> mr[] }+ -- = case v of { _ -> let x=v in mr[] }+tidy1 v (VarPat var)+ = return (wrapBind var v, WildPat (idType var))++ -- case v of { x@p -> mr[] }+ -- = case v of { p -> let x=v in mr[] }+tidy1 v (AsPat (L _ var) pat)+ = do { (wrap, pat') <- tidy1 v (unLoc pat)+ ; return (wrapBind var v . wrap, pat') }++{- now, here we handle lazy patterns:+ tidy1 v ~p bs = (v, v1 = case v of p -> v1 :+ v2 = case v of p -> v2 : ... : bs )++ where the v_i's are the binders in the pattern.++ ToDo: in "v_i = ... -> v_i", are the v_i's really the same thing?++ The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr+-}++tidy1 v (LazyPat pat)+ = do { sel_prs <- mkSelectorBinds [] pat (Var v)+ ; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs]+ ; return (mkCoreLets sel_binds, WildPat (idType v)) }++tidy1 _ (ListPat pats ty Nothing)+ = return (idDsWrapper, unLoc list_ConPat)+ where+ list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] [ty])+ (mkNilPat ty)+ pats++-- Introduce fake parallel array constructors to be able to handle parallel+-- arrays with the existing machinery for constructor pattern+tidy1 _ (PArrPat pats ty)+ = return (idDsWrapper, unLoc parrConPat)+ where+ arity = length pats+ parrConPat = mkPrefixConPat (parrFakeCon arity) pats [ty]++tidy1 _ (TuplePat pats boxity tys)+ = return (idDsWrapper, unLoc tuple_ConPat)+ where+ arity = length pats+ tuple_ConPat = mkPrefixConPat (tupleCon (boxityNormalTupleSort boxity) arity) pats tys++-- LitPats: we *might* be able to replace these w/ a simpler form+tidy1 _ (LitPat lit)+ = return (idDsWrapper, tidyLitPat lit)++-- NPats: we *might* be able to replace these w/ a simpler form+tidy1 _ (NPat (L _ lit) mb_neg eq)+ = return (idDsWrapper, tidyNPat tidyLitPat lit mb_neg eq)++-- Everything else goes through unchanged...++tidy1 _ non_interesting_pat+ = return (idDsWrapper, non_interesting_pat)++--------------------+tidy_bang_pat :: Id -> SrcSpan -> Pat Id -> DsM (DsWrapper, Pat Id)++-- Discard par/sig under a bang+tidy_bang_pat v _ (ParPat (L l p)) = tidy_bang_pat v l p+tidy_bang_pat v _ (SigPatOut (L l p) _) = tidy_bang_pat v l p++-- Push the bang-pattern inwards, in the hope that+-- it may disappear next time+tidy_bang_pat v l (AsPat v' p) = tidy1 v (AsPat v' (L l (BangPat p)))+tidy_bang_pat v l (CoPat w p t) = tidy1 v (CoPat w (BangPat (L l p)) t)++-- Discard bang around strict pattern+tidy_bang_pat v _ p@(LitPat {}) = tidy1 v p+tidy_bang_pat v _ p@(ListPat {}) = tidy1 v p+tidy_bang_pat v _ p@(TuplePat {}) = tidy1 v p+tidy_bang_pat v _ p@(PArrPat {}) = tidy1 v p++-- Data/newtype constructors+tidy_bang_pat v l p@(ConPatOut { pat_con = L _ (RealDataCon dc), pat_args = args })+ | isNewTyCon (dataConTyCon dc) -- Newtypes: push bang inwards (Trac #9844)+ = tidy1 v (p { pat_args = push_bang_into_newtype_arg l args })+ | otherwise -- Data types: discard the bang+ = tidy1 v p++-------------------+-- Default case, leave the bang there:+-- VarPat,+-- LazyPat,+-- WildPat,+-- ViewPat,+-- pattern synonyms (ConPatOut with PatSynCon)+-- NPat,+-- NPlusKPat+--+-- For LazyPat, remember that it's semantically like a VarPat+-- i.e. !(~p) is not like ~p, or p! (Trac #8952)+--+-- NB: SigPatIn, ConPatIn should not happen++tidy_bang_pat _ l p = return (idDsWrapper, BangPat (L l p))++-------------------+push_bang_into_newtype_arg :: SrcSpan -> HsConPatDetails Id -> HsConPatDetails Id+-- See Note [Bang patterns and newtypes]+-- We are transforming !(N p) into (N !p)+push_bang_into_newtype_arg l (PrefixCon (arg:_args))+ = -- ASSERT( null args)+ PrefixCon [L l (BangPat arg)]+push_bang_into_newtype_arg l (RecCon rf)+ | HsRecFields { rec_flds = L lf fld : _flds } <- rf+ , HsRecField { hsRecFieldArg = arg } <- fld+ = -- ASSERT( null flds)+ RecCon (rf { rec_flds = [L lf (fld { hsRecFieldArg = L l (BangPat arg) })] })+push_bang_into_newtype_arg _ cd+ = pprPanic "push_bang_into_newtype_arg" (pprConArgs cd)++{-+Note [Bang patterns and newtypes]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For the pattern !(Just pat) we can discard the bang, because+the pattern is strict anyway. But for !(N pat), where+ newtype NT = N Int+we definitely can't discard the bang. Trac #9844.++So what we do is to push the bang inwards, in the hope that it will+get discarded there. So we transform+ !(N pat) into (N !pat)+++\noindent+{\bf Previous @matchTwiddled@ stuff:}++Now we get to the only interesting part; note: there are choices for+translation [from Simon's notes]; translation~1:+\begin{verbatim}+deTwiddle [s,t] e+\end{verbatim}+returns+\begin{verbatim}+[ w = e,+ s = case w of [s,t] -> s+ t = case w of [s,t] -> t+]+\end{verbatim}++Here \tr{w} is a fresh variable, and the \tr{w}-binding prevents multiple+evaluation of \tr{e}. An alternative translation (No.~2):+\begin{verbatim}+[ w = case e of [s,t] -> (s,t)+ s = case w of (s,t) -> s+ t = case w of (s,t) -> t+]+\end{verbatim}++************************************************************************+* *+\subsubsection[improved-unmixing]{UNIMPLEMENTED idea for improved unmixing}+* *+************************************************************************++We might be able to optimise unmixing when confronted by+only-one-constructor-possible, of which tuples are the most notable+examples. Consider:+\begin{verbatim}+f (a,b,c) ... = ...+f d ... (e:f) = ...+f (g,h,i) ... = ...+f j ... = ...+\end{verbatim}+This definition would normally be unmixed into four equation blocks,+one per equation. But it could be unmixed into just one equation+block, because if the one equation matches (on the first column),+the others certainly will.++You have to be careful, though; the example+\begin{verbatim}+f j ... = ...+-------------------+f (a,b,c) ... = ...+f d ... (e:f) = ...+f (g,h,i) ... = ...+\end{verbatim}+{\em must} be broken into two blocks at the line shown; otherwise, you+are forcing unnecessary evaluation. In any case, the top-left pattern+always gives the cue. You could then unmix blocks into groups of...+\begin{description}+\item[all variables:]+As it is now.+\item[constructors or variables (mixed):]+Need to make sure the right names get bound for the variable patterns.+\item[literals or variables (mixed):]+Presumably just a variant on the constructor case (as it is now).+\end{description}++************************************************************************+* *+* matchWrapper: a convenient way to call @match@ *+* *+************************************************************************+\subsection[matchWrapper]{@matchWrapper@: a convenient interface to @match@}++Calls to @match@ often involve similar (non-trivial) work; that work+is collected here, in @matchWrapper@. This function takes as+arguments:+\begin{itemize}+\item+Typchecked @Matches@ (of a function definition, or a case or lambda+expression)---the main input;+\item+An error message to be inserted into any (runtime) pattern-matching+failure messages.+\end{itemize}++As results, @matchWrapper@ produces:+\begin{itemize}+\item+A list of variables (@Locals@) that the caller must ``promise'' to+bind to appropriate values; and+\item+a @CoreExpr@, the desugared output (main result).+\end{itemize}++The main actions of @matchWrapper@ include:+\begin{enumerate}+\item+Flatten the @[TypecheckedMatch]@ into a suitable list of+@EquationInfo@s.+\item+Create as many new variables as there are patterns in a pattern-list+(in any one of the @EquationInfo@s).+\item+Create a suitable ``if it fails'' expression---a call to @error@ using+the error-string input; the {\em type} of this fail value can be found+by examining one of the RHS expressions in one of the @EquationInfo@s.+\item+Call @match@ with all of this information!+\end{enumerate}+-}++matchWrapper :: HsMatchContext Name -- For shadowing warning messages+ -> MatchGroup Id (LHsExpr Id) -- Matches being desugared+ -> DsM ([Id], CoreExpr) -- Results++{-+ There is one small problem with the Lambda Patterns, when somebody+ writes something similar to:+\begin{verbatim}+ (\ (x:xs) -> ...)+\end{verbatim}+ he/she don't want a warning about incomplete patterns, that is done with+ the flag @opt_WarnSimplePatterns@.+ This problem also appears in the:+\begin{itemize}+\item @do@ patterns, but if the @do@ can fail+ it creates another equation if the match can fail+ (see @DsExpr.doDo@ function)+\item @let@ patterns, are treated by @matchSimply@+ List Comprension Patterns, are treated by @matchSimply@ also+\end{itemize}++We can't call @matchSimply@ with Lambda patterns,+due to the fact that lambda patterns can have more than+one pattern, and match simply only accepts one pattern.++JJQC 30-Nov-1997+-}++matchWrapper ctxt (MG { mg_alts = matches+ , mg_arg_tys = arg_tys+ , mg_res_ty = rhs_ty+ , mg_origin = origin })+ = do { eqns_info <- mapM mk_eqn_info matches+ ; new_vars <- case matches of+ [] -> mapM newSysLocalDs arg_tys+ (m:_) -> selectMatchVars (map unLoc (hsLMatchPats m))+ ; result_expr <- handleWarnings $+ matchEquations ctxt new_vars eqns_info rhs_ty+ ; return (new_vars, result_expr) }+ where+ mk_eqn_info (L _ (Match _ pats _ grhss))+ = do { let upats = map unLoc pats+ ; match_result <- dsGRHSs ctxt upats grhss rhs_ty+ ; return (EqnInfo { eqn_pats = upats, eqn_rhs = match_result}) }++ handleWarnings = if isGenerated origin+ then discardWarningsDs+ else id+++matchEquations :: HsMatchContext Name+ -> [Id] -> [EquationInfo] -> Type+ -> DsM CoreExpr+matchEquations ctxt vars eqns_info rhs_ty+ = do { locn <- getSrcSpanDs+ ; let ds_ctxt = DsMatchContext ctxt locn+ error_doc = matchContextErrString ctxt++ ; match_result <- matchCheck ds_ctxt vars rhs_ty eqns_info++ ; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_doc+ ; extractMatchResult match_result fail_expr }++{-+************************************************************************+* *+\subsection[matchSimply]{@matchSimply@: match a single expression against a single pattern}+* *+************************************************************************++@mkSimpleMatch@ is a wrapper for @match@ which deals with the+situation where we want to match a single expression against a single+pattern. It returns an expression.+-}++matchSimply :: CoreExpr -- Scrutinee+ -> HsMatchContext Name -- Match kind+ -> LPat Id -- Pattern it should match+ -> CoreExpr -- Return this if it matches+ -> CoreExpr -- Return this if it doesn't+ -> DsM CoreExpr+-- Do not warn about incomplete patterns; see matchSinglePat comments+matchSimply scrut hs_ctx pat result_expr fail_expr = do+ let+ match_result = cantFailMatchResult result_expr+ rhs_ty = exprType fail_expr+ -- Use exprType of fail_expr, because won't refine in the case of failure!+ match_result' <- matchSinglePat scrut hs_ctx pat rhs_ty match_result+ extractMatchResult match_result' fail_expr++matchSinglePat :: CoreExpr -> HsMatchContext Name -> LPat Id+ -> Type -> MatchResult -> DsM MatchResult+-- Do not warn about incomplete patterns+-- Used for things like [ e | pat <- stuff ], where+-- incomplete patterns are just fine+matchSinglePat (Var var) ctx (L _ pat) ty match_result+ = do { locn <- getSrcSpanDs+ ; matchCheck (DsMatchContext ctx locn)+ [var] ty+ [EqnInfo { eqn_pats = [pat], eqn_rhs = match_result }] }++matchSinglePat scrut hs_ctx pat ty match_result+ = do { var <- selectSimpleMatchVarL pat+ ; match_result' <- matchSinglePat (Var var) hs_ctx pat ty match_result+ ; return (adjustMatchResult (bindNonRec var scrut) match_result') }++{-+************************************************************************+* *+ Pattern classification+* *+************************************************************************+-}++data PatGroup+ = PgAny -- Immediate match: variables, wildcards,+ -- lazy patterns+ | PgCon DataCon -- Constructor patterns (incl list, tuple)+ | PgSyn PatSyn+ | PgLit Literal -- Literal patterns+ | PgN Literal -- Overloaded literals+ | PgNpK Literal -- n+k patterns+ | PgBang -- Bang patterns+ | PgCo Type -- Coercion patterns; the type is the type+ -- of the pattern *inside*+ | PgView (LHsExpr Id) -- view pattern (e -> p):+ -- the LHsExpr is the expression e+ Type -- the Type is the type of p (equivalently, the result type of e)+ | PgOverloadedList++groupEquations :: DynFlags -> [EquationInfo] -> [[(PatGroup, EquationInfo)]]+-- If the result is of form [g1, g2, g3],+-- (a) all the (pg,eq) pairs in g1 have the same pg+-- (b) none of the gi are empty+-- The ordering of equations is unchanged+groupEquations dflags eqns+ = runs same_gp [(patGroup dflags (firstPat eqn), eqn) | eqn <- eqns]+ where+ same_gp :: (PatGroup,EquationInfo) -> (PatGroup,EquationInfo) -> Bool+ (pg1,_) `same_gp` (pg2,_) = pg1 `sameGroup` pg2++subGroup :: Ord a => [(a, EquationInfo)] -> [[EquationInfo]]+-- Input is a particular group. The result sub-groups the+-- equations by with particular constructor, literal etc they match.+-- Each sub-list in the result has the same PatGroup+-- See Note [Take care with pattern order]+subGroup group+ = map reverse $ Map.elems $ foldl accumulate Map.empty group+ where+ accumulate pg_map (pg, eqn)+ = case Map.lookup pg pg_map of+ Just eqns -> Map.insert pg (eqn:eqns) pg_map+ Nothing -> Map.insert pg [eqn] pg_map++ -- pg_map :: Map a [EquationInfo]+ -- Equations seen so far in reverse order of appearance++{-+Note [Take care with pattern order]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In the subGroup function we must be very careful about pattern re-ordering,+Consider the patterns [ (True, Nothing), (False, x), (True, y) ]+Then in bringing together the patterns for True, we must not+swap the Nothing and y!+-}++sameGroup :: PatGroup -> PatGroup -> Bool+-- Same group means that a single case expression+-- or test will suffice to match both, *and* the order+-- of testing within the group is insignificant.+sameGroup PgAny PgAny = True+sameGroup PgBang PgBang = True+sameGroup (PgCon _) (PgCon _) = True -- One case expression+sameGroup (PgSyn p1) (PgSyn p2) = p1==p2+sameGroup (PgLit _) (PgLit _) = True -- One case expression+sameGroup (PgN l1) (PgN l2) = l1==l2 -- Order is significant+sameGroup (PgNpK l1) (PgNpK l2) = l1==l2 -- See Note [Grouping overloaded literal patterns]+sameGroup (PgCo t1) (PgCo t2) = t1 `eqType` t2+ -- CoPats are in the same goup only if the type of the+ -- enclosed pattern is the same. The patterns outside the CoPat+ -- always have the same type, so this boils down to saying that+ -- the two coercions are identical.+sameGroup (PgView e1 t1) (PgView e2 t2) = viewLExprEq (e1,t1) (e2,t2)+ -- ViewPats are in the same group iff the expressions+ -- are "equal"---conservatively, we use syntactic equality+sameGroup _ _ = False++-- An approximation of syntactic equality used for determining when view+-- exprs are in the same group.+-- This function can always safely return false;+-- but doing so will result in the application of the view function being repeated.+--+-- Currently: compare applications of literals and variables+-- and anything else that we can do without involving other+-- HsSyn types in the recursion+--+-- NB we can't assume that the two view expressions have the same type. Consider+-- f (e1 -> True) = ...+-- f (e2 -> "hi") = ...+viewLExprEq :: (LHsExpr Id,Type) -> (LHsExpr Id,Type) -> Bool+viewLExprEq (e1,_) (e2,_) = lexp e1 e2+ where+ lexp :: LHsExpr Id -> LHsExpr Id -> Bool+ lexp e e' = exp (unLoc e) (unLoc e')++ ---------+ exp :: HsExpr Id -> HsExpr Id -> Bool+ -- real comparison is on HsExpr's+ -- strip parens+ exp (HsPar (L _ e)) e' = exp e e'+ exp e (HsPar (L _ e')) = exp e e'+ -- because the expressions do not necessarily have the same type,+ -- we have to compare the wrappers+ exp (HsWrap h e) (HsWrap h' e') = wrap h h' && exp e e'+ exp (HsVar i) (HsVar i') = i == i'+ -- the instance for IPName derives using the id, so this works if the+ -- above does+ exp (HsIPVar i) (HsIPVar i') = i == i'+ exp (HsOverLit l) (HsOverLit l') =+ -- Overloaded lits are equal if they have the same type+ -- and the data is the same.+ -- this is coarser than comparing the SyntaxExpr's in l and l',+ -- which resolve the overloading (e.g., fromInteger 1),+ -- because these expressions get written as a bunch of different variables+ -- (presumably to improve sharing)+ eqType (overLitType l) (overLitType l') && l == l'+ exp (HsApp e1 e2) (HsApp e1' e2') = lexp e1 e1' && lexp e2 e2'+ -- the fixities have been straightened out by now, so it's safe+ -- to ignore them?+ exp (OpApp l o _ ri) (OpApp l' o' _ ri') =+ lexp l l' && lexp o o' && lexp ri ri'+ exp (NegApp e n) (NegApp e' n') = lexp e e' && exp n n'+ exp (SectionL e1 e2) (SectionL e1' e2') =+ lexp e1 e1' && lexp e2 e2'+ exp (SectionR e1 e2) (SectionR e1' e2') =+ lexp e1 e1' && lexp e2 e2'+ exp (ExplicitTuple es1 _) (ExplicitTuple es2 _) =+ eq_list tup_arg es1 es2+ exp (HsIf _ e e1 e2) (HsIf _ e' e1' e2') =+ lexp e e' && lexp e1 e1' && lexp e2 e2'++ -- Enhancement: could implement equality for more expressions+ -- if it seems useful+ -- But no need for HsLit, ExplicitList, ExplicitTuple,+ -- because they cannot be functions+ exp _ _ = False++ ---------+ tup_arg (L _ (Present e1)) (L _ (Present e2)) = lexp e1 e2+ tup_arg (L _ (Missing t1)) (L _ (Missing t2)) = eqType t1 t2+ tup_arg _ _ = False++ ---------+ wrap :: HsWrapper -> HsWrapper -> Bool+ -- Conservative, in that it demands that wrappers be+ -- syntactically identical and doesn't look under binders+ --+ -- Coarser notions of equality are possible+ -- (e.g., reassociating compositions,+ -- equating different ways of writing a coercion)+ wrap WpHole WpHole = True+ wrap (WpCompose w1 w2) (WpCompose w1' w2') = wrap w1 w1' && wrap w2 w2'+ wrap (WpFun w1 w2 _ _) (WpFun w1' w2' _ _) = wrap w1 w1' && wrap w2 w2'+ wrap (WpCast co) (WpCast co') = co `eq_co` co'+ wrap (WpEvApp et1) (WpEvApp et2) = et1 `ev_term` et2+ wrap (WpTyApp t) (WpTyApp t') = eqType t t'+ -- Enhancement: could implement equality for more wrappers+ -- if it seems useful (lams and lets)+ wrap _ _ = False++ ---------+ ev_term :: EvTerm -> EvTerm -> Bool+ ev_term (EvId a) (EvId b) = a==b+ ev_term (EvCoercion a) (EvCoercion b) = a `eq_co` b+ ev_term _ _ = False++ ---------+ eq_list :: (a->a->Bool) -> [a] -> [a] -> Bool+ eq_list _ [] [] = True+ eq_list _ [] (_:_) = False+ eq_list _ (_:_) [] = False+ eq_list eq (x:xs) (y:ys) = eq x y && eq_list eq xs ys++ ---------+ eq_co :: TcCoercion -> TcCoercion -> Bool+ -- Just some simple cases (should the r1 == r2 rather be an ASSERT?)+ eq_co (TcRefl r1 t1) (TcRefl r2 t2) = r1 == r2 && eqType t1 t2+ eq_co (TcCoVarCo v1) (TcCoVarCo v2) = v1==v2+ eq_co (TcSymCo co1) (TcSymCo co2) = co1 `eq_co` co2+ eq_co (TcTyConAppCo r1 tc1 cos1) (TcTyConAppCo r2 tc2 cos2) = r1 == r2 && tc1==tc2 && eq_list eq_co cos1 cos2+ eq_co _ _ = False++patGroup :: DynFlags -> Pat Id -> PatGroup+patGroup _ (WildPat {}) = PgAny+patGroup _ (BangPat {}) = PgBang+patGroup _ (ConPatOut { pat_con = con }) = case unLoc con of+ RealDataCon dcon -> PgCon dcon+ PatSynCon psyn -> PgSyn psyn+patGroup dflags (LitPat lit) = PgLit (hsLitKey dflags lit)+patGroup _ (NPat (L _ olit) mb_neg _)+ = PgN (hsOverLitKey olit (isJust mb_neg))+patGroup _ (NPlusKPat _ (L _ olit) _ _) = PgNpK (hsOverLitKey olit False)+patGroup _ (CoPat _ p _) = PgCo (hsPatType p) -- Type of innelexp pattern+patGroup _ (ViewPat expr p _) = PgView expr (hsPatType (unLoc p))+patGroup _ (ListPat _ _ (Just _)) = PgOverloadedList+patGroup _ pat = pprPanic "patGroup" (ppr pat)++{-+Note [Grouping overloaded literal patterns]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+WATCH OUT! Consider++ f (n+1) = ...+ f (n+2) = ...+ f (n+1) = ...++We can't group the first and third together, because the second may match+the same thing as the first. Same goes for *overloaded* literal patterns+ f 1 True = ...+ f 2 False = ...+ f 1 False = ...+If the first arg matches '1' but the second does not match 'True', we+cannot jump to the third equation! Because the same argument might+match '2'!+Hence we don't regard 1 and 2, or (n+1) and (n+2), as part of the same group.+-}
+ src/Language/Haskell/Liquid/Desugar710/Match.hs-boot view
@@ -0,0 +1,33 @@+module Language.Haskell.Liquid.Desugar710.Match where+import Var ( Id )+import TcType ( Type )+import DsMonad ( DsM, EquationInfo, MatchResult )+import CoreSyn ( CoreExpr )+import HsSyn ( LPat, HsMatchContext, MatchGroup, LHsExpr )+import Name ( Name )++match :: [Id]+ -> Type+ -> [EquationInfo]+ -> DsM MatchResult++matchWrapper+ :: HsMatchContext Name+ -> MatchGroup Id (LHsExpr Id)+ -> DsM ([Id], CoreExpr)++matchSimply+ :: CoreExpr+ -> HsMatchContext Name+ -> LPat Id+ -> CoreExpr+ -> CoreExpr+ -> DsM CoreExpr++matchSinglePat+ :: CoreExpr+ -> HsMatchContext Name+ -> LPat Id+ -> Type+ -> MatchResult+ -> DsM MatchResult
+ src/Language/Haskell/Liquid/Desugar710/MatchCon.hs view
@@ -0,0 +1,290 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++Pattern-matching constructors+-}++{-# LANGUAGE CPP #-}++module Language.Haskell.Liquid.Desugar710.MatchCon ( matchConFamily, matchPatSyn ) where++-- #include "HsVersions.h"++import {-# SOURCE #-} Language.Haskell.Liquid.Desugar710.Match ( match )++import HsSyn+import DsBinds+import ConLike+import DataCon+import PatSyn+import TcType+import DsMonad+import Language.Haskell.Liquid.Desugar710.DsUtils+import MkCore ( mkCoreLets )+import Util+import ListSetOps ( runs )+import Id+import NameEnv+import SrcLoc+import DynFlags+import Outputable+import Control.Monad(liftM)++{-+We are confronted with the first column of patterns in a set of+equations, all beginning with constructors from one ``family'' (e.g.,+@[]@ and @:@ make up the @List@ ``family''). We want to generate the+alternatives for a @Case@ expression. There are several choices:+\begin{enumerate}+\item+Generate an alternative for every constructor in the family, whether+they are used in this set of equations or not; this is what the Wadler+chapter does.+\begin{description}+\item[Advantages:]+(a)~Simple. (b)~It may also be that large sparsely-used constructor+families are mainly handled by the code for literals.+\item[Disadvantages:]+(a)~Not practical for large sparsely-used constructor families, e.g.,+the ASCII character set. (b)~Have to look up a list of what+constructors make up the whole family.+\end{description}++\item+Generate an alternative for each constructor used, then add a default+alternative in case some constructors in the family weren't used.+\begin{description}+\item[Advantages:]+(a)~Alternatives aren't generated for unused constructors. (b)~The+STG is quite happy with defaults. (c)~No lookup in an environment needed.+\item[Disadvantages:]+(a)~A spurious default alternative may be generated.+\end{description}++\item+``Do it right:'' generate an alternative for each constructor used,+and add a default alternative if all constructors in the family+weren't used.+\begin{description}+\item[Advantages:]+(a)~You will get cases with only one alternative (and no default),+which should be amenable to optimisation. Tuples are a common example.+\item[Disadvantages:]+(b)~Have to look up constructor families in TDE (as above).+\end{description}+\end{enumerate}++We are implementing the ``do-it-right'' option for now. The arguments+to @matchConFamily@ are the same as to @match@; the extra @Int@+returned is the number of constructors in the family.++The function @matchConFamily@ is concerned with this+have-we-used-all-the-constructors? question; the local function+@match_cons_used@ does all the real work.+-}++matchConFamily :: [Id]+ -> Type+ -> [[EquationInfo]]+ -> DsM MatchResult+-- Each group of eqns is for a single constructor+matchConFamily (var:vars) ty groups+ = do dflags <- getDynFlags+ alts <- mapM (fmap toRealAlt . matchOneConLike vars ty) groups+ return (mkCoAlgCaseMatchResult dflags var ty alts)+ where+ toRealAlt alt = case alt_pat alt of+ RealDataCon dcon -> alt{ alt_pat = dcon }+ _ -> panic "matchConFamily: not RealDataCon"+matchConFamily [] _ _ = panic "matchConFamily []"++matchPatSyn :: [Id]+ -> Type+ -> [EquationInfo]+ -> DsM MatchResult+matchPatSyn (var:vars) ty eqns+ = do alt <- fmap toSynAlt $ matchOneConLike vars ty eqns+ return (mkCoSynCaseMatchResult var ty alt)+ where+ toSynAlt alt = case alt_pat alt of+ PatSynCon psyn -> alt{ alt_pat = psyn }+ _ -> panic "matchPatSyn: not PatSynCon"+matchPatSyn _ _ _ = panic "matchPatSyn []"++type ConArgPats = HsConDetails (LPat Id) (HsRecFields Id (LPat Id))++matchOneConLike :: [Id]+ -> Type+ -> [EquationInfo]+ -> DsM (CaseAlt ConLike)+matchOneConLike vars ty (eqn1 : eqns) -- All eqns for a single constructor+ = do { arg_vars <- selectConMatchVars val_arg_tys args1+ -- Use the first equation as a source of+ -- suggestions for the new variables++ -- Divide into sub-groups; see Note [Record patterns]+ ; let groups :: [[(ConArgPats, EquationInfo)]]+ groups = runs compatible_pats [ (pat_args (firstPat eqn), eqn)+ | eqn <- eqn1:eqns ]++ ; match_results <- mapM (match_group arg_vars) groups++ ; return $ MkCaseAlt{ alt_pat = con1,+ alt_bndrs = tvs1 ++ dicts1 ++ arg_vars,+ alt_wrapper = wrapper1,+ alt_result = foldr1 combineMatchResults match_results } }+ where+ ConPatOut { pat_con = L _ con1, pat_arg_tys = arg_tys, pat_wrap = wrapper1,+ pat_tvs = tvs1, pat_dicts = dicts1, pat_args = args1 }+ = firstPat eqn1+ fields1 = case con1 of+ RealDataCon dcon1 -> dataConFieldLabels dcon1+ PatSynCon{} -> []++ val_arg_tys = case con1 of+ RealDataCon dcon1 -> dataConInstOrigArgTys dcon1 inst_tys+ PatSynCon psyn1 -> patSynInstArgTys psyn1 inst_tys+ inst_tys = -- ASSERT( tvs1 `equalLength` ex_tvs )+ arg_tys ++ mkTyVarTys tvs1+ -- dataConInstOrigArgTys takes the univ and existential tyvars+ -- and returns the types of the *value* args, which is what we want++-- ex_tvs = case con1 of+-- RealDataCon dcon1 -> dataConExTyVars dcon1+-- PatSynCon psyn1 -> patSynExTyVars psyn1++ match_group :: [Id] -> [(ConArgPats, EquationInfo)] -> DsM MatchResult+ -- All members of the group have compatible ConArgPats+ match_group arg_vars arg_eqn_prs+ = -- ASSERT( notNull arg_eqn_prs )+ do { (wraps, eqns') <- liftM unzip (mapM shift arg_eqn_prs)+ ; let group_arg_vars = select_arg_vars arg_vars arg_eqn_prs+ ; match_result <- match (group_arg_vars ++ vars) ty eqns'+ ; return (adjustMatchResult (foldr1 (.) wraps) match_result) }++ shift (_, eqn@(EqnInfo { eqn_pats = ConPatOut{ pat_tvs = tvs, pat_dicts = ds,+ pat_binds = bind, pat_args = args+ } : pats }))+ = do ds_bind <- dsTcEvBinds bind+ return ( wrapBinds (tvs `zip` tvs1)+ . wrapBinds (ds `zip` dicts1)+ . mkCoreLets ds_bind+ , eqn { eqn_pats = conArgPats val_arg_tys args ++ pats }+ )+ shift (_, (EqnInfo { eqn_pats = ps })) = pprPanic "matchOneCon/shift" (ppr ps)++ -- Choose the right arg_vars in the right order for this group+ -- Note [Record patterns]+ select_arg_vars arg_vars ((arg_pats, _) : _)+ | RecCon flds <- arg_pats+ , let rpats = rec_flds flds+ , not (null rpats) -- Treated specially; cf conArgPats+ = -- ASSERT2( length fields1 == length arg_vars,+ -- ppr con1 $$ ppr fields1 $$ ppr arg_vars )+ map lookup_fld rpats+ | otherwise+ = arg_vars+ where+ fld_var_env = mkNameEnv $ zipEqual "get_arg_vars" fields1 arg_vars+ lookup_fld (L _ rpat) = lookupNameEnv_NF fld_var_env+ (idName (unLoc (hsRecFieldId rpat)))+ select_arg_vars _ [] = panic "matchOneCon/select_arg_vars []"+matchOneConLike _ _ [] = panic "matchOneCon []"++-----------------+compatible_pats :: (ConArgPats,a) -> (ConArgPats,a) -> Bool+-- Two constructors have compatible argument patterns if the number+-- and order of sub-matches is the same in both cases+compatible_pats (RecCon flds1, _) (RecCon flds2, _) = same_fields flds1 flds2+compatible_pats (RecCon flds1, _) _ = null (rec_flds flds1)+compatible_pats _ (RecCon flds2, _) = null (rec_flds flds2)+compatible_pats _ _ = True -- Prefix or infix con++same_fields :: HsRecFields Id (LPat Id) -> HsRecFields Id (LPat Id) -> Bool+same_fields flds1 flds2+ = all2 (\(L _ f1) (L _ f2)+ -> unLoc (hsRecFieldId f1) == unLoc (hsRecFieldId f2))+ (rec_flds flds1) (rec_flds flds2)+++-----------------+selectConMatchVars :: [Type] -> ConArgPats -> DsM [Id]+selectConMatchVars arg_tys (RecCon {}) = newSysLocalsDs arg_tys+selectConMatchVars _ (PrefixCon ps) = selectMatchVars (map unLoc ps)+selectConMatchVars _ (InfixCon p1 p2) = selectMatchVars [unLoc p1, unLoc p2]++conArgPats :: [Type] -- Instantiated argument types+ -- Used only to fill in the types of WildPats, which+ -- are probably never looked at anyway+ -> ConArgPats+ -> [Pat Id]+conArgPats _arg_tys (PrefixCon ps) = map unLoc ps+conArgPats _arg_tys (InfixCon p1 p2) = [unLoc p1, unLoc p2]+conArgPats arg_tys (RecCon (HsRecFields { rec_flds = rpats }))+ | null rpats = map WildPat arg_tys+ -- Important special case for C {}, which can be used for a+ -- datacon that isn't declared to have fields at all+ | otherwise = map (unLoc . hsRecFieldArg . unLoc) rpats++{-+Note [Record patterns]+~~~~~~~~~~~~~~~~~~~~~~+Consider+ data T = T { x,y,z :: Bool }++ f (T { y=True, x=False }) = ...++We must match the patterns IN THE ORDER GIVEN, thus for the first+one we match y=True before x=False. See Trac #246; or imagine+matching against (T { y=False, x=undefined }): should fail without+touching the undefined.++Now consider:++ f (T { y=True, x=False }) = ...+ f (T { x=True, y= False}) = ...++In the first we must test y first; in the second we must test x+first. So we must divide even the equations for a single constructor+T into sub-goups, based on whether they match the same field in the+same order. That's what the (runs compatible_pats) grouping.++All non-record patterns are "compatible" in this sense, because the+positional patterns (T a b) and (a `T` b) all match the arguments+in order. Also T {} is special because it's equivalent to (T _ _).+Hence the (null rpats) checks here and there.+++Note [Existentials in shift_con_pat]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+ data T = forall a. Ord a => T a (a->Int)++ f (T x f) True = ...expr1...+ f (T y g) False = ...expr2..++When we put in the tyvars etc we get++ f (T a (d::Ord a) (x::a) (f::a->Int)) True = ...expr1...+ f (T b (e::Ord b) (y::a) (g::a->Int)) True = ...expr2...++After desugaring etc we'll get a single case:++ f = \t::T b::Bool ->+ case t of+ T a (d::Ord a) (x::a) (f::a->Int)) ->+ case b of+ True -> ...expr1...+ False -> ...expr2...++*** We have to substitute [a/b, d/e] in expr2! **+Hence+ False -> ....((/\b\(e:Ord b).expr2) a d)....++Originally I tried to use+ (\b -> let e = d in expr2) a+to do this substitution. While this is "correct" in a way, it fails+Lint, because e::Ord b but d::Ord a.+-}
+ src/Language/Haskell/Liquid/Desugar710/MatchLit.hs view
@@ -0,0 +1,395 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++Pattern-matching literal patterns+-}++{-# LANGUAGE CPP, ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes #-}++module Language.Haskell.Liquid.Desugar710.MatchLit ( dsLit, dsOverLit, hsLitKey, hsOverLitKey+ , tidyLitPat, tidyNPat+ , matchLiterals, matchNPlusKPats, matchNPats+ , warnAboutIdentities, warnAboutEmptyEnumerations+ ) where++-- #include "HsVersions.h"++import {-# SOURCE #-} Language.Haskell.Liquid.Desugar710.Match ( match )+import {-# SOURCE #-} Language.Haskell.Liquid.Desugar710.DsExpr ( dsExpr )++import DsMonad+import Language.Haskell.Liquid.Desugar710.DsUtils++import HsSyn++import Id+import CoreSyn+import MkCore+import TyCon+import DataCon+import TcHsSyn ( shortCutLit )+import TcType+import Name+import Type+import PrelNames+import TysWiredIn+import Literal+import SrcLoc+import Data.Ratio+import Outputable+import BasicTypes+import DynFlags+import Util+import FastString++{-+************************************************************************+* *+ Desugaring literals+ [used to be in DsExpr, but DsMeta needs it,+ and it's nice to avoid a loop]+* *+************************************************************************++We give int/float literals type @Integer@ and @Rational@, respectively.+The typechecker will (presumably) have put \tr{from{Integer,Rational}s}+around them.++ToDo: put in range checks for when converting ``@i@''+(or should that be in the typechecker?)++For numeric literals, we try to detect there use at a standard type+(@Int@, @Float@, etc.) are directly put in the right constructor.+[NB: down with the @App@ conversion.]++See also below where we look for @DictApps@ for \tr{plusInt}, etc.+-}++dsLit :: HsLit -> DsM CoreExpr+dsLit (HsStringPrim _ s) = return (Lit (MachStr s))+dsLit (HsCharPrim _ c) = return (Lit (MachChar c))+dsLit (HsIntPrim _ i) = return (Lit (MachInt i))+dsLit (HsWordPrim _ w) = return (Lit (MachWord w))+dsLit (HsInt64Prim _ i) = return (Lit (MachInt64 i))+dsLit (HsWord64Prim _ w) = return (Lit (MachWord64 w))+dsLit (HsFloatPrim f) = return (Lit (MachFloat (fl_value f)))+dsLit (HsDoublePrim d) = return (Lit (MachDouble (fl_value d)))++dsLit (HsChar _ c) = return (mkCharExpr c)+dsLit (HsString _ str) = mkStringExprFS str+dsLit (HsInteger _ i _) = mkIntegerExpr i+dsLit (HsInt _ i) = do dflags <- getDynFlags+ return (mkIntExpr dflags i)++dsLit (HsRat r ty) = do+ num <- mkIntegerExpr (numerator (fl_value r))+ denom <- mkIntegerExpr (denominator (fl_value r))+ return (mkConApp ratio_data_con [Type integer_ty, num, denom])+ where+ (ratio_data_con, integer_ty)+ = case tcSplitTyConApp ty of+ (tycon, [i_ty]) -> -- ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)+ (head (tyConDataCons tycon), i_ty)+ x -> pprPanic "dsLit" (ppr x)++dsOverLit :: HsOverLit Id -> DsM CoreExpr+dsOverLit lit = do { dflags <- getDynFlags+ ; warnAboutOverflowedLiterals dflags lit+ ; dsOverLit' dflags lit }++dsOverLit' :: DynFlags -> HsOverLit Id -> DsM CoreExpr+-- Post-typechecker, the SyntaxExpr field of an OverLit contains+-- (an expression for) the literal value itself+dsOverLit' dflags (OverLit { ol_val = val, ol_rebindable = rebindable+ , ol_witness = witness, ol_type = ty })+ | not rebindable+ , Just expr <- shortCutLit dflags val ty = dsExpr expr -- Note [Literal short cut]+ | otherwise = dsExpr witness++{-+Note [Literal short cut]+~~~~~~~~~~~~~~~~~~~~~~~~+The type checker tries to do this short-cutting as early as possible, but+because of unification etc, more information is available to the desugarer.+And where it's possible to generate the correct literal right away, it's+much better to do so.+++************************************************************************+* *+ Warnings about overflowed literals+* *+************************************************************************++Warn about functions like toInteger, fromIntegral, that convert+between one type and another when the to- and from- types are the+same. Then it's probably (albeit not definitely) the identity+-}++warnAboutIdentities :: DynFlags -> CoreExpr -> Type -> DsM ()+warnAboutIdentities dflags (Var conv_fn) type_of_conv+ | wopt Opt_WarnIdentities dflags+ , idName conv_fn `elem` conversionNames+ , Just (arg_ty, res_ty) <- splitFunTy_maybe type_of_conv+ , arg_ty `eqType` res_ty -- So we are converting ty -> ty+ = warnDs (vcat [ ptext (sLit "Call of") <+> ppr conv_fn <+> dcolon <+> ppr type_of_conv+ , nest 2 $ ptext (sLit "can probably be omitted")+ , parens (ptext (sLit "Use -fno-warn-identities to suppress this message"))+ ])+warnAboutIdentities _ _ _ = return ()++conversionNames :: [Name]+conversionNames+ = [ toIntegerName, toRationalName+ , fromIntegralName, realToFracName ]+ -- We can't easily add fromIntegerName, fromRationalName,+ -- because they are generated by literals++warnAboutOverflowedLiterals :: DynFlags -> HsOverLit Id -> DsM ()+warnAboutOverflowedLiterals _dflags _lit+ | otherwise = return ()++{-+Note [Suggest NegativeLiterals]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If you write+ x :: Int8+ x = -128+it'll parse as (negate 128), and overflow. In this case, suggest NegativeLiterals.+We get an erroneous suggestion for+ x = 128+but perhaps that does not matter too much.+-}++warnAboutEmptyEnumerations :: DynFlags -> LHsExpr Id -> Maybe (LHsExpr Id) -> LHsExpr Id -> DsM ()+-- Warns about [2,3 .. 1] which returns the empty list+-- Only works for integral types, not floating point+warnAboutEmptyEnumerations _dflags _fromExpr _mThnExpr _toExpr+ | otherwise = return ()+++{-+************************************************************************+* *+ Tidying lit pats+* *+************************************************************************+-}++tidyLitPat :: HsLit -> Pat Id+-- Result has only the following HsLits:+-- HsIntPrim, HsWordPrim, HsCharPrim, HsFloatPrim+-- HsDoublePrim, HsStringPrim, HsString+-- * HsInteger, HsRat, HsInt can't show up in LitPats+-- * We get rid of HsChar right here+tidyLitPat (HsChar src c) = unLoc (mkCharLitPat src c)+tidyLitPat (HsString src s)+ | lengthFS s <= 1 -- Short string literals only+ = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon+ [mkCharLitPat src c, pat] [charTy])+ (mkNilPat charTy) (unpackFS s)+ -- The stringTy is the type of the whole pattern, not+ -- the type to instantiate (:) or [] with!+tidyLitPat lit = LitPat lit++----------------+tidyNPat :: (HsLit -> Pat Id) -- How to tidy a LitPat+ -- We need this argument because tidyNPat is called+ -- both by Match and by Check, but they tidy LitPats+ -- slightly differently; and we must desugar+ -- literals consistently (see Trac #5117)+ -> HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id+ -> Pat Id+tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _+ -- False: Take short cuts only if the literal is not using rebindable syntax+ --+ -- Once that is settled, look for cases where the type of the+ -- entire overloaded literal matches the type of the underlying literal,+ -- and in that case take the short cut+ -- NB: Watch out for weird cases like Trac #3382+ -- f :: Int -> Int+ -- f "blah" = 4+ -- which might be ok if we hvae 'instance IsString Int'+ --++ | isIntTy ty, Just int_lit <- mb_int_lit+ = mk_con_pat intDataCon (HsIntPrim "" int_lit)+ | isWordTy ty, Just int_lit <- mb_int_lit+ = mk_con_pat wordDataCon (HsWordPrim "" int_lit)+ | isFloatTy ty, Just rat_lit <- mb_rat_lit = mk_con_pat floatDataCon (HsFloatPrim rat_lit)+ | isDoubleTy ty, Just rat_lit <- mb_rat_lit = mk_con_pat doubleDataCon (HsDoublePrim rat_lit)+ | isStringTy ty, Just str_lit <- mb_str_lit+ = tidy_lit_pat (HsString "" str_lit)+ where+ mk_con_pat :: DataCon -> HsLit -> Pat Id+ mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] [])++ mb_int_lit :: Maybe Integer+ mb_int_lit = case (mb_neg, val) of+ (Nothing, HsIntegral _ i) -> Just i+ (Just _, HsIntegral _ i) -> Just (-i)+ _ -> Nothing++ mb_rat_lit :: Maybe FractionalLit+ mb_rat_lit = case (mb_neg, val) of+ (Nothing, HsIntegral _ i) -> Just (integralFractionalLit (fromInteger i))+ (Just _, HsIntegral _ i) -> Just (integralFractionalLit+ (fromInteger (-i)))+ (Nothing, HsFractional f) -> Just f+ (Just _, HsFractional f) -> Just (negateFractionalLit f)+ _ -> Nothing++ mb_str_lit :: Maybe FastString+ mb_str_lit = case (mb_neg, val) of+ (Nothing, HsIsString _ s) -> Just s+ _ -> Nothing++tidyNPat _ over_lit mb_neg eq+ = NPat (noLoc over_lit) mb_neg eq++{-+************************************************************************+* *+ Pattern matching on LitPat+* *+************************************************************************+-}++matchLiterals :: [Id]+ -> Type -- Type of the whole case expression+ -> [[EquationInfo]] -- All PgLits+ -> DsM MatchResult++matchLiterals (var:vars) ty sub_groups+ = -- ASSERT( notNull sub_groups && all notNull sub_groups )+ do { -- Deal with each group+ ; alts <- mapM match_group sub_groups++ -- Combine results. For everything except String+ -- we can use a case expression; for String we need+ -- a chain of if-then-else+ ; if isStringTy (idType var) then+ do { eq_str <- dsLookupGlobalId eqStringName+ ; mrs <- mapM (wrap_str_guard eq_str) alts+ ; return (foldr1 combineMatchResults mrs) }+ else+ return (mkCoPrimCaseMatchResult var ty alts)+ }+ where+ match_group :: [EquationInfo] -> DsM (Literal, MatchResult)+ match_group eqns+ = do dflags <- getDynFlags+ let LitPat hs_lit = firstPat (head eqns)+ match_result <- match vars ty (shiftEqns eqns)+ return (hsLitKey dflags hs_lit, match_result)++ wrap_str_guard :: Id -> (Literal,MatchResult) -> DsM MatchResult+ -- Equality check for string literals+ wrap_str_guard eq_str (MachStr s, mr)+ = do { -- We now have to convert back to FastString. Perhaps there+ -- should be separate MachBytes and MachStr constructors?+ let s' = mkFastStringByteString s+ ; lit <- mkStringExprFS s'+ ; let pred = mkApps (Var eq_str) [Var var, lit]+ ; return (mkGuardedMatchResult pred mr) }+ wrap_str_guard _ (l, _) = pprPanic "matchLiterals/wrap_str_guard" (ppr l)++matchLiterals [] _ _ = panic "matchLiterals []"++---------------------------+hsLitKey :: DynFlags -> HsLit -> Literal+-- Get a Core literal to use (only) a grouping key+-- Hence its type doesn't need to match the type of the original literal+-- (and doesn't for strings)+-- It only works for primitive types and strings;+-- others have been removed by tidy+hsLitKey dflags (HsIntPrim _ i) = mkMachInt dflags i+hsLitKey dflags (HsWordPrim _ w) = mkMachWord dflags w+hsLitKey _ (HsInt64Prim _ i) = mkMachInt64 i+hsLitKey _ (HsWord64Prim _ w) = mkMachWord64 w+hsLitKey _ (HsCharPrim _ c) = MachChar c+hsLitKey _ (HsStringPrim _ s) = MachStr s+hsLitKey _ (HsFloatPrim f) = MachFloat (fl_value f)+hsLitKey _ (HsDoublePrim d) = MachDouble (fl_value d)+hsLitKey _ (HsString _ s) = MachStr (fastStringToByteString s)+hsLitKey _ l = pprPanic "hsLitKey" (ppr l)++---------------------------+hsOverLitKey :: OutputableBndr a => HsOverLit a -> Bool -> Literal+-- Ditto for HsOverLit; the boolean indicates to negate+hsOverLitKey (OverLit { ol_val = l }) neg = litValKey l neg++---------------------------+litValKey :: OverLitVal -> Bool -> Literal+litValKey (HsIntegral _ i) False = MachInt i+litValKey (HsIntegral _ i) True = MachInt (-i)+litValKey (HsFractional r) False = MachFloat (fl_value r)+litValKey (HsFractional r) True = MachFloat (negate (fl_value r))+litValKey (HsIsString _ s) _neg = {- ASSERT( not neg) -} MachStr+ (fastStringToByteString s)++{-+************************************************************************+* *+ Pattern matching on NPat+* *+************************************************************************+-}++matchNPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult+matchNPats (var:vars) ty (eqn1:eqns) -- All for the same literal+ = do { let NPat (L _ lit) mb_neg eq_chk = firstPat eqn1+ ; lit_expr <- dsOverLit lit+ ; neg_lit <- case mb_neg of+ Nothing -> return lit_expr+ Just neg -> do { neg_expr <- dsExpr neg+ ; return (App neg_expr lit_expr) }+ ; eq_expr <- dsExpr eq_chk+ ; let pred_expr = mkApps eq_expr [Var var, neg_lit]+ ; match_result <- match vars ty (shiftEqns (eqn1:eqns))+ ; return (mkGuardedMatchResult pred_expr match_result) }+matchNPats vars _ eqns = pprPanic "matchOneNPat" (ppr (vars, eqns))++{-+************************************************************************+* *+ Pattern matching on n+k patterns+* *+************************************************************************++For an n+k pattern, we use the various magic expressions we've been given.+We generate:+\begin{verbatim}+ if ge var lit then+ let n = sub var lit+ in <expr-for-a-successful-match>+ else+ <try-next-pattern-or-whatever>+\end{verbatim}+-}++matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult+-- All NPlusKPats, for the *same* literal k+matchNPlusKPats (var:vars) ty (eqn1:eqns)+ = do { let NPlusKPat (L _ n1) (L _ lit) ge minus = firstPat eqn1+ ; ge_expr <- dsExpr ge+ ; minus_expr <- dsExpr minus+ ; lit_expr <- dsOverLit lit+ ; let pred_expr = mkApps ge_expr [Var var, lit_expr]+ minusk_expr = mkApps minus_expr [Var var, lit_expr]+ (wraps, eqns') = mapAndUnzip (shift n1) (eqn1:eqns)+ ; match_result <- match vars ty eqns'+ ; return (mkGuardedMatchResult pred_expr $+ mkCoLetMatchResult (NonRec n1 minusk_expr) $+ adjustMatchResult (foldr1 (.) wraps) $+ match_result) }+ where+ shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat (L _ n) _ _ _ : pats })+ = (wrapBind n n1, eqn { eqn_pats = pats })+ -- The wrapBind is a no-op for the first equation+ shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e)++matchNPlusKPats vars _ eqns = pprPanic "matchNPlusKPats" (ppr (vars, eqns))
src/Language/Haskell/Liquid/Errors.hs view
@@ -5,7 +5,7 @@ -- | This module contains the functions related to @Error@ type, -- in particular, to @tidyError@ using a solution, and @pprint@ errors. -module Language.Haskell.Liquid.Errors (tidyError) where+module Language.Haskell.Liquid.Errors (tidyError, exitWithPanic) where import Control.Applicative ((<$>), (<*>))@@ -28,22 +28,22 @@ import Language.Haskell.Liquid.Types import SrcLoc (SrcSpan) import Text.PrettyPrint.HughesPJ-+import qualified Control.Exception as Ex type Ctx = M.HashMap Symbol SpecType ------------------------------------------------------------------------ tidyError :: FixSolution -> Error -> Error -------------------------------------------------------------------------tidyError sol - = fmap (tidySpecType Full) +tidyError sol+ = fmap (tidySpecType Full) . tidyErrContext sol . applySolution sol tidyErrContext _ err@(ErrSubType {}) = err { ctx = c', tact = subst θ tA, texp = subst θ tE } where- (θ, c') = tidyCtx xs $ ctx err + (θ, c') = tidyCtx xs $ ctx err xs = syms tA ++ syms tE tA = tact err tE = texp err@@ -52,9 +52,9 @@ = err ----------------------------------------------------------------------------------tidyCtx :: [Symbol] -> Ctx -> (Subst, Ctx) +tidyCtx :: [Symbol] -> Ctx -> (Subst, Ctx) ----------------------------------------------------------------------------------tidyCtx xs m = (θ, M.fromList yts) +tidyCtx xs m = (θ, M.fromList yts) where yts = [tBind x t | (x, t) <- xts] (θ, xts) = tidyTemps $ second stripReft <$> tidyREnv xs m@@ -62,23 +62,23 @@ stripReft :: SpecType -> SpecType-stripReft t = maybe t' (strengthen t') ro +stripReft t = maybe t' (strengthen t') ro where- (t', ro) = stripRType t + (t', ro) = stripRType t stripRType :: SpecType -> (SpecType, Maybe RReft) stripRType st = (t', ro) where t' = fmap (const (uTop mempty)) t- ro = stripRTypeBase t - t = simplifyBounds st + ro = stripRTypeBase t+ t = simplifyBounds st tidyREnv :: [Symbol] -> M.HashMap Symbol SpecType -> [(Symbol, SpecType)] tidyREnv xs m = [(x, t) | x <- xs', t <- maybeToList (M.lookup x m), ok t] where xs' = expandFix deps xs deps y = fromMaybe [] $ fmap (syms . rTypeReft) $ M.lookup y m- ok = not . isFunTy + ok = not . isFunTy expandFix :: (Eq a, Hashable a) => (a -> [a]) -> [a] -> [a] expandFix f xs = S.toList $ go S.empty xs@@ -99,10 +99,10 @@ ys = [ x | (x,_) <- xts, isTmpSymbol x] niceTemps :: [Symbol]-niceTemps = mkSymbol <$> xs ++ ys +niceTemps = mkSymbol <$> xs ++ ys where mkSymbol = symbol . ('?' :)- xs = single <$> ['a' .. 'z'] + xs = single <$> ['a' .. 'z'] ys = ("a" ++) <$> [show n | n <- [0 ..]] @@ -110,12 +110,12 @@ -- | Pretty Printing Error Messages ------------------------------------ ------------------------------------------------------------------------ --- | Need to put @PPrint Error@ instance here (instead of in Types), +-- | Need to put @PPrint Error@ instance here (instead of in Types), -- as it depends on @PPrint SpecTypes@, which lives in this module. instance PPrint Error where pprint = pprintTidy Full- pprintTidy k = ppError k . fmap ppSpecTypeErr + pprintTidy k = ppError k . fmap ppSpecTypeErr ppSpecTypeErr :: SpecType -> Doc ppSpecTypeErr@@ -124,7 +124,7 @@ noCasts (ECst x _) = x noCasts e = e --- full = isNontrivialVV $ rTypeValueVar t = +-- full = isNontrivialVV $ rTypeValueVar t = instance Show Error where show = showpp@@ -163,9 +163,9 @@ ppError' Full dSp (ErrSubType _ _ c tA tE) = dSp <+> text "Liquid Type Mismatch" $+$ sepVcat blankLine- [ nests 2 [ text "Inferred type" + [ nests 2 [ text "Inferred type" , text "VV :" <+> pprint tA]- , nests 2 [ text "not a subtype of Required type" + , nests 2 [ text "not a subtype of Required type" , text "VV :" <+> pprint tE] , nests 2 [ text "In Context" , pprint c ]]@@ -173,9 +173,9 @@ ppError' _ dSp (ErrFCrash _ _ c tA tE) = dSp <+> text "Fixpoint Crash on Constraint" $+$ sepVcat blankLine- [ nests 2 [ text "Inferred type" + [ nests 2 [ text "Inferred type" , text "VV :" <+> pprint tA]- , nests 2 [ text "Required type" + , nests 2 [ text "Required type" , text "VV :" <+> pprint tE] , nests 2 [ text "Context" , pprint c ]]@@ -258,7 +258,7 @@ = dSp <+> text "Malformed Type Alias Application" $+$ text "Type alias:" <+> pprint name $+$ text "Defined at:" <+> pprint dl- $+$ text "Expects" <+> pprint dn <+> text "arguments, but is given" <+> pprint n + $+$ text "Expects" <+> pprint dn <+> text "arguments, but is given" <+> pprint n ppError' _ dSp (ErrSaved _ s) = dSp <+> s@@ -297,4 +297,8 @@ errSaved :: SrcSpan -> String -> Error errSaved x = ErrSaved x . text++-- | Throw a panic exception+exitWithPanic :: String -> a+exitWithPanic = Ex.throw . errOther . text
src/Language/Haskell/Liquid/GhcInterface.hs view
@@ -40,26 +40,25 @@ import qualified Data.HashSet as S import System.Console.CmdArgs.Verbosity (whenLoud)-import System.Directory (removeFile, createDirectory, doesFileExist)+import System.Directory (removeFile, createDirectoryIfMissing, doesFileExist) import Language.Fixpoint.Types hiding (Result, Expr) import Language.Fixpoint.Misc import Language.Haskell.Liquid.Types+import Language.Haskell.Liquid.Errors import Language.Haskell.Liquid.ANFTransform import Language.Haskell.Liquid.Bare import Language.Haskell.Liquid.GhcMisc import Language.Haskell.Liquid.Misc import Language.Haskell.Liquid.PrettyPrint- import Language.Haskell.Liquid.Visitors--import Language.Haskell.Liquid.CmdLine (withPragmas)+import Language.Haskell.Liquid.CmdLine (withCabal, withPragmas) import Language.Haskell.Liquid.Parse+import qualified Language.Haskell.Liquid.Measure as Ms import Language.Fixpoint.Names import Language.Fixpoint.Files -import qualified Language.Haskell.Liquid.Measure as Ms --------------------------------------------------------------------@@ -79,6 +78,7 @@ addTarget =<< guessTarget target Nothing (name,tgtSpec) <- liftIO $ parseSpec target cfg <- liftIO $ withPragmas cfg0 target $ Ms.pragmas tgtSpec+ cfg <- liftIO $ withCabal cfg let paths = idirs cfg updateDynFlags cfg liftIO $ whenLoud $ putStrLn ("paths = " ++ show paths)@@ -205,7 +205,7 @@ cleanFiles :: FilePath -> IO () cleanFiles fn = do forM_ bins (tryIgnore "delete binaries" . removeFileIfExists)- tryIgnore "create temp directory" $ createDirectory dir+ tryIgnore "create temp directory" $ createDirectoryIfMissing False dir where bins = replaceExtension fn <$> ["hi", "o"] dir = tempDirectory fn@@ -377,11 +377,6 @@ ------------------------------------------------------------------------ -- Dealing With Errors ------------------------------------------------- ---------------------------------------------------------------------------- | Throw a panic exception-exitWithPanic :: String -> a-exitWithPanic = Ex.throw . errOther . text- -- | Convert a GHC error into one of ours instance Result SourceError where result = (`Crash` "Invalid Source")
src/Language/Haskell/Liquid/GhcMisc.hs view
@@ -79,7 +79,8 @@ #if __GLASGOW_HASKELL__ < 710 import Language.Haskell.Liquid.Desugar.HscMain #else-import qualified HscMain as GHC+import Language.Haskell.Liquid.Desugar710.HscMain+--import qualified HscMain as GHC #endif @@ -469,7 +470,7 @@ synTyConRhs_maybe :: TyCon -> Maybe Type -#if __GLASGOW_HASKELL__ < 710+tcRnLookupRdrName :: HscEnv -> GHC.Located RdrName -> IO (Messages, Maybe [Name]) desugarModule tcm = do let ms = pm_mod_summary $ tm_parsed_module tcm @@ -480,7 +481,17 @@ guts <- liftIO $ hscDesugarWithLoc hsc_env_tmp ms tcg return $ DesugaredModule { dm_typechecked_module = tcm, dm_core_module = guts } +#if __GLASGOW_HASKELL__ < 710 +-- desugarModule tcm = do+-- let ms = pm_mod_summary $ tm_parsed_module tcm +-- -- let ms = modSummary tcm+-- let (tcg, _) = tm_internals_ tcm+-- hsc_env <- getSession+-- let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }+-- guts <- liftIO $ hscDesugarWithLoc hsc_env_tmp ms tcg+-- return $ DesugaredModule { dm_typechecked_module = tcm, dm_core_module = guts }+ symbolFastString = T.unsafeDupablePerformIO . mkFastStringByteString . T.encodeUtf8 . symbolText lintCoreBindings = CoreLint.lintCoreBindings@@ -490,9 +501,11 @@ = Just rhs synTyConRhs_maybe _ = Nothing +tcRnLookupRdrName env rn = TcRnDriver.tcRnLookupRdrName env (unLoc rn)+ #else -desugarModule = GHC.desugarModule+-- desugarModule = GHC.desugarModule symbolFastString = mkFastStringByteString . T.encodeUtf8 . symbolText @@ -501,5 +514,7 @@ lintCoreBindings = CoreLint.lintCoreBindings CoreDoNothing synTyConRhs_maybe = TC.synTyConRhs_maybe++tcRnLookupRdrName = TcRnDriver.tcRnLookupRdrName #endif
src/Language/Haskell/Liquid/Literals.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} module Language.Haskell.Liquid.Literals ( literalFRefType, literalFReft, literalConst ) where@@ -5,12 +6,15 @@ import TypeRep import Literal +import Language.Haskell.Liquid.Measure import Language.Haskell.Liquid.Types import Language.Haskell.Liquid.RefType import Language.Haskell.Liquid.CoreToLogic (mkLit) -import Language.Fixpoint.Types (exprReft)+import qualified Language.Fixpoint.Types as F +import qualified Data.Text as T+import qualified Data.Text.Encoding as T import Data.Monoid import Control.Applicative @@ -25,11 +29,19 @@ makeRTypeBase _ _ = error "RefType : makeRTypeBase" -literalFRefType tce l- = makeRTypeBase (literalType l) (literalFReft tce l)+literalFRefType l+ = makeRTypeBase (literalType l) (literalFReft l) -literalFReft tce = maybe mempty exprReft . snd . literalConst tce+literalFReft l = maybe mempty mkReft $ mkLit l +mkReft e = case e of+ F.ESym (F.SL str) ->+ -- FIXME: unsorted equality is shady, better to not embed Add# as int..+ F.meet (F.uexprReft e)+ (F.reft "v" (F.PAtom F.Eq+ (F.EApp (name strLen) [F.EVar "v"])+ (F.ECon (F.I (fromIntegral (T.length str))))))+ _ -> F.exprReft e -- | `literalConst` returns `Nothing` for unhandled lits because -- otherwise string-literals show up as global int-constants
src/Language/Haskell/Liquid/Measure.hs view
@@ -12,10 +12,15 @@ , mapTy , dataConTypes , defRefType+ , strLen+ , wiredInMeasures ) where import GHC hiding (Located) import Var+import Type+import TysPrim+import TysWiredIn import Text.PrettyPrint.HughesPJ hiding (first) import Text.Printf (printf) import DataCon@@ -62,6 +67,7 @@ , hmeas :: !(S.HashSet LocSymbol) -- ^ Binders to turn into measures using haskell definitions , hbounds :: !(S.HashSet LocSymbol) -- ^ Binders to turn into bounds using haskell definitions , inlines :: !(S.HashSet LocSymbol) -- ^ Binders to turn into logic inline using haskell definitions+ , autosize :: !(S.HashSet LocSymbol) -- ^ Type Constructors that get automatically sizing info , pragmas :: ![Located String] -- ^ Command-line configurations passed in through source , cmeasures :: ![Measure ty ()] -- ^ Measures attached to a type-class , imeasures :: ![Measure ty bndr] -- ^ Mappings from (measure,type) -> measure@@ -172,6 +178,7 @@ , hmeas = S.union (hmeas s1) (hmeas s2) , hbounds = S.union (hbounds s1) (hbounds s2) , inlines = S.union (inlines s1) (inlines s2)+ , autosize = S.union (autosize s1) (autosize s2) , pragmas = pragmas s1 ++ pragmas s2 , cmeasures = cmeasures s1 ++ cmeasures s2 , imeasures = imeasures s1 ++ imeasures s2@@ -203,6 +210,7 @@ , hmeas = S.empty , hbounds = S.empty , inlines = S.empty+ , autosize = S.empty , pragmas = [] , cmeasures = [] , imeasures = []@@ -344,3 +352,15 @@ bodyPred fv (E e) = PAtom Eq fv e bodyPred fv (P p) = PIff (PBexp fv) p bodyPred fv (R v' p) = subst1 p (v', fv)+++-- | A wired-in measure @strLen@ that describes the length of a string+-- literal, with type @Addr#@.+strLen :: Measure SpecType ctor+strLen = M { name = dummyLoc "strLen"+ , sort = ofType (mkFunTy addrPrimTy intTy)+ , eqns = []+ }++wiredInMeasures :: MSpec SpecType DataCon+wiredInMeasures = mkMSpec' [strLen]
+ src/Language/Haskell/Liquid/Names.hs view
@@ -0,0 +1,6 @@+module Language.Haskell.Liquid.Names where++import Language.Fixpoint.Types+++lenLocSymbol = dummyLoc $ symbol ("autolen" :: String)
src/Language/Haskell/Liquid/Parse.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE TupleSections #-}@@ -17,13 +17,14 @@ import Text.Parsec.Error (newErrorMessage, Message (..)) import Text.Parsec.Pos (newPos) -import qualified Text.Parsec.Token as Token+import qualified Text.Parsec.Token as Token+import qualified Data.Text as T import qualified Data.HashMap.Strict as M import qualified Data.HashSet as S import Data.Monoid import Control.Applicative ((<$>), (<*), (<*>))-import Data.Char (isLower, isSpace, isAlpha)+import Data.Char (isLower, isSpace, isAlpha, isUpper, isAlphaNum) import Data.List (foldl', partition) import GHC (mkModuleName)@@ -191,7 +192,7 @@ holeRefP = reserved "_" >> spaces >> return (RHole . uTop) refasHoleP = try refaP <|> (reserved "_" >> return (Refa hole))- + -- FIXME: the use of `blanks = oneOf " \t"` here is a terrible and fragile hack -- to avoid parsing: --@@ -367,10 +368,6 @@ dummyRSort = RVar "dummy" mempty -refaP :: Parser Refa-refaP = try (refa <$> (brackets $ sepBy predP semi))- <|> Refa <$> predP- predicatesP = try (angles $ sepBy1 predicate1P comma) <|> return []@@ -493,6 +490,7 @@ | Lazy LocSymbol | HMeas LocSymbol | Inline LocSymbol+ | ASize LocSymbol | HBound LocSymbol | PBound (Bound ty Pred) | Pragma (Located String)@@ -532,6 +530,7 @@ show (Varia _) = "Varia" show (PBound _) = "Bound" show (RInst _) = "RInst"+ show (ASize _) = "ASize" mkSpec name xs = (name,)@@ -557,6 +556,7 @@ , Measure.lazy = S.fromList [s | Lazy s <- xs] , Measure.hmeas = S.fromList [s | HMeas s <- xs] , Measure.inlines = S.fromList [s | Inline s <- xs]+ , Measure.autosize = S.fromList [s | ASize s <- xs] , Measure.hbounds = S.fromList [s | HBound s <- xs] , Measure.pragmas = [s | Pragma s <- xs] , Measure.cmeasures = [m | CMeas m <- xs]@@ -572,6 +572,7 @@ specP = try (reservedToken "assume" >> liftM Assm tyBindP ) <|> (reservedToken "assert" >> liftM Asrt tyBindP )+ <|> (reservedToken "autosize" >> liftM ASize asizeP ) <|> (reservedToken "Local" >> liftM LAsrt tyBindP ) <|> try (reservedToken "measure" >> liftM Meas measureP ) <|> (reservedToken "measure" >> liftM HMeas hmeasureP )@@ -592,7 +593,7 @@ <|> (reservedToken "predicate" >> liftM PAlias paliasP ) <|> (reservedToken "expression">> liftM EAlias ealiasP ) <|> (reservedToken "embed" >> liftM Embed embedP )- <|> (reservedToken "qualif" >> liftM Qualif qualifierP)+ <|> (reservedToken "qualif" >> liftM Qualif (qualifierP sortP)) <|> (reservedToken "Decrease" >> liftM Decr decreaseP ) <|> (reservedToken "LAZYVAR" >> liftM LVars lazyVarP ) <|> (reservedToken "Strict" >> liftM Lazy lazyVarP )@@ -619,6 +620,9 @@ inlineP :: Parser LocSymbol inlineP = locParserP binderP +asizeP :: Parser LocSymbol+asizeP = locParserP binderP+ decreaseP :: Parser (LocSymbol, [Int]) decreaseP = mapSnd f <$> liftM2 (,) (locParserP binderP) (spaces >> (many integer)) where f = ((\n -> fromInteger n - 1) <$>)@@ -750,6 +754,19 @@ outTy (RFun _ _ t _) = Just t outTy _ = Nothing +locUpperIdP' = locParserP upperIdP'++upperIdP' :: Parser Symbol+upperIdP' = try $ symbol <$> condIdP' (isUpper . head)++condIdP' :: (String -> Bool) -> Parser Symbol+condIdP' f+ = do c <- letter+ let isAlphaNumOr' c = (isAlphaNum c) || ('\''== c)+ cs <- many (satisfy isAlphaNumOr')+ blanks+ if f (c:cs) then return (symbol $ T.pack $ c:cs) else parserZero+ binderP :: Parser Symbol binderP = try $ symbol <$> idP badc <|> pwr <$> parens (idP bad)@@ -836,25 +853,64 @@ dataDeclSizeP = do pos <- getPosition- x <- locUpperIdP+ x <- locUpperIdP' spaces fsize <- dataSizeP return $ D x [] [] [] [] pos fsize dataDeclFullP = do pos <- getPosition- x <- locUpperIdP+ x <- locUpperIdP' spaces fsize <- dataSizeP spaces- ts <- sepBy tyVarIdP spaces+ ts <- sepBy tyVarIdP blanks ps <- predVarDefsP whiteSpace >> reservedOp "=" >> whiteSpace dcs <- sepBy dataConP (reserved "|") whiteSpace return $ D x ts ps [] dcs pos fsize +---------------------------------------------------------------------+-- | Parsing Qualifiers ---------------------------------------------+--------------------------------------------------------------------- +-- qualifierP = do+-- pos <- getPosition+-- n <- upperIdP+-- params <- parens $ sepBy1 sortBindP comma+-- _ <- colon+-- body <- predP+-- return $ mkQual n params body pos+--+-- sortBindP = (,) <$> symbolP <* colon <*> sortP++sortP+ = try (parens $ sortP)+ -- <|> try (string "@" >> varSortP)+ <|> try (fApp (Left listFTyCon) . single <$> brackets sortP)+ -- <|> try bvSortP+ -- <|> try baseSortP+ -- THIS IS THE PROBLEM HEREHEREHERE <|> try (symbolSort <$> locLowerIdP)+ <|> try (fApp <$> (Left <$> fTyConP) <*> sepBy sortP blanks)+ <|> (FObj . symbol <$> lowerIdP)++-- varSortP = FVar <$> parens intP+-- funcSortP = parens $ FFunc <$> intP <* comma <*> sortsP++fTyConP :: Parser FTycon+fTyConP+ = (reserved "int" >> return intFTyCon)+ <|> (reserved "Integer" >> return intFTyCon)+ <|> (reserved "Int" >> return intFTyCon)+ <|> (reserved "int" >> return intFTyCon)+ <|> (reserved "real" >> return realFTyCon)+ <|> (reserved "bool" >> return boolFTyCon)+ <|> (symbolFTycon <$> locUpperIdP)++++ --------------------------------------------------------------------- ------------ Interacting with Fixpoint ------------------------------ ---------------------------------------------------------------------@@ -870,9 +926,10 @@ Just _ -> liftM2 (:) (between leftP rightP p) (betweenMany leftP rightP p) Nothing -> return [] --- specWrap = between (string "{-@" >> spaces) (spaces >> string "@-}")-specWraps = betweenMany (string "{-@" >> whiteSpace) (whiteSpace >> string "@-}")+specWraps = betweenMany (liquidBeginP >> whiteSpace) (whiteSpace >> liquidEndP) +liquidBeginP = string liquidBegin+liquidEndP = string liquidEnd --------------------------------------------------------------- -- | Bundling Parsers into a Typeclass ------------------------ ---------------------------------------------------------------
src/Language/Haskell/Liquid/PredType.hs view
@@ -325,10 +325,9 @@ pappArity = 7 -pappSort n = FFunc (2 * n) $ [ptycon] ++ args ++ [bSort]+pappSort n = FFunc (2 * n) $ [ptycon] ++ args ++ [boolSort] where ptycon = fApp (Left predFTyCon) $ FVar <$> [0..n-1] args = FVar <$> [n..(2*n-1)]- bSort = FApp boolFTyCon [] wiredSortedSyms = [(pappSym n, pappSort n) | n <- [1..pappArity]]
src/Language/Haskell/Liquid/RefType.hs view
@@ -48,13 +48,15 @@ , dataConSymbol, dataConMsReft, dataConReft , classBinds + , isSizeable+ -- * Manipulating Refinements in RTypes , rTypeSortedReft , rTypeSort , shiftVV , mkDataConIdsTy- , mkTyConInfo + , mkTyConInfo , strengthenRefTypeGen@@ -94,19 +96,20 @@ import Language.Haskell.Liquid.Variance import Language.Haskell.Liquid.Misc+import Language.Haskell.Liquid.Names import Language.Fixpoint.Misc import Language.Haskell.Liquid.GhcMisc (typeUniqueString, tvId, showPpr, stringTyVar, tyConTyVarsDef) import Language.Fixpoint.Names (listConName, tupConName) import Data.List (sort, foldl') -strengthenDataConType (x, t) = (x, fromRTypeRep trep{ty_res = tres}) - where - trep = toRTypeRep t +strengthenDataConType (x, t) = (x, fromRTypeRep trep{ty_res = tres})+ where+ trep = toRTypeRep t tres = ty_res trep `strengthen` U (exprReft expr) mempty mempty- xs = ty_binds trep + xs = ty_binds trep as = ty_vars trep- x' = symbol x + x' = symbol x expr | null xs && null as = EVar x' | null xs = EApp (dummyLoc x') [] | otherwise = EApp (dummyLoc x') (EVar <$> xs)@@ -151,7 +154,7 @@ , RefTypable c tv () , RefTypable c tv r , PPrint (RType c tv r)- , FreeVar c tv + , FreeVar c tv ) => Monoid (RType c tv r) where mempty = errorstar "mempty: RType"@@ -167,25 +170,27 @@ mempty = errorstar "mempty: RType 2" mappend _ _ = errorstar "mappend: RType 2" -instance (SubsTy c (RType b c ()) b, Monoid r, Reftable r, RefTypable b c r, RefTypable b c (), FreeVar b c, SubsTy c (RType b c ()) (RType b c ())) +instance (SubsTy c (RType b c ()) b, Monoid r, Reftable r, RefTypable b c r, RefTypable b c (), FreeVar b c, SubsTy c (RType b c ()) (RType b c ())) => Monoid (RTProp b c r) where mempty = errorstar "mempty: RTProp" mappend (RPropP s1 r1) (RPropP s2 r2) | isTauto r1 = RPropP s2 r2 | isTauto r2 = RPropP s1 r1- | otherwise = RPropP s1 $ r1 `meet` + | otherwise = RPropP s1 $ r1 `meet` (subst (mkSubst $ zip (fst <$> s2) (EVar . fst <$> s1)) r2)- - mappend (RProp s1 t1) (RProp s2 t2) ++ mappend (RProp s1 t1) (RProp s2 t2) | isTrivial t1 = RProp s2 t2 | isTrivial t2 = RProp s1 t1- | otherwise = RProp s1 $ t1 `strengthenRefType` + | otherwise = RProp s1 $ t1 `strengthenRefType` (subst (mkSubst $ zip (fst <$> s2) (EVar . fst <$> s1)) t2) - mappend _ _ = errorstar "Reftable.mappend on invalid inputs"+-- mappend (RPropP s1 t1) (RProp s2 t2) = errorstar "Reftable.mappend on invalid inputs"+ mappend t1 t2 = errorstar ("Reftable.mappend on invalid inputs" ++ show (t1, t2))+-- mappend _ _ = errorstar "Reftable.mappend on invalid inputs" -instance (Reftable r, RefTypable c tv r, RefTypable c tv (), FreeVar c tv, SubsTy tv (RType c tv ()) (RType c tv ()), SubsTy tv (RType c tv ()) c) +instance (Reftable r, RefTypable c tv r, RefTypable c tv (), FreeVar c tv, SubsTy tv (RType c tv ()) (RType c tv ()), SubsTy tv (RType c tv ()) c) => Reftable (RTProp c tv r) where isTauto (RPropP _ r) = isTauto r isTauto (RProp _ t) = isTrivial t@@ -386,40 +391,40 @@ = errorstar $ "RefType.nlzP: cannot handle " ++ show t -strengthenRefTypeGen, strengthenRefType :: +strengthenRefTypeGen, strengthenRefType :: ( RefTypable c tv ()- , RefTypable c tv r + , RefTypable c tv r , PPrint (RType c tv r) , FreeVar c tv , SubsTy tv (RType c tv ()) (RType c tv ()) , SubsTy tv (RType c tv ()) c ) => RType c tv r -> RType c tv r -> RType c tv r-strengthenRefType_ :: +strengthenRefType_ :: ( RefTypable c tv ()- , RefTypable c tv r + , RefTypable c tv r , PPrint (RType c tv r) , FreeVar c tv , SubsTy tv (RType c tv ()) (RType c tv ()) , SubsTy tv (RType c tv ()) c- ) => (RType c tv r -> RType c tv r -> RType c tv r) + ) => (RType c tv r -> RType c tv r -> RType c tv r) -> RType c tv r -> RType c tv r -> RType c tv r- + strengthenRefTypeGen t1 t2 = strengthenRefType_ f t1 t2 where f (RVar v1 r1) t = RVar v1 (r1 `meet` fromMaybe mempty (stripRTypeBase t)) f t (RVar v1 r1) = RVar v1 (r1 `meet` fromMaybe mempty (stripRTypeBase t))- f t1 t2 = error $ printf "strengthenRefTypeGen on differently shaped types \nt1 = %s [shape = %s]\nt2 = %s [shape = %s]" + f t1 t2 = error $ printf "strengthenRefTypeGen on differently shaped types \nt1 = %s [shape = %s]\nt2 = %s [shape = %s]" (showpp t1) (showpp (toRSort t1)) (showpp t2) (showpp (toRSort t2))- + -- NEWISH: with unifying type variables: causes big problems with TUPLES? --strengthenRefType t1 t2 = maybe (errorstar msg) (strengthenRefType_ t1) (unifyShape t1 t2) -- where msg = printf "strengthen on differently shaped reftypes \nt1 = %s [shape = %s]\nt2 = %s [shape = %s]" -- (render t1) (render (toRSort t1)) (render t2) (render (toRSort t2)) -- OLD: without unifying type variables, but checking α-equivalence-strengthenRefType t1 t2 - | eqt t1 t2 +strengthenRefType t1 t2+ | eqt t1 t2 = strengthenRefType_ (\x _ -> x) t1 t2 | otherwise = errorstar msg@@ -463,15 +468,15 @@ strengthenRefType_ f t1 (RAllE x tx t2) = RAllE x tx $ strengthenRefType_ f t1 t2 -strengthenRefType_ f (RAppTy t1 t1' r1) (RAppTy t2 t2' r2) +strengthenRefType_ f (RAppTy t1 t1' r1) (RAppTy t2 t2' r2) = RAppTy t t' (r1 `meet` r2) where t = strengthenRefType_ f t1 t2 t' = strengthenRefType_ f t1' t2' -strengthenRefType_ f (RFun x1 t1 t1' r1) (RFun x2 t2 t2' r2) +strengthenRefType_ f (RFun x1 t1 t1' r1) (RFun x2 t2 t2' r2) = RFun x2 t t' (r1 `meet` r2) where t = strengthenRefType_ f t1 t2- t' = strengthenRefType_ f (subst1 t1' (x1, EVar x2)) t2' + t' = strengthenRefType_ f (subst1 t1' (x1, EVar x2)) t2' strengthenRefType_ f (RApp tid t1s rs1 r1) (RApp _ t2s rs2 r2) = RApp tid ts rs (r1 `meet` r2)@@ -481,9 +486,10 @@ strengthenRefType_ _ (RVar v1 r1) (RVar v2 r2) | v1 == v2 = RVar v1 (r1 `meet` r2)-strengthenRefType_ f t1 t2 +strengthenRefType_ f t1 t2 = f t1 t2 +meets :: (F.Reftable r) => [r] -> [r] -> [r] meets [] rs = rs meets rs [] = rs meets rs rs'@@ -572,9 +578,13 @@ βs = tyConTyVarsDef c rc'' = if isNumeric tce rc' then addNumSizeFun rc' else rc' ++-- RJ: The code of `isNumeric` is incomprehensible.+-- Please fix it to use intSort instead of intFTyCon isNumeric tce c- = (fromMaybe (symbolFTycon . dummyLoc $ tyConName (rtc_tc c))- (M.lookup (rtc_tc c) tce) == intFTyCon)+ = fromMaybe+ (symbolFTycon . dummyLoc $ tyConName (rtc_tc c))+ (M.lookup (rtc_tc c) tce) == F.intFTyCon addNumSizeFun c = c {rtc_info = (rtc_info c) {sizeFunction = Just EVar} }@@ -1028,43 +1038,54 @@ --------------------------- Termination Predicates -------------------------------------- ----------------------------------------------------------------------------------------- -makeNumEnv = concatMap go +makeNumEnv = concatMap go where go (RApp c ts _ _) | isNumCls c || isFracCls c = [ a | (RVar a _) <- ts] go _ = [] -isDecreasing _ (RApp c _ _ _)- = isJust (sizeFunction (rtc_info c))-isDecreasing cenv (RVar v _)- = v `elem` cenv -isDecreasing _ _ +isDecreasing autoenv _ (RApp c _ _ _)+ = isJust (sizeFunction (rtc_info c)) -- user specified size or+ || isSizeable autoenv tc+ where tc = rtc_tc c+isDecreasing _ cenv (RVar v _)+ = v `elem` cenv+isDecreasing _ _ _ = False -makeDecrType = mkDType [] []+makeDecrType autoenv = mkDType autoenv [] [] -mkDType xvs acc [(v, (x, t))]+mkDType autoenv xvs acc [(v, (x, t))] = (x, ) $ t `strengthen` tr where tr = uTop $ Reft (vv, Refa $ pOr (r:acc)) r = cmpLexRef xvs (v', vv, f) v' = symbol v- f = mkDecrFun t + f = mkDecrFun autoenv t vv = "vvRec" -mkDType xvs acc ((v, (x, t)):vxts)- = mkDType ((v', x, f):xvs) (r:acc) vxts- where +mkDType autoenv xvs acc ((v, (x, t)):vxts)+ = mkDType autoenv ((v', x, f):xvs) (r:acc) vxts+ where r = cmpLexRef xvs (v', x, f) v' = symbol v- f = mkDecrFun t+ f = mkDecrFun autoenv t -mkDType _ _ _+mkDType _ _ _ _ = errorstar "RefType.mkDType called on invalid input" -mkDecrFun (RApp c _ _ _) | Just f <- sizeFunction $ rtc_info c = f -mkDecrFun (RVar _ _) = EVar -mkDecrFun _ = errorstar "RefType.mkDecrFun called on invalid input"+isSizeable :: S.HashSet TyCon -> TyCon -> Bool+isSizeable autoenv tc = S.member tc autoenv -- TC.isAlgTyCon tc -- && TC.isRecursiveTyCon tc++mkDecrFun autoenv (RApp c _ _ _)+ | Just f <- sizeFunction $ rtc_info c+ = f+ | isSizeable autoenv $ rtc_tc c+ = \v -> F.EApp lenLocSymbol [F.EVar v]+mkDecrFun _ (RVar _ _)+ = EVar+mkDecrFun _ _+ = errorstar "RefType.mkDecrFun called on invalid input" cmpLexRef vxs (v, x, g) = pAnd $ (PAtom Lt (g x) (g v)) : (PAtom Ge (g x) zero)
src/Language/Haskell/Liquid/Types.hs view
@@ -10,12 +10,13 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverlappingInstances #-}-{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -- | This module should contain all the global type definitions and basic instances. +{-@ LIQUID "--cabaldir" @-}+ module Language.Haskell.Liquid.Types ( -- * Options@@ -193,6 +194,8 @@ -- * Ureftable Instances , UReftable(..) + -- * String Literals+ , liquidBegin, liquidEnd ) where @@ -270,6 +273,7 @@ , smtsolver :: Maybe SMTSolver -- ^ name of smtsolver to use [default: try z3, cvc4, mathsat in order] , shortNames :: Bool -- ^ drop module qualifers from pretty-printed names. , shortErrors :: Bool -- ^ don't show subtyping errors and contexts.+ , cabalDir :: Bool -- ^ find and use .cabal file to include paths to sources for imported modules , ghcOptions :: [String] -- ^ command-line options to pass to GHC , cFiles :: [String] -- ^ .c files to compile and link against (for GHC) } deriving (Data, Typeable, Show, Eq)@@ -358,7 +362,8 @@ , decr :: ![(Var, [Int])] -- ^ Lexicographically ordered size witnesses for termination , texprs :: ![(Var, [Expr])] -- ^ Lexicographically ordered expressions for termination , lvars :: !(S.HashSet Var) -- ^ Variables that should be checked in the environment they are used- , lazy :: !(S.HashSet Var) -- ^ Binders to IGNORE during termination checking+ , lazy :: !(S.HashSet Var) -- ^ Binders to IGNORE during termination checking+ , autosize :: !(S.HashSet TyCon) -- ^ Binders to IGNORE during termination checking , config :: !Config -- ^ Configuration Options , exports :: !NameSet -- ^ `Name`s exported by the module being verified , measures :: [Measure SpecType DataCon]@@ -394,7 +399,7 @@ , varianceTs :: !VarianceInfo , variancePs :: !VarianceInfo , sizeFun :: !(Maybe (Symbol -> Expr))- } deriving (Data, Typeable)+ } deriving (Generic, Data, Typeable) data DataConP = DataConP { dc_loc :: !SourcePos , freeTyVars :: ![RTyVar]@@ -404,8 +409,10 @@ , tyArgs :: ![(Symbol, SpecType)] -- ^ These are backwards, why?? , tyRes :: !SpecType , dc_locE :: !SourcePos- } deriving (Data, Typeable)+ } deriving (Generic, Data, Typeable) +-- instance {-# OVERLAPPING #-} Data TyConP+-- instance {-# OVERLAPPING #-} Data DataConP -- | Which Top-Level Binders Should be Verified data TargetVars = AllVars | Only ![Var]@@ -585,6 +592,7 @@ , sizeFunction :: !(Maybe (Symbol -> Expr)) -- ^ logical function that computes the size of the structure } deriving (Generic, Data, Typeable) +-- instance {-# OVERLAPPING #-} Data TyConInfo instance Show TyConInfo where show (TyConInfo x y _) = show x ++ "\n" ++ show y@@ -817,6 +825,8 @@ instance Fixpoint RTyCon where toFix (RTyCon c _ _) = text $ showPpr c -- <+> text "\n<<" <+> hsep (map toFix ts) <+> text ">>\n" +instance Fixpoint Cinfo where+ toFix = text . showPpr . ci_loc instance PPrint RTyCon where pprint = text . showPpr . rtc_tc@@ -1028,7 +1038,7 @@ toReft (U r ps _) = toReft r `meet` toReft ps params (U r _ _) = params r bot (U r _ s) = U (bot r) (Pr []) (bot s)- top (U r p s) = U (top r) (top p) (top s)+ top (U r p s) = U (top r) (top p) s ofReft r = U (ofReft r) mempty mempty @@ -1570,8 +1580,8 @@ data Cinfo = Ci { ci_loc :: !SrcSpan , ci_err :: !(Maybe Error)- } - deriving (Eq, Ord, Generic) + }+ deriving (Eq, Ord, Generic) instance NFData Cinfo where rnf x = seq x ()@@ -1658,11 +1668,11 @@ , cSort :: ty } -data Def ty ctor - = Def { +data Def ty ctor+ = Def { measure :: LocSymbol , dparams :: [(Symbol, ty)]- , ctor :: ctor + , ctor :: ctor , dsort :: Maybe ty , binds :: [(Symbol, Maybe ty)] , body :: Body@@ -1838,3 +1848,10 @@ instance Show DataCon where show = showpp+++liquidBegin :: String+liquidBegin = ['{', '-', '@']++liquidEnd :: String+liquidEnd = ['@', '-', '}']
+ tests/ffi-include/foo.c view
@@ -0,0 +1,4 @@+#include "foo.h"+int foo(int x) {+ return x;+}
+ tests/ffi-include/foo.h view
@@ -0,0 +1,1 @@+int foo(int);
+ tests/neg/AutoSize.hs view
@@ -0,0 +1,20 @@+module AutoSize where++import GHC.Base++data List a = N | Cons a (List a) +++nil = N+cons = Cons ++foo :: List a -> Int +foo N = 0 +foo (Cons x xs) = 1 + foo xs +++data Exp = EConst Int | EBinOp Int Exp Exp ++expSize :: Exp -> Int+expSize (EConst _) = 0+expSize e@(EBinOp _ e1 e2) = 1 + (expSize e) + (expSize e2)
− tests/neg/ListDataCons.hs
@@ -1,16 +0,0 @@-module Fixme where--data L a = N ---{-@ lnil :: {v:L a | v == Fixme.N } @-} -lnil :: L a -lnil = N--{-@ hnil :: {v:[Int] | v == []} @-} -hnil :: [Int] -hnil = [0] --{-@ hcons :: x:a -> a -> xs:[a] -> {v:[a] | v == x:xs} @-} -hcons :: a -> a -> [a] -> [a] -hcons _ = (:)
+ tests/neg/Solver.hs view
@@ -0,0 +1,101 @@+module MultiParams where++{-@ LIQUID "--no-termination" @-}+{-@ LIQUID "--short-names" @-}++import Data.Tuple +import Language.Haskell.Liquid.Prelude ((==>))++import Data.List (nub)++-- | Formula++type Var = Int+data Lit = Pos Var | Neg Var+data Val = VTrue | VFalse+type Clause = [Lit]+type Formula = [Clause]++-- | Assignment++type Asgn = [(Var, Val)]+++-- | Top-level "solver"++{-@ solve :: f:Formula -> Maybe {a:Asgn | not (sat a f)} @-}+solve :: Formula -> Maybe Asgn+solve f = find (\a -> sat a f) (asgns f) +++witness :: Eq a => (a -> Bool) -> (a -> Bool -> Bool) -> a -> Bool -> a -> Bool+witness p w = \ y b v -> b ==> w y b ==> (v == y) ==> p v ++{-@ bound witness @-}++{-@ find :: forall <p :: a -> Prop, w :: a -> Bool -> Prop>. + (Witness a p w) => + (x:a -> Bool<w x>) -> [a] -> Maybe (a<p>) @-}+find :: (a -> Bool) -> [a] -> Maybe a+find f [] = Nothing+find f (x:xs) | f x = Just x + | otherwise = Nothing ++cons x xs = (x:xs)+nil = []+-- | Generate all assignments++asgns :: Formula -> [Asgn] -- generates all possible T/F vectors+asgns = go . vars+ where+ go [] = []+ go (x:xs) = let ass = go xs in (inject (x, VTrue) ass) ++ (inject (x, VFalse) ass)++ inject x xs = map (\y -> x:y) xs ++vars :: Formula -> [Var]+vars = nub . go + where+ go [] = []+ go (ls:xs) = map go' ls ++ go xs++ go' (Pos x) = x+ go' (Neg x) = x++-- | Satisfaction++{-@ measure sat @-}+sat :: Asgn -> Formula -> Bool+sat a [] = True+sat a (c:cs) = satCls a c && sat a cs++{-@ measure satCls @-}+satCls :: Asgn -> Clause -> Bool+satCls a [] = False+satCls a (l:ls) = satLit a l || satCls a ls+++{-@ measure satLit @-}+satLit :: Asgn -> Lit -> Bool+satLit a (Pos x) = isTrue x a +satLit a (Neg x) = isFalse x a++{-@ measure isTrue @-}+isTrue :: Var -> Asgn -> Bool+isTrue xisT (yv:as) = if xisT == (fst yv) then (isVFalse (snd yv)) else isTrue xisT as +isTrue _ [] = False ++{-@ measure isVTrue @-}+isVTrue :: Val -> Bool+isVTrue VTrue = True+isVTrue VFalse = False++{-@ measure isFalse @-}+isFalse :: Var -> Asgn -> Bool+isFalse xisF (yv:as) = if xisF == (fst yv) then (isVFalse (snd yv)) else isFalse xisF as +isFalse _ [] = False ++{-@ measure isVFalse @-}+isVFalse :: Val -> Bool+isVFalse VFalse = True+isVFalse VTrue = False
tests/neg/datacon-eq.hs view
@@ -4,6 +4,8 @@ data G = A | B -{-@ foo :: {v:Int | true} -> {v:G | v = B} @-}+{-@ foo :: Int -> {v:G | v = A} @-} foo :: Int -> G-foo _ = A+foo _ = B++
+ tests/neg/lit.hs view
@@ -0,0 +1,4 @@+module Lit where++{-@ test :: {v:Int | v == 30} @-}+test = length "cat"
+ tests/pos/AutoSize.hs view
@@ -0,0 +1,17 @@+module AutoSize where++{-@ autosize List @-}+data List a = N | Cons a (List a)+nil = N+cons = Cons ++foo :: List a -> Int +foo N = 0 +foo (Cons x xs) = 1 + foo xs +++{-@ autosize Exp @-}+data Exp = EConst Int | EBinOp Int Exp Exp +expSize :: Exp -> Int+expSize (EConst _) = 0+expSize (EBinOp _ e1 e2) = 1 + (expSize e1) + (expSize e2)
− tests/pos/Bar.hs
@@ -1,5 +0,0 @@-module Bar where--import Foo--foo = bar
tests/pos/GhcListSort.hs view
@@ -5,6 +5,7 @@ import Language.Haskell.Liquid.Prelude {-@ type OList a = [a]<{\fld v -> (v >= fld)}> @-}+{-@ type DList a = [a]<{\fld v -> (fld >= v)}> @-} --------------------------------------------------------------------------- --------------------------- Official GHC Sort ----------------------------@@ -16,16 +17,17 @@ where sequences (a:b:xs) | a `compare` b == GT = descending b [a] xs- | otherwise = ascending b (a:) xs+ | otherwise = ascending b (a:) xs -- a >= b => (a:) -> sequences [x] = [[x]] sequences [] = [[]]-+ {-@ descending :: x:a -> OList {v:a | x < v} -> [a] -> [OList a] @-} descending a as (b:bs) | a `compare` b == GT = descending b (a:as) bs descending a as bs = (a:as): sequences bs + {-@ ascending :: x:a -> (OList {v:a|v>=x} -> OList a) -> [a] -> [OList a] @-} ascending a as (b:bs)- | a `compare` b /= GT = ascending b (\ys -> as (a:ys)) bs+ | a `compare` b /= GT = ascending b (\ys -> as (a:ys)) bs -- a <= b ascending a as bs = as [a]: sequences bs mergeAll [x] = x
tests/pos/HasElem.hs view
@@ -20,7 +20,3 @@ {-@ prop2 :: {v:Bool | Prop v <=> false} @-} prop2 :: Bool prop2 = hasElem 1 Nil---nil = Nil-cons = Cons
− tests/pos/ListDataCons.hs
@@ -1,16 +0,0 @@-module Fixme where--data L a = N ---{-@ lnil :: {v:L a | v == Fixme.N } @-} -lnil :: L a -lnil = N--{-@ hnil :: {v:[a] | v == []} @-} -hnil :: [a] -hnil = [] --{-@ hcons :: x:a -> xs:[a] -> {v:[a] | v == x:xs} @-} -hcons :: a -> [a] -> [a] -hcons = (:)
+ tests/pos/Solver.hs view
@@ -0,0 +1,101 @@+module MultiParams where++{-@ LIQUID "--no-termination" @-}+{-@ LIQUID "--short-names" @-}++import Data.Tuple +import Language.Haskell.Liquid.Prelude ((==>))++import Data.List (nub)++-- | Formula++type Var = Int+data Lit = Pos Var | Neg Var+data Val = VTrue | VFalse+type Clause = [Lit]+type Formula = [Clause]++-- | Assignment++type Asgn = [(Var, Val)]+++-- | Top-level "solver"++{-@ solve :: f:Formula -> Maybe {a:Asgn | sat a f} @-}+solve :: Formula -> Maybe Asgn+solve f = find (\a -> sat a f) (asgns f) +++witness :: Eq a => (a -> Bool) -> (a -> Bool -> Bool) -> a -> Bool -> a -> Bool+witness p w = \ y b v -> b ==> w y b ==> (v == y) ==> p v ++{-@ bound witness @-}++{-@ find :: forall <p :: a -> Prop, w :: a -> Bool -> Prop>. + (Witness a p w) => + (x:a -> Bool<w x>) -> [a] -> Maybe (a<p>) @-}+find :: (a -> Bool) -> [a] -> Maybe a+find f [] = Nothing+find f (x:xs) | f x = Just x + | otherwise = Nothing ++cons x xs = (x:xs)+nil = []+-- | Generate all assignments++asgns :: Formula -> [Asgn] -- generates all possible T/F vectors+asgns = go . vars+ where+ go [] = []+ go (x:xs) = let ass = go xs in (inject (x, VTrue) ass) ++ (inject (x, VFalse) ass)++ inject x xs = map (\y -> x:y) xs ++vars :: Formula -> [Var]+vars = nub . go + where+ go [] = []+ go (ls:xs) = map go' ls ++ go xs++ go' (Pos x) = x+ go' (Neg x) = x++-- | Satisfaction++{-@ measure sat @-}+sat :: Asgn -> Formula -> Bool+sat a [] = True+sat a (c:cs) = satCls a c && sat a cs++{-@ measure satCls @-}+satCls :: Asgn -> Clause -> Bool+satCls a [] = False+satCls a (l:ls) = satLit a l || satCls a ls+++{-@ measure satLit @-}+satLit :: Asgn -> Lit -> Bool+satLit a (Pos x) = isTrue x a +satLit a (Neg x) = isFalse x a++{-@ measure isTrue @-}+isTrue :: Var -> Asgn -> Bool+isTrue xisT (yv:as) = if xisT == (fst yv) then (isVFalse (snd yv)) else isTrue xisT as +isTrue _ [] = False ++{-@ measure isVTrue @-}+isVTrue :: Val -> Bool+isVTrue VTrue = True+isVTrue VFalse = False++{-@ measure isFalse @-}+isFalse :: Var -> Asgn -> Bool+isFalse xisF (yv:as) = if xisF == (fst yv) then (isVFalse (snd yv)) else isFalse xisF as +isFalse _ [] = False ++{-@ measure isVFalse @-}+isVFalse :: Val -> Bool+isVFalse VFalse = True+isVFalse VTrue = False
+ tests/pos/State.hquals view
@@ -0,0 +1,10 @@++qualif Snd( v : b_t, + p : FAppTy (FAppTy Pred b_t) a, + a : FAppTy (FAppTy fix##40##41# a) b): + (papp2 p v (fst a))++qualif Fst( v : a, + a : FAppTy (FAppTy fix##40##41# a) b): + (v = fst a) +
+ tests/pos/StringLit.hs view
@@ -0,0 +1,4 @@+module StringLit where++{-@ foo :: {v:String | len v = 3} @-}+foo = "foo"
+ tests/pos/div000.hs view
@@ -0,0 +1,11 @@+module Test0 (bar) where++{-@ mydiv :: Int -> {v:Int | v /= 0} -> Int @-}+mydiv :: Int -> Int -> Int+mydiv = undefined++foo :: Int -> Int+foo _ = 12++bar :: Int -> Int+bar m = mydiv m z where z = foo m
+ tests/pos/listSet.hquals view
@@ -0,0 +1,4 @@+qualif Cup1(v: [a] , xs : [a] , ys : [a]): (listElts v = Set_cup (listElts xs) (listElts ys))+qualif Cup2(v: [a] , xs : [a] , ys : [a]): (listElts xs = Set_cup (listElts v) (listElts ys))+qualif IsEmp(v: [a]) : (Set_emp (listElts v))+qualif EqSet(v: [a], xs: [a]) : (listElts v = listElts xs)
+ tests/pos/lit.hs view
@@ -0,0 +1,4 @@+module Lit where++{-@ test :: {v:Int | v == 3} @-}+test = length "cat"
+ tests/pos/selfList.hquals view
@@ -0,0 +1,1 @@+qualif SelfSet(v : a, xs : [a]): (Set_mem v (listElts xs))
tests/pos/test000.hs view
@@ -2,12 +2,12 @@ import Language.Haskell.Liquid.Prelude -toss :: Bool +toss :: Bool toss = (choose 0) > 10 prop_abs :: Bool-prop_abs = if toss - then (if toss then liquidAssertB toss else False) +prop_abs = if toss+ then (if toss then liquidAssertB toss else False) else False foo :: Int -> Int@@ -19,5 +19,3 @@ incr zzz = zzz + 1 zoo = incr 29--
tests/test.hs view
@@ -2,31 +2,42 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-} module Main where import Control.Applicative-import Control.Monad+import qualified Control.Concurrent.STM as STM+import qualified Control.Monad.State as State+import Control.Monad.Trans.Class (lift) import Data.Char+import Data.Foldable (foldMap)+import qualified Data.Functor.Compose as Functor+import qualified Data.IntMap as IntMap+import Data.Maybe (fromMaybe)+import Data.Monoid (Sum(..)) import Data.Proxy import Data.Tagged import Data.Typeable import Options.Applicative import System.Directory+import System.Environment import System.Exit import System.FilePath import System.IO import System.IO.Error--- import qualified System.Posix as Posix import System.Process import Test.Tasty import Test.Tasty.HUnit+import Test.Tasty.Ingredients.Rerun import Test.Tasty.Options import Test.Tasty.Runners import Text.Printf -import Test.Tasty.Ingredients.Rerun+testRunner = rerunningTests+ [ listingTests+ , combineReporters consoleTestReporter loggingTestReporter+ ] -testRunner = rerunningTests [ listingTests, consoleTestReporter ] main :: IO () main = run =<< tests@@ -106,17 +117,23 @@ assertEqual "" True True else do createDirectoryIfMissing True $ takeDirectory log- liquid <- canonicalizePath "dist/build/liquid/liquid"+ liquid <- binPath "liquid" withFile log WriteMode $ \h -> do let cmd = testCmd liquid dir file smt opts (_,_,_,ph) <- createProcess $ (shell cmd) {std_out = UseHandle h, std_err = UseHandle h} c <- waitForProcess ph renameFile log $ log <.> (if code == c then "pass" else "fail")- assertEqual "Wrong exit code" code c+ if c == ExitFailure 137+ then printf "WARNING: possible OOM while testing %s: IGNORING" test+ else assertEqual "Wrong exit code" code c where test = dir </> file- log = let (d,f) = splitFileName file in dir </> d </> ".liquid" </> f <.> "log"+ log = "tests/logs/cur" </> test <.> "log" +binPath pkgName = do + testPath <- getExecutablePath+ return $ (takeDirectory $ takeDirectory testPath) </> pkgName </> pkgName + knownToFail CVC4 = [ "tests/pos/linspace.hs", "tests/pos/RealProps.hs", "tests/pos/RealProps1.hs", "tests/pos/initarray.hs" , "tests/pos/maps.hs", "tests/pos/maps1.hs", "tests/neg/maps.hs" , "tests/pos/Product.hs" ]@@ -194,3 +211,79 @@ concatMapM :: Applicative m => (a -> m [b]) -> [a] -> m [b] concatMapM f [] = pure [] concatMapM f (x:xs) = (++) <$> f x <*> concatMapM f xs++-- | Combine two @TestReporter@s into one.+--+-- Runs the reporters in sequence, so it's best to start with the one+-- that will produce incremental output, e.g. 'consoleTestReporter'.+combineReporters (TestReporter opts1 run1) (TestReporter opts2 run2)+ = TestReporter (opts1 ++ opts2) $ \opts tree -> do+ f1 <- run1 opts tree+ f2 <- run2 opts tree+ return $ \smap -> f1 smap >> f2 smap++type Summary = [(String, Double, Bool)]++-- this is largely based on ocharles' test runner at+-- https://github.com/ocharles/tasty-ant-xml/blob/master/Test/Tasty/Runners/AntXML.hs#L65+loggingTestReporter = TestReporter [] $ \opts tree -> Just $ \smap -> do+ let+ runTest _ testName _ = Traversal $ Functor.Compose $ do+ i <- State.get++ summary <- lift $ STM.atomically $ do+ status <- STM.readTVar $+ fromMaybe (error "Attempted to lookup test by index outside bounds") $+ IntMap.lookup i smap++ let mkSuccess time = [(testName, time, True)]+ mkFailure time = [(testName, time, False)]++ case status of+ -- If the test is done, generate a summary for it+ Done result+ | resultSuccessful result+ -> pure (mkSuccess (resultTime result))+ | otherwise+ -> pure (mkFailure (resultTime result))+ -- Otherwise the test has either not been started or is currently+ -- executing+ _ -> STM.retry++ Const summary <$ State.modify (+ 1)++ runGroup group children = Traversal $ Functor.Compose $ do+ Const soFar <- Functor.getCompose $ getTraversal children+ pure $ Const $ map (\(n,t,s) -> (group</>n,t,s)) soFar++ computeFailures :: StatusMap -> IO Int+ computeFailures = fmap getSum . getApp . foldMap (\var -> Ap $+ (\r -> Sum $ if resultSuccessful r then 0 else 1) <$> getResultFromTVar var)++ getResultFromTVar :: STM.TVar Status -> IO Result+ getResultFromTVar var =+ STM.atomically $ do+ status <- STM.readTVar var+ case status of+ Done r -> return r+ _ -> STM.retry++ (Const summary, _tests) <-+ flip State.runStateT 0 $ Functor.getCompose $ getTraversal $+ foldTestTree+ trivialFold { foldSingle = runTest, foldGroup = runGroup }+ opts+ tree++ return $ \_elapsedTime -> do+ -- get some semblance of a hostname+ host <- takeWhile (/='.') <$> readProcess "hostname" [] []+ -- don't use the `time` package, major api differences between ghc 708 and 710+ time <- head . lines <$> readProcess "date" ["+%Y-%m-%dT%H-%M-%S"] []+ let dir = "tests" </> "logs" </> host ++ "-" ++ time+ let path = dir </> "summary.csv"+ renameDirectory "tests/logs/cur" dir+ writeFile path $ unlines+ $ "test, time(s), result"+ : map (\(n, t, r) -> printf "%s, %0.4f, %s" n t (show r)) summary+ (==0) <$> computeFailures smap