diff --git a/Liquid.hs b/Liquid.hs --- a/Liquid.hs +++ b/Liquid.hs @@ -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 diff --git a/include/708/Control/Monad.spec b/include/708/Control/Monad.spec new file mode 100644 --- /dev/null +++ b/include/708/Control/Monad.spec @@ -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)} diff --git a/include/710/Data/Traversable.spec b/include/710/Data/Traversable.spec new file mode 100644 --- /dev/null +++ b/include/710/Data/Traversable.spec @@ -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)}) diff --git a/include/GHC/Base.spec b/include/GHC/Base.spec --- a/include/GHC/Base.spec +++ b/include/GHC/Base.spec @@ -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} - - diff --git a/include/GHC/CString.spec b/include/GHC/CString.spec --- a/include/GHC/CString.spec +++ b/include/GHC/CString.spec @@ -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} diff --git a/include/Prelude.spec b/include/Prelude.spec --- a/include/Prelude.spec +++ b/include/Prelude.spec @@ -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 } diff --git a/liquidhaskell.cabal b/liquidhaskell.cabal --- a/liquidhaskell.cabal +++ b/liquidhaskell.cabal @@ -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 diff --git a/src/Language/Haskell/Liquid/ANFTransform.hs b/src/Language/Haskell/Liquid/ANFTransform.hs --- a/src/Language/Haskell/Liquid/ANFTransform.hs +++ b/src/Language/Haskell/Liquid/ANFTransform.hs @@ -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} diff --git a/src/Language/Haskell/Liquid/Annotate.hs b/src/Language/Haskell/Liquid/Annotate.hs --- a/src/Language/Haskell/Liquid/Annotate.hs +++ b/src/Language/Haskell/Liquid/Annotate.hs @@ -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 diff --git a/src/Language/Haskell/Liquid/Bare/Check.hs b/src/Language/Haskell/Liquid/Bare/Check.hs --- a/src/Language/Haskell/Liquid/Bare/Check.hs +++ b/src/Language/Haskell/Liquid/Bare/Check.hs @@ -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 diff --git a/src/Language/Haskell/Liquid/Bare/GhcSpec.hs b/src/Language/Haskell/Liquid/Bare/GhcSpec.hs --- a/src/Language/Haskell/Liquid/Bare/GhcSpec.hs +++ b/src/Language/Haskell/Liquid/Bare/GhcSpec.hs @@ -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 ] diff --git a/src/Language/Haskell/Liquid/Bare/Lookup.hs b/src/Language/Haskell/Liquid/Bare/Lookup.hs --- a/src/Language/Haskell/Liquid/Bare/Lookup.hs +++ b/src/Language/Haskell/Liquid/Bare/Lookup.hs @@ -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 diff --git a/src/Language/Haskell/Liquid/Bare/Measure.hs b/src/Language/Haskell/Liquid/Bare/Measure.hs --- a/src/Language/Haskell/Liquid/Bare/Measure.hs +++ b/src/Language/Haskell/Liquid/Bare/Measure.hs @@ -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 diff --git a/src/Language/Haskell/Liquid/Bare/SymSort.hs b/src/Language/Haskell/Liquid/Bare/SymSort.hs --- a/src/Language/Haskell/Liquid/Bare/SymSort.hs +++ b/src/Language/Haskell/Liquid/Bare/SymSort.hs @@ -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 diff --git a/src/Language/Haskell/Liquid/Cabal.hs b/src/Language/Haskell/Liquid/Cabal.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Cabal.hs @@ -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 }) diff --git a/src/Language/Haskell/Liquid/CmdLine.hs b/src/Language/Haskell/Liquid/CmdLine.hs --- a/src/Language/Haskell/Liquid/CmdLine.hs +++ b/src/Language/Haskell/Liquid/CmdLine.hs @@ -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 () diff --git a/src/Language/Haskell/Liquid/Constraint/Generate.hs b/src/Language/Haskell/Liquid/Constraint/Generate.hs --- a/src/Language/Haskell/Liquid/Constraint/Generate.hs +++ b/src/Language/Haskell/Liquid/Constraint/Generate.hs @@ -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) diff --git a/src/Language/Haskell/Liquid/Constraint/ToFixpoint.hs b/src/Language/Haskell/Liquid/Constraint/ToFixpoint.hs --- a/src/Language/Haskell/Liquid/Constraint/ToFixpoint.hs +++ b/src/Language/Haskell/Liquid/Constraint/ToFixpoint.hs @@ -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 - - - diff --git a/src/Language/Haskell/Liquid/Constraint/Types.hs b/src/Language/Haskell/Liquid/Constraint/Types.hs --- a/src/Language/Haskell/Liquid/Constraint/Types.hs +++ b/src/Language/Haskell/Liquid/Constraint/Types.hs @@ -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 - diff --git a/src/Language/Haskell/Liquid/CoreToLogic.hs b/src/Language/Haskell/Liquid/CoreToLogic.hs --- a/src/Language/Haskell/Liquid/CoreToLogic.hs +++ b/src/Language/Haskell/Liquid/CoreToLogic.hs @@ -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 diff --git a/src/Language/Haskell/Liquid/Desugar710/Check.hs b/src/Language/Haskell/Liquid/Desugar710/Check.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Desugar710/Check.hs @@ -0,0 +1,773 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1997-1998 + +Author: Juan J. Quintela +-} + +{-# 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 diff --git a/src/Language/Haskell/Liquid/Desugar710/Coverage.hs b/src/Language/Haskell/Liquid/Desugar710/Coverage.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Desugar710/Coverage.hs @@ -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 -- 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_()`, 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 diff --git a/src/Language/Haskell/Liquid/Desugar710/Desugar.hs b/src/Language/Haskell/Liquid/Desugar710/Desugar.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Desugar710/Desugar.hs @@ -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) diff --git a/src/Language/Haskell/Liquid/Desugar710/DsArrows.hs b/src/Language/Haskell/Liquid/Desugar710/DsArrows.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Desugar710/DsArrows.hs @@ -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 diff --git a/src/Language/Haskell/Liquid/Desugar710/DsBinds.hs b/src/Language/Haskell/Liquid/Desugar710/DsBinds.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Desugar710/DsBinds.hs @@ -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 = + +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 + +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, 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 = + ... 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 = 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. +-} diff --git a/src/Language/Haskell/Liquid/Desugar710/DsCCall.hs b/src/Language/Haskell/Liquid/Desugar710/DsCCall.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Desugar710/DsCCall.hs @@ -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# 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 diff --git a/src/Language/Haskell/Liquid/Desugar710/DsExpr.hs b/src/Language/Haskell/Liquid/Desugar710/DsExpr.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Desugar710/DsExpr.hs @@ -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:@ where @@ 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 diff --git a/src/Language/Haskell/Liquid/Desugar710/DsExpr.hs-boot b/src/Language/Haskell/Liquid/Desugar710/DsExpr.hs-boot new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Desugar710/DsExpr.hs-boot @@ -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 diff --git a/src/Language/Haskell/Liquid/Desugar710/DsForeign.hs b/src/Language/Haskell/Liquid/Desugar710/DsForeign.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Desugar710/DsForeign.hs @@ -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'' 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" diff --git a/src/Language/Haskell/Liquid/Desugar710/DsGRHSs.hs b/src/Language/Haskell/Liquid/Desugar710/DsGRHSs.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Desugar710/DsGRHSs.hs @@ -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} +-} diff --git a/src/Language/Haskell/Liquid/Desugar710/DsListComp.hs b/src/Language/Haskell/Liquid/Desugar710/DsListComp.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Desugar710/DsListComp.hs @@ -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 <> TE <> + +(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])) } diff --git a/src/Language/Haskell/Liquid/Desugar710/DsMeta.hs b/src/Language/Haskell/Liquid/Desugar710/DsMeta.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Desugar710/DsMeta.hs @@ -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 : 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 diff --git a/src/Language/Haskell/Liquid/Desugar710/DsUtils.hs b/src/Language/Haskell/Liquid/Desugar710/DsUtils.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Desugar710/DsUtils.hs @@ -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) + ] diff --git a/src/Language/Haskell/Liquid/Desugar710/HscMain.hs b/src/Language/Haskell/Liquid/Desugar710/HscMain.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Desugar710/HscMain.hs @@ -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 diff --git a/src/Language/Haskell/Liquid/Desugar710/Match.hs b/src/Language/Haskell/Liquid/Desugar710/Match.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Desugar710/Match.hs @@ -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 +in +\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. +-} diff --git a/src/Language/Haskell/Liquid/Desugar710/Match.hs-boot b/src/Language/Haskell/Liquid/Desugar710/Match.hs-boot new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Desugar710/Match.hs-boot @@ -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 diff --git a/src/Language/Haskell/Liquid/Desugar710/MatchCon.hs b/src/Language/Haskell/Liquid/Desugar710/MatchCon.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Desugar710/MatchCon.hs @@ -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. +-} diff --git a/src/Language/Haskell/Liquid/Desugar710/MatchLit.hs b/src/Language/Haskell/Liquid/Desugar710/MatchLit.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Desugar710/MatchLit.hs @@ -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 + else + +\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)) diff --git a/src/Language/Haskell/Liquid/Errors.hs b/src/Language/Haskell/Liquid/Errors.hs --- a/src/Language/Haskell/Liquid/Errors.hs +++ b/src/Language/Haskell/Liquid/Errors.hs @@ -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 diff --git a/src/Language/Haskell/Liquid/GhcInterface.hs b/src/Language/Haskell/Liquid/GhcInterface.hs --- a/src/Language/Haskell/Liquid/GhcInterface.hs +++ b/src/Language/Haskell/Liquid/GhcInterface.hs @@ -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") diff --git a/src/Language/Haskell/Liquid/GhcMisc.hs b/src/Language/Haskell/Liquid/GhcMisc.hs --- a/src/Language/Haskell/Liquid/GhcMisc.hs +++ b/src/Language/Haskell/Liquid/GhcMisc.hs @@ -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 diff --git a/src/Language/Haskell/Liquid/Literals.hs b/src/Language/Haskell/Liquid/Literals.hs --- a/src/Language/Haskell/Liquid/Literals.hs +++ b/src/Language/Haskell/Liquid/Literals.hs @@ -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 diff --git a/src/Language/Haskell/Liquid/Measure.hs b/src/Language/Haskell/Liquid/Measure.hs --- a/src/Language/Haskell/Liquid/Measure.hs +++ b/src/Language/Haskell/Liquid/Measure.hs @@ -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] diff --git a/src/Language/Haskell/Liquid/Names.hs b/src/Language/Haskell/Liquid/Names.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Names.hs @@ -0,0 +1,6 @@ +module Language.Haskell.Liquid.Names where + +import Language.Fixpoint.Types + + +lenLocSymbol = dummyLoc $ symbol ("autolen" :: String) diff --git a/src/Language/Haskell/Liquid/Parse.hs b/src/Language/Haskell/Liquid/Parse.hs --- a/src/Language/Haskell/Liquid/Parse.hs +++ b/src/Language/Haskell/Liquid/Parse.hs @@ -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 ------------------------ --------------------------------------------------------------- diff --git a/src/Language/Haskell/Liquid/PredType.hs b/src/Language/Haskell/Liquid/PredType.hs --- a/src/Language/Haskell/Liquid/PredType.hs +++ b/src/Language/Haskell/Liquid/PredType.hs @@ -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]] diff --git a/src/Language/Haskell/Liquid/RefType.hs b/src/Language/Haskell/Liquid/RefType.hs --- a/src/Language/Haskell/Liquid/RefType.hs +++ b/src/Language/Haskell/Liquid/RefType.hs @@ -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) diff --git a/src/Language/Haskell/Liquid/Types.hs b/src/Language/Haskell/Liquid/Types.hs --- a/src/Language/Haskell/Liquid/Types.hs +++ b/src/Language/Haskell/Liquid/Types.hs @@ -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 = ['@', '-', '}'] diff --git a/tests/ffi-include/foo.c b/tests/ffi-include/foo.c new file mode 100644 --- /dev/null +++ b/tests/ffi-include/foo.c @@ -0,0 +1,4 @@ +#include "foo.h" +int foo(int x) { + return x; +} diff --git a/tests/ffi-include/foo.h b/tests/ffi-include/foo.h new file mode 100644 --- /dev/null +++ b/tests/ffi-include/foo.h @@ -0,0 +1,1 @@ +int foo(int); diff --git a/tests/neg/AutoSize.hs b/tests/neg/AutoSize.hs new file mode 100644 --- /dev/null +++ b/tests/neg/AutoSize.hs @@ -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) diff --git a/tests/neg/ListDataCons.hs b/tests/neg/ListDataCons.hs deleted file mode 100644 --- a/tests/neg/ListDataCons.hs +++ /dev/null @@ -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 _ = (:) diff --git a/tests/neg/Solver.hs b/tests/neg/Solver.hs new file mode 100644 --- /dev/null +++ b/tests/neg/Solver.hs @@ -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

Prop, w :: a -> Bool -> Prop>. + (Witness a p w) => + (x:a -> Bool) -> [a] -> Maybe (a

) @-} +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 diff --git a/tests/neg/datacon-eq.hs b/tests/neg/datacon-eq.hs --- a/tests/neg/datacon-eq.hs +++ b/tests/neg/datacon-eq.hs @@ -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 + + diff --git a/tests/neg/lit.hs b/tests/neg/lit.hs new file mode 100644 --- /dev/null +++ b/tests/neg/lit.hs @@ -0,0 +1,4 @@ +module Lit where + +{-@ test :: {v:Int | v == 30} @-} +test = length "cat" diff --git a/tests/pos/AutoSize.hs b/tests/pos/AutoSize.hs new file mode 100644 --- /dev/null +++ b/tests/pos/AutoSize.hs @@ -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) diff --git a/tests/pos/Bar.hs b/tests/pos/Bar.hs deleted file mode 100644 --- a/tests/pos/Bar.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Bar where - -import Foo - -foo = bar diff --git a/tests/pos/GhcListSort.hs b/tests/pos/GhcListSort.hs --- a/tests/pos/GhcListSort.hs +++ b/tests/pos/GhcListSort.hs @@ -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 diff --git a/tests/pos/HasElem.hs b/tests/pos/HasElem.hs --- a/tests/pos/HasElem.hs +++ b/tests/pos/HasElem.hs @@ -20,7 +20,3 @@ {-@ prop2 :: {v:Bool | Prop v <=> false} @-} prop2 :: Bool prop2 = hasElem 1 Nil - - -nil = Nil -cons = Cons diff --git a/tests/pos/ListDataCons.hs b/tests/pos/ListDataCons.hs deleted file mode 100644 --- a/tests/pos/ListDataCons.hs +++ /dev/null @@ -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 = (:) diff --git a/tests/pos/Solver.hs b/tests/pos/Solver.hs new file mode 100644 --- /dev/null +++ b/tests/pos/Solver.hs @@ -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

Prop, w :: a -> Bool -> Prop>. + (Witness a p w) => + (x:a -> Bool) -> [a] -> Maybe (a

) @-} +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 diff --git a/tests/pos/State.hquals b/tests/pos/State.hquals new file mode 100644 --- /dev/null +++ b/tests/pos/State.hquals @@ -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) + diff --git a/tests/pos/StringLit.hs b/tests/pos/StringLit.hs new file mode 100644 --- /dev/null +++ b/tests/pos/StringLit.hs @@ -0,0 +1,4 @@ +module StringLit where + +{-@ foo :: {v:String | len v = 3} @-} +foo = "foo" diff --git a/tests/pos/div000.hs b/tests/pos/div000.hs new file mode 100644 --- /dev/null +++ b/tests/pos/div000.hs @@ -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 diff --git a/tests/pos/listSet.hquals b/tests/pos/listSet.hquals new file mode 100644 --- /dev/null +++ b/tests/pos/listSet.hquals @@ -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) diff --git a/tests/pos/lit.hs b/tests/pos/lit.hs new file mode 100644 --- /dev/null +++ b/tests/pos/lit.hs @@ -0,0 +1,4 @@ +module Lit where + +{-@ test :: {v:Int | v == 3} @-} +test = length "cat" diff --git a/tests/pos/selfList.hquals b/tests/pos/selfList.hquals new file mode 100644 --- /dev/null +++ b/tests/pos/selfList.hquals @@ -0,0 +1,1 @@ +qualif SelfSet(v : a, xs : [a]): (Set_mem v (listElts xs)) diff --git a/tests/pos/test000.hs b/tests/pos/test000.hs --- a/tests/pos/test000.hs +++ b/tests/pos/test000.hs @@ -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 - - diff --git a/tests/test.hs b/tests/test.hs --- a/tests/test.hs +++ b/tests/test.hs @@ -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) -> (groupn,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